###############
## Section 5 ##
###############

#install.packages("mlogit")
library(mlogit)
library(MASS)

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

bes.data.raw <- read.csv("BES2015.csv", header=TRUE)

bes.data <- mlogit.data(bes.data.raw, choice="vote", shape="long", chid.var="respondent_id", alt.var="party_id")

###############
## Table 5.1 ##
###############

bes2015.mnl <- mlogit(vote ~ taxspend | approve_EU + NHS_improved + income + female + age, data=bes.data, reflevel=4)
bes2015.mnl.results <- cbind(bes2015.mnl$coefficients, sqrt(diag(vcov(bes2015.mnl))), confint.default(bes2015.mnl, level=0.95))
N <- length(unique(bes.data$respondent_id))
A <- nrow(bes.data)
colnames(bes2015.mnl.results) <- c("Coeff", "(se)", "2.5%", "97.5%")
print((round(bes2015.mnl.results, digits=3)))
print(N)
print(A)

###############
## Table 5.2 ##
###############

beta <- bes2015.mnl$coefficients
covmat.beta <- vcov(bes2015.mnl)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

baseline.x <- with(bes.data, data.frame(
constant = rbind(0, diag(3)),
taxspend = tapply(taxspend, idx(bes2015.mnl, 2), median),
approve_EU = median(approve_EU) * rbind(0, diag(3)),
NHS_improved = median(NHS_improved) * rbind(0, diag(3)),
income=median(income) * rbind(0, diag(3)),
female=median(female) * rbind(0, diag(3)),
age=median(age) * rbind(0, diag(3))
))

baseline.x <- baseline.x[order(rownames(baseline.x)),]

approveEUcol <- grep("approve_EU", colnames(baseline.x))
diff.x <- baseline.x
diff.x[,approveEUcol] <- rbind(diag(3), 0) * 2

exb.baseline <- exp(betadraw %*% t(baseline.x))
exb.diff <- exp(betadraw %*% t(diff.x))

probs.baseline <- exb.baseline/rowSums(exb.baseline)
probs.diff <- exb.diff/rowSums(exb.diff)

simprob.diff <- probs.diff - probs.baseline

all.results <- cbind(probs.baseline, probs.diff, simprob.diff)

quantiles <- apply(all.results, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(all.results, 2, sd)
first.differences <- cbind(t(quantiles), sds)
colnames(first.differences) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(first.differences) <- c("Neutral:Conservative", "Neutral:Labour", "Neutral:LibDem", "Neutral:UKIP", "Disapprove:Conservative", "Disapprove:Labour", "Disapprove:LibDem", "Disapprove:UKIP", "Diff:Conservative", "Diff:Labour", "Diff:LibDem", "Diff:UKIP")
print(round(first.differences, digits=3))

#################
## Figure 5.1 ##
#################

beta <- bes2015.mnl$coefficients
covmat.beta <- vcov(bes2015.mnl)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

baseline.x <- with(bes.data, data.frame(
constant = rbind(0, diag(3)),
taxspend = tapply(taxspend, idx(bes2015.mnl, 2), median),
approve_EU = median(approve_EU) * rbind(0, diag(3)),
NHS_improved = median(NHS_improved) * rbind(0, diag(3)),
income = median(income) * rbind(0, diag(3)),
female = median(female) * rbind(0, diag(3)),
age = median(age) * rbind(0, diag(3))
))

## the reference level is always first in idx
# reorder rows to avoid confusion
baseline.x <- baseline.x[order(rownames(baseline.x)),]

agecols <- grep("age", colnames(baseline.x))
age.range <- c(10:100)

mlogit.probs1 <- matrix(NA, ndraws, length(age.range))
mlogit.probs2 <- matrix(NA, ndraws, length(age.range))
mlogit.probs3 <- matrix(NA, ndraws, length(age.range))
mlogit.probs4 <- matrix(NA, ndraws, length(age.range))

mlogit.mean.probs <- matrix(NA, 4, length(age.range))

for (i in 1:length(age.range)) {

	baseline.x[,agecols] <- rbind(diag(3), 0) * age.range[i]
	exb <- exp(betadraw %*% t(baseline.x))

	mlogit.probs1[,i] <- exb[,1]/rowSums(exb)
	mlogit.probs2[,i] <- exb[,2]/rowSums(exb)
	mlogit.probs3[,i] <- exb[,3]/rowSums(exb)
	mlogit.probs4[,i] <- exb[,4]/rowSums(exb)

	mprobs.mean <- exp(beta%*%t(baseline.x))
	mlogit.mean.probs[1,i] <- mprobs.mean[1]/sum(mprobs.mean)
	mlogit.mean.probs[2,i] <- mprobs.mean[2]/sum(mprobs.mean)
	mlogit.mean.probs[3,i] <- mprobs.mean[3]/sum(mprobs.mean)
	mlogit.mean.probs[4,i] <- mprobs.mean[4]/sum(mprobs.mean)

}

# Conservative, Labour, Liberal Democrat, UKIP

colors <- c("#47E3FF80", "#FF634780", "#B1D87780","#6347FF80")

pdf("fig51.pdf")
par(mar=c(5.1, 4.1, 4.1, 5.6), mgp=c(2.5, 1, 0), cex.lab=1.5)
plot(mlogit.mean.probs[1,]~age.range, xlim=c(18,90), ylim=c(0,0.8), type="n", xlab="Age", ylab="Probability", xaxt="n", las=1)
axis(1, at=c(18, 30, 40, 50, 60, 70, 80, 90))
for (i in 1:length(age.range)){
	points(mlogit.probs1[i,] ~ age.range, type="l", col=colors[1], lwd=1)
	points(mlogit.probs2[i,] ~ age.range, type="l", col=colors[2], lwd=1)
	points(mlogit.probs3[i,] ~ age.range, type="l", col=colors[3], lwd=1)
	points(mlogit.probs4[i,] ~ age.range, type="l", col=colors[4], lwd=1)
}
lines(mlogit.mean.probs[1,]~age.range, col=rgb(0,0,0,0.5), lwd=2)
lines(mlogit.mean.probs[2,]~age.range, col=rgb(0,0,0,0.5), lwd=2)
lines(mlogit.mean.probs[3,]~age.range, col=rgb(0,0,0,0.5), lwd=2)
lines(mlogit.mean.probs[4,]~age.range, col=rgb(0,0,0,0.5), lwd=2)
mtext("Conservative", side=4, at=mlogit.mean.probs[1,84], cex=1.1, las=1, line=0.3)
mtext("Labour", side=4, at=mlogit.mean.probs[2,84]+0.02, cex=1.1, las=1, line=0.3)
mtext("Liberal", side=4, at=mlogit.mean.probs[3,84]-0.01, cex=1.1, las=1, line=0.3)
mtext("Democrat", side=4, at=mlogit.mean.probs[3,84]-0.04, cex=1.1, las=1, line=0.3)
mtext("UKIP", side=4, at=mlogit.mean.probs[4,84], cex=1.1, las=1, line=0.3)
dev.off()

#################
## Figure 5.2 ##
#################

beta <- bes2015.mnl$coefficients
covmat.beta <- vcov(bes2015.mnl)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

baseline.x <- with(bes.data, data.frame(
constant = rbind(0, diag(3)),
taxspend = tapply(taxspend, idx(bes2015.mnl, 2), median),
approve_EU = median(approve_EU) * rbind(0, diag(3)),
NHS_improved = median(NHS_improved) * rbind(0, diag(3)),
income = median(income) * rbind(0, diag(3)),
female = median(female) * rbind(0, diag(3)),
age = median(age) * rbind(0, diag(3))
))

baseline.x <- baseline.x[order(rownames(baseline.x)),]

taxspendcol <- grep("taxspend", colnames(baseline.x))
taxspend.range <- seq(-5,15,0.1)
mlogit.probs1 <- matrix(NA, ndraws, length(taxspend.range))
mlogit.probs2 <- matrix(NA, ndraws, length(taxspend.range))
mlogit.probs3 <- matrix(NA, ndraws, length(taxspend.range))
mlogit.probs4 <- matrix(NA, ndraws, length(taxspend.range))

mlogit.mean.probs <- matrix(NA, 4, length(taxspend.range))

for (i in 1:length(taxspend.range)) {

	baseline.x[rownames(baseline.x)=="4", taxspendcol] <- taxspend.range[i]
	exb <- exp(betadraw %*% t(baseline.x))
	mlogit.probs1[,i] <- exb[,1]/rowSums(exb)
	mlogit.probs2[,i] <- exb[,2]/rowSums(exb)
	mlogit.probs3[,i] <- exb[,3]/rowSums(exb)
	mlogit.probs4[,i] <- exb[,4]/rowSums(exb)

	mprobs.mean <- exp(beta%*%t(baseline.x))
	mlogit.mean.probs[1,i] <- mprobs.mean[1]/sum(mprobs.mean)
	mlogit.mean.probs[2,i] <- mprobs.mean[2]/sum(mprobs.mean)
	mlogit.mean.probs[3,i] <- mprobs.mean[3]/sum(mprobs.mean)
	mlogit.mean.probs[4,i] <- mprobs.mean[4]/sum(mprobs.mean)
}

# Conservative, Labour, Liberal Democrat, UKIP

colors <- c("#47E3FF80", "#FF634780", "#B1D87780","#6347FF80")

pdf("fig52.pdf")
par(mar=c(5.1, 4.1, 4.1, 5.6), mgp=c(2.5, 1, 0), cex.lab=1.5)
plot(mlogit.mean.probs[1,]~taxspend.range, xlim=c(1,10), ylim=c(0,0.6), type="n", xlab="Tax/Spend Scale", ylab="Probability", xaxt="n", las=1)
axis(1, at=c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10))
for (i in 1:length(taxspend.range)){
	points(mlogit.probs1[i,] ~ taxspend.range, type="l", col=colors[1], lwd=1)
	points(mlogit.probs2[i,] ~ taxspend.range, type="l", col=colors[2], lwd=1)
	points(mlogit.probs3[i,] ~ taxspend.range, type="l", col=colors[3], lwd=1)
	points(mlogit.probs4[i,] ~ taxspend.range, type="l", col=colors[4], lwd=1)
}
lines(mlogit.mean.probs[1,]~taxspend.range, col=rgb(0,0,0,0.5), lwd=2)
lines(mlogit.mean.probs[2,]~taxspend.range, col=rgb(0,0,0,0.5), lwd=2)
lines(mlogit.mean.probs[3,]~taxspend.range, col=rgb(0,0,0,0.5), lwd=2)
lines(mlogit.mean.probs[4,]~taxspend.range, col=rgb(0,0,0,0.5), lwd=2)
mtext("Conservative", side=4, at=mlogit.mean.probs[1,156], cex=1.1, las=1, line=0.3)
mtext("Labour", side=4, at=mlogit.mean.probs[2,156], cex=1.1, las=1, line=0.3)
mtext("Liberal", side=4, at=mlogit.mean.probs[3,156]+0.01, cex=1.1, las=1, line=0.3)
mtext("Democrat", side=4, at=mlogit.mean.probs[3,156]-0.01, cex=1.1, las=1, line=0.3)
mtext("UKIP", side=4, at=mlogit.mean.probs[4,156], cex=1.1, las=1, line=0.3)
dev.off()

###############
## Table 5.3 ##
###############

beta <- bes2015.mnl$coefficients
covmat.beta <- vcov(bes2015.mnl)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

## observed

observed.x <- with(bes.data, data.frame(
cons1 = as.numeric(idx[2]==1),
cons2 = as.numeric(idx[2]==2),
cons3 = as.numeric(idx[2]==3),
taxspend = taxspend,
approve_EU1 = approve_EU * as.numeric(idx[2]==1),
approve_EU2 = approve_EU * as.numeric(idx[2]==2),
approve_EU3 = approve_EU * as.numeric(idx[2]==3),
NHS_improved1 = NHS_improved * as.numeric(idx[2]==1),
NHS_improved2 = NHS_improved * as.numeric(idx[2]==2),
NHS_improved3 = NHS_improved * as.numeric(idx[2]==3),
income1 = income * as.numeric(idx[2]==1),
income2 = income * as.numeric(idx[2]==2),
income3 = income * as.numeric(idx[2]==3),
female1 = female * as.numeric(idx[2]==1),
female2 = female * as.numeric(idx[2]==2),
female3 = female * as.numeric(idx[2]==3),
age1 = age * as.numeric(idx[2]==1),
age2 = age * as.numeric(idx[2]==2),
age3 = age * as.numeric(idx[2]==3),
id = idx,
weights = wt_combined_main
))

exb.party1.o <- exp(betadraw %*% t(subset(observed.x, id.alt==1, select=c(1:19))))
exb.party2.o <- exp(betadraw %*% t(subset(observed.x, id.alt==2, select=c(1:19))))
exb.party3.o <- exp(betadraw %*% t(subset(observed.x, id.alt==3, select=c(1:19))))
exb.party4.o <- exp(betadraw %*% t(subset(observed.x, id.alt==4, select=c(1:19))))
exb.all.o <- exb.party1.o + exb.party2.o + exb.party3.o + exb.party4.o

probs1.o <- exb.party1.o/exb.all.o
probs2.o <- exb.party2.o/exb.all.o
probs3.o <- exb.party3.o/exb.all.o
probs4.o <- exb.party4.o/exb.all.o

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

shares.party1.o <- colSums(apply(probs1.o, 1, function(x){x * id.weights}))/sum(id.weights) * 100
shares.party2.o <- colSums(apply(probs2.o, 1, function(x){x * id.weights}))/sum(id.weights) * 100
shares.party3.o <- colSums(apply(probs3.o, 1, function(x){x * id.weights}))/sum(id.weights) * 100
shares.party4.o <- colSums(apply(probs4.o, 1, function(x){x * id.weights}))/sum(id.weights) * 100

## counterfactual

counterfactual.x <- observed.x
counterfactual.x$rand.draw <- rep(runif(length(unique(counterfactual.x$id.chid))), each=4)
counterfactual.x$approve_EU1[counterfactual.x$approve_EU1 > 1 & counterfactual.x$rand.draw <= 0.25] <- counterfactual.x$approve_EU1[counterfactual.x$approve_EU1 > 1 & counterfactual.x$rand.draw <= 0.25] - 1
counterfactual.x$approve_EU2[counterfactual.x$approve_EU2 > 1 & counterfactual.x$rand.draw <= 0.25] <- counterfactual.x$approve_EU2[counterfactual.x$approve_EU2 > 1 & counterfactual.x$rand.draw <= 0.25] - 1
counterfactual.x$approve_EU3[counterfactual.x$approve_EU3 > 1 & counterfactual.x$rand.draw <= 0.25] <- counterfactual.x$approve_EU3[counterfactual.x$approve_EU3 > 1 & counterfactual.x$rand.draw <= 0.25] - 1

exb.party1.c <- exp(betadraw %*% t(subset(counterfactual.x, id.alt==1, select=c(1:19))))
exb.party2.c <- exp(betadraw %*% t(subset(counterfactual.x, id.alt==2, select=c(1:19))))
exb.party3.c <- exp(betadraw %*% t(subset(counterfactual.x, id.alt==3, select=c(1:19))))
exb.party4.c <- exp(betadraw %*% t(subset(counterfactual.x, id.alt==4, select=c(1:19))))
exb.all.c <- exb.party1.c + exb.party2.c + exb.party3.c + exb.party4.c

probs1.c <- exb.party1.c/exb.all.c
probs2.c <- exb.party2.c/exb.all.c
probs3.c <- exb.party3.c/exb.all.c
probs4.c <- exb.party4.c/exb.all.c

shares.party1.c <- colSums(apply(probs1.c, 1, function(x){x * id.weights}))/sum(id.weights) * 100
shares.party2.c <- colSums(apply(probs2.c, 1, function(x){x * id.weights}))/sum(id.weights) * 100
shares.party3.c <- colSums(apply(probs3.c, 1, function(x){x * id.weights}))/sum(id.weights) * 100
shares.party4.c <- colSums(apply(probs4.c, 1, function(x){x * id.weights}))/sum(id.weights) * 100

## difference

probs1.diff <- probs1.c - probs1.o
probs2.diff <- probs2.c - probs2.o
probs3.diff <- probs3.c - probs3.o
probs4.diff <- probs4.c - probs4.o

shares.party1.diff <- colSums(apply(probs1.diff, 1, function(x){x * id.weights}))/sum(id.weights) * 100
shares.party2.diff <- colSums(apply(probs2.diff, 1, function(x){x * id.weights}))/sum(id.weights) * 100
shares.party3.diff <- colSums(apply(probs3.diff, 1, function(x){x * id.weights}))/sum(id.weights) * 100
shares.party4.diff <- colSums(apply(probs4.diff, 1, function(x){x * id.weights}))/sum(id.weights) * 100

all.results <- cbind(shares.party1.o, shares.party2.o, shares.party3.o, shares.party4.o, shares.party1.c, shares.party2.c, shares.party3.c, shares.party4.c, shares.party1.diff, shares.party2.diff, shares.party3.diff, shares.party4.diff)

quantiles <- apply(all.results, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(all.results, 2, sd)
first.differences <- cbind(t(quantiles), sds)
colnames(first.differences) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(first.differences) <- c("Neutral:Conservative", "Neutral:Labour", "Neutral:LibDem", "Neutral:UKIP", "Disapprove:Conservative", "Disapprove:Labour", "Disapprove:LibDem", "Disapprove:UKIP", "Diff:Conservative", "Diff:Labour", "Diff:LibDem", "Diff:UKIP")
print(round(first.differences, digits=3))

###############
## Table 5.4 ##
###############

beta <- bes2015.mnl$coefficients
covmat.beta <- vcov(bes2015.mnl)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

approveEU.coeffs <- cbind(betadraw[,grep("approve_EU", colnames(betadraw))], 0)

## AME ##

observed.x <- with(bes.data, data.frame(
cons1 = as.numeric(idx[2]==1),
cons2 = as.numeric(idx[2]==2),
cons3 = as.numeric(idx[2]==3),
taxspend = taxspend,
approve_EU1 = approve_EU * as.numeric(idx[2]==1),
approve_EU2 = approve_EU * as.numeric(idx[2]==2),
approve_EU3 = approve_EU * as.numeric(idx[2]==3),
NHS_improved1 = NHS_improved * as.numeric(idx[2]==1),
NHS_improved2 = NHS_improved * as.numeric(idx[2]==2),
NHS_improved3 = NHS_improved * as.numeric(idx[2]==3),
income1 = income * as.numeric(idx[2]==1),
income2 = income * as.numeric(idx[2]==2),
income3 = income * as.numeric(idx[2]==3),
female1 = female * as.numeric(idx[2]==1),
female2 = female * as.numeric(idx[2]==2),
female3 = female * as.numeric(idx[2]==3),
age1 = age * as.numeric(idx[2]==1),
age2 = age * as.numeric(idx[2]==2),
age3 = age * as.numeric(idx[2]==3),
id = idx,
weights = wt_combined_main
))

approveEU <- observed.x[observed.x$id.alt==1, grep("approve_EU1", colnames(observed.x))]

exb.party1 <- exp(betadraw %*% t(subset(observed.x, id.alt==1, select=c(1:19))))
exb.party2 <- exp(betadraw %*% t(subset(observed.x, id.alt==2, select=c(1:19))))
exb.party3 <- exp(betadraw %*% t(subset(observed.x, id.alt==3, select=c(1:19))))
exb.party4 <- exp(betadraw %*% t(subset(observed.x, id.alt==4, select=c(1:19))))
exb.all <- exb.party1 + exb.party2 + exb.party3 + exb.party4

probs1 <- exb.party1/exb.all
probs2 <- exb.party2/exb.all
probs3 <- exb.party3/exb.all
probs4 <- exb.party4/exb.all

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

## marginal effects

me.approveEU.1 <- probs1 * (approveEU.coeffs[,1] - ((probs1 * approveEU.coeffs[,1]) + (probs2 * approveEU.coeffs[,2]) + (probs3 * approveEU.coeffs[,3]) + (probs4 * approveEU.coeffs[,4])))
me.approveEU.2 <- probs2 * (approveEU.coeffs[,2] - ((probs1 * approveEU.coeffs[,1]) + (probs2 * approveEU.coeffs[,2]) + (probs3 * approveEU.coeffs[,3]) + (probs4 * approveEU.coeffs[,4])))
me.approveEU.3 <- probs3 * (approveEU.coeffs[,3] - ((probs1 * approveEU.coeffs[,1]) + (probs2 * approveEU.coeffs[,2]) + (probs3 * approveEU.coeffs[,3]) + (probs4 * approveEU.coeffs[,4])))
me.approveEU.4 <- probs4 * (approveEU.coeffs[,4] - ((probs1 * approveEU.coeffs[,1]) + (probs2 * approveEU.coeffs[,2]) + (probs3 * approveEU.coeffs[,3]) + (probs4 * approveEU.coeffs[,4])))

me.AME.approveEU.1 <- colSums(apply(me.approveEU.1, 1, function(x){x * id.weights}))/sum(id.weights)
me.AME.approveEU.2 <- colSums(apply(me.approveEU.2, 1, function(x){x * id.weights}))/sum(id.weights)
me.AME.approveEU.3 <- colSums(apply(me.approveEU.3, 1, function(x){x * id.weights}))/sum(id.weights)
me.AME.approveEU.4 <- colSums(apply(me.approveEU.4, 1, function(x){x * id.weights}))/sum(id.weights)

## elasticities

e.approveEU.1 <- approveEU * (approveEU.coeffs[,1] - ((probs1 * approveEU.coeffs[,1]) + (probs2 * approveEU.coeffs[,2]) + (probs3 * approveEU.coeffs[,3]) + (probs4 * approveEU.coeffs[,4])))
e.approveEU.2 <- approveEU * (approveEU.coeffs[,2] - ((probs1 * approveEU.coeffs[,1]) + (probs2 * approveEU.coeffs[,2]) + (probs3 * approveEU.coeffs[,3]) + (probs4 * approveEU.coeffs[,4])))
e.approveEU.3 <- approveEU * (approveEU.coeffs[,3] - ((probs1 * approveEU.coeffs[,1]) + (probs2 * approveEU.coeffs[,2]) + (probs3 * approveEU.coeffs[,3]) + (probs4 * approveEU.coeffs[,4])))
e.approveEU.4 <- approveEU * (approveEU.coeffs[,4] - ((probs1 * approveEU.coeffs[,1]) + (probs2 * approveEU.coeffs[,2]) + (probs3 * approveEU.coeffs[,3]) + (probs4 * approveEU.coeffs[,4])))

e.AME.approveEU.1 <- colSums(apply(e.approveEU.1, 1, function(x){x * id.weights}))/sum(id.weights)
e.AME.approveEU.2 <- colSums(apply(e.approveEU.2, 1, function(x){x * id.weights}))/sum(id.weights)
e.AME.approveEU.3 <- colSums(apply(e.approveEU.3, 1, function(x){x * id.weights}))/sum(id.weights)
e.AME.approveEU.4 <- colSums(apply(e.approveEU.4, 1, function(x){x * id.weights}))/sum(id.weights)

## MEM ##

mean.x <- with(bes.data, data.frame(
constant = rbind(0, diag(3)),
taxspend = tapply(taxspend, idx(bes2015.mnl, 2), mean),
approve_EU = mean(approve_EU) * rbind(0, diag(3)),
NHS_improved = mean(NHS_improved) * rbind(0, diag(3)),
income=mean(income) * rbind(0, diag(3)),
female=mean(female) * rbind(0, diag(3)),
age=mean(age) * rbind(0, diag(3))
))

mean.x <- mean.x[order(rownames(mean.x)),]
mean.approveEU <- mean(bes.data$approve_EU)

exb.mean <- exp(betadraw %*% t(mean.x))

probs.mean <- exb.mean/rowSums(exb.mean)

## marginal effects

me.MEM.approveEU.1 <- probs.mean[,1] * (approveEU.coeffs[,1] - ((probs.mean[,1] * approveEU.coeffs[,1]) + (probs.mean[,2] * approveEU.coeffs[,2]) + (probs.mean[,3] * approveEU.coeffs[,3]) + (probs.mean[,4] * approveEU.coeffs[,4])))
me.MEM.approveEU.2 <- probs.mean[,2] * (approveEU.coeffs[,2] - ((probs.mean[,1] * approveEU.coeffs[,1]) + (probs.mean[,2] * approveEU.coeffs[,2]) + (probs.mean[,3] * approveEU.coeffs[,3]) + (probs.mean[,4] * approveEU.coeffs[,4])))
me.MEM.approveEU.3 <- probs.mean[,3] * (approveEU.coeffs[,3] - ((probs.mean[,1] * approveEU.coeffs[,1]) + (probs.mean[,2] * approveEU.coeffs[,2]) + (probs.mean[,3] * approveEU.coeffs[,3]) + (probs.mean[,4] * approveEU.coeffs[,4])))
me.MEM.approveEU.4 <- probs.mean[,4] * (approveEU.coeffs[,4] - ((probs.mean[,1] * approveEU.coeffs[,1]) + (probs.mean[,2] * approveEU.coeffs[,2]) + (probs.mean[,3] * approveEU.coeffs[,3]) + (probs.mean[,4] * approveEU.coeffs[,4])))

## elasticities

e.MEM.approveEU.1 <- mean.approveEU * (approveEU.coeffs[,1] - ((probs.mean[,1] * approveEU.coeffs[,1]) + (probs.mean[,2] * approveEU.coeffs[,2]) + (probs.mean[,3] * approveEU.coeffs[,3]) + (probs.mean[,4] * approveEU.coeffs[,4])))
e.MEM.approveEU.2 <- mean.approveEU * (approveEU.coeffs[,2] - ((probs.mean[,1] * approveEU.coeffs[,1]) + (probs.mean[,2] * approveEU.coeffs[,2]) + (probs.mean[,3] * approveEU.coeffs[,3]) + (probs.mean[,4] * approveEU.coeffs[,4])))
e.MEM.approveEU.3 <- mean.approveEU * (approveEU.coeffs[,3] - ((probs.mean[,1] * approveEU.coeffs[,1]) + (probs.mean[,2] * approveEU.coeffs[,2]) + (probs.mean[,3] * approveEU.coeffs[,3]) + (probs.mean[,4] * approveEU.coeffs[,4])))
e.MEM.approveEU.4 <- mean.approveEU * (approveEU.coeffs[,4] - ((probs.mean[,1] * approveEU.coeffs[,1]) + (probs.mean[,2] * approveEU.coeffs[,2]) + (probs.mean[,3] * approveEU.coeffs[,3]) + (probs.mean[,4] * approveEU.coeffs[,4])))

all.results <- cbind(me.AME.approveEU.1, me.AME.approveEU.2, me.AME.approveEU.3, me.AME.approveEU.4, me.MEM.approveEU.1, me.MEM.approveEU.2, me.MEM.approveEU.3, me.MEM.approveEU.4, e.AME.approveEU.1, e.AME.approveEU.2, e.AME.approveEU.3, e.AME.approveEU.4, e.MEM.approveEU.1, e.MEM.approveEU.2, e.MEM.approveEU.3, e.MEM.approveEU.4)

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("Conservative:AME", "Labour:AME", "LibDem:AME", "UKIP:AME", "Conservative:MEM", "Labour:MEM", "LibDem:MEM", "UKIP:MEM", "Conservative: Average Elasticity", "Labour: Average Elasticity", "LibDem: Average Elasticity", "UKIP: Average Elasticity", "Conservative: Elasticity at the Mean", "Labour: Elasticity at the Mean", "LibDem: Elasticity at the Mean", "UKIP: Elasticity at the Mean")
print(round(marginal.effects, digits=3))

###############
## Table 5.5 ##
###############

beta <- bes2015.mnl$coefficients
covmat.beta <- vcov(bes2015.mnl)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

taxspend.coeffs <- betadraw[,grep("taxspend", colnames(betadraw))]

## AME ##

observed.x <- with(bes.data, data.frame(
cons1 = as.numeric(idx[2]==1),
cons2 = as.numeric(idx[2]==2),
cons3 = as.numeric(idx[2]==3),
taxspend = taxspend,
approve_EU1 = approve_EU * as.numeric(idx[2]==1),
approve_EU2 = approve_EU * as.numeric(idx[2]==2),
approve_EU3 = approve_EU * as.numeric(idx[2]==3),
NHS_improved1 = NHS_improved * as.numeric(idx[2]==1),
NHS_improved2 = NHS_improved * as.numeric(idx[2]==2),
NHS_improved3 = NHS_improved * as.numeric(idx[2]==3),
income1 = income * as.numeric(idx[2]==1),
income2 = income * as.numeric(idx[2]==2),
income3 = income * as.numeric(idx[2]==3),
female1 = female * as.numeric(idx[2]==1),
female2 = female * as.numeric(idx[2]==2),
female3 = female * as.numeric(idx[2]==3),
age1 = age * as.numeric(idx[2]==1),
age2 = age * as.numeric(idx[2]==2),
age3 = age * as.numeric(idx[2]==3),
id = idx,
weights = wt_combined_main
))

party4.taxspend <- observed.x[observed.x$id.alt==4, grep("taxspend", colnames(observed.x))]

exb.party1 <- exp(betadraw %*% t(subset(observed.x, id.alt==1, select=c(1:19))))
exb.party2 <- exp(betadraw %*% t(subset(observed.x, id.alt==2, select=c(1:19))))
exb.party3 <- exp(betadraw %*% t(subset(observed.x, id.alt==3, select=c(1:19))))
exb.party4 <- exp(betadraw %*% t(subset(observed.x, id.alt==4, select=c(1:19))))
exb.all <- exb.party1 + exb.party2 + exb.party3 + exb.party4

probs1 <- exb.party1/exb.all
probs2 <- exb.party2/exb.all
probs3 <- exb.party3/exb.all
probs4 <- exb.party4/exb.all

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

## marginal effects for UKIP
me.taxspend <- taxspend.coeffs * (probs4 * (1 - probs4))
me.AME.taxspend <- colSums(apply(me.taxspend, 1, function(x){x * id.weights}))/sum(id.weights)

## cross-marginal effects
cme.taxspend41 <- taxspend.coeffs * (probs1 * probs4)
cme.taxspend42 <- taxspend.coeffs * (probs2 * probs4)
cme.taxspend43 <- taxspend.coeffs * (probs3 * probs4)

cme.AME.taxspend41 <- -1 * colSums(apply(cme.taxspend41, 1, function(x){x * id.weights}))/sum(id.weights)
cme.AME.taxspend42 <- -1 * colSums(apply(cme.taxspend42, 1, function(x){x * id.weights}))/sum(id.weights)
cme.AME.taxspend43 <- -1 * colSums(apply(cme.taxspend43, 1, function(x){x * id.weights}))/sum(id.weights)

cme.AME.taxspend <- cbind(cme.AME.taxspend41, cme.AME.taxspend42, cme.AME.taxspend43)

## elasticities for UKIP
e.taxspend <- taxspend.coeffs * t(party4.taxspend  * t(1 - probs4))
e.AME.taxspend <- colSums(apply(e.taxspend, 1, function(x){x * id.weights}))/sum(id.weights)

## cross-elasticities
ce.taxspend41 <- taxspend.coeffs * t(party4.taxspend * t(probs4))
ce.taxspend42 <- taxspend.coeffs * t(party4.taxspend * t(probs4))
ce.taxspend43 <- taxspend.coeffs * t(party4.taxspend * t(probs4))

ce.AME.taxspend41 <- -1 * colSums(apply(ce.taxspend41, 1, function(x){x * id.weights}))/sum(id.weights)
ce.AME.taxspend42 <- -1 * colSums(apply(ce.taxspend42, 1, function(x){x * id.weights}))/sum(id.weights)
ce.AME.taxspend43 <- -1 * colSums(apply(ce.taxspend43, 1, function(x){x * id.weights}))/sum(id.weights)

ce.AME.taxspend <- cbind(ce.AME.taxspend41, ce.AME.taxspend42, ce.AME.taxspend43)

## MEM ##

mean.x <- with(bes.data, data.frame(
constant = rbind(0, diag(3)),
taxspend = tapply(taxspend, idx(bes2015.mnl, 2), mean),
approve_EU = mean(approve_EU) * rbind(0, diag(3)),
NHS_improved = mean(NHS_improved) * rbind(0, diag(3)),
income=mean(income) * rbind(0, diag(3)),
female=mean(female) * rbind(0, diag(3)),
age=mean(age) * rbind(0, diag(3))
))

mean.x <- mean.x[order(rownames(mean.x)),]

taxspendcol <- grep("taxspend", colnames(mean.x))

exb.mean <- exp(betadraw %*% t(mean.x))

probs.mean <- exb.mean/rowSums(exb.mean)

## marginal effects for UKIP
me.MEM.taxspend <- taxspend.coeffs * probs.mean[,colnames(probs.mean)=="4"] * (1 - probs.mean[,colnames(probs.mean)=="4"])

## cross-marginal effects
cme.MEM.taxspend41 <- -1 * taxspend.coeffs * probs.mean[,colnames(probs.mean)=="4"] * probs.mean[,colnames(probs.mean)=="1"]
cme.MEM.taxspend42 <- -1 * taxspend.coeffs * probs.mean[,colnames(probs.mean)=="4"] * probs.mean[,colnames(probs.mean)=="2"]
cme.MEM.taxspend43 <- -1 * taxspend.coeffs * probs.mean[,colnames(probs.mean)=="4"] * probs.mean[,colnames(probs.mean)=="3"]
cme.MEM.taxspend <- cbind(cme.MEM.taxspend41, cme.MEM.taxspend42, cme.MEM.taxspend43)

## elasticities for UKIP
e.MEM.taxspend <- taxspend.coeffs * mean.x[rownames(mean.x)=="4",taxspendcol] * (1 - probs.mean[,colnames(probs.mean)=="4"])

## cross-elasticities
ce.MEM.taxspend41 <- -1 * taxspend.coeffs * mean.x[rownames(mean.x)=="4",taxspendcol] * probs.mean[,colnames(probs.mean)=="4"]
ce.MEM.taxspend42 <- -1 * taxspend.coeffs * mean.x[rownames(mean.x)=="4",taxspendcol] * probs.mean[,colnames(probs.mean)=="4"]
ce.MEM.taxspend43 <- -1 * taxspend.coeffs * mean.x[rownames(mean.x)=="4",taxspendcol] * probs.mean[,colnames(probs.mean)=="4"]
ce.MEM.taxspend <- cbind(ce.MEM.taxspend41, ce.MEM.taxspend42, ce.MEM.taxspend43)

all.results <- cbind(me.AME.taxspend, me.MEM.taxspend, e.AME.taxspend, e.MEM.taxspend, cme.AME.taxspend, cme.MEM.taxspend, ce.AME.taxspend, ce.MEM.taxspend)

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("UKIP: AME", "UKIP: MEM", "UKIP: Average Elasticity", "UKIP: Elasticity at the Mean", "Conservative: Average CME", "Labour: Average CME", "LibDem: Average CME", "Conservative: CME at Mean", "Labour: CME at Mean", "LibDem: CME at Mean", "Conservative: Average CE", "Labour: Average CE", "LibDem: Average CE", "Conservative: CE at Mean", "Labour: CE at Mean", "LibDem: CE at Mean")
print(round(marginal.effects, digits=3))

###############
## Table 5.6 ##
###############

N <- length(unique(bes.data$respondent_id))
A <- nrow(bes.data)
beta <- bes2015.mnl$coefficients
covmat.beta <- vcov(bes2015.mnl)
ndraws <- 1000

betadraw <- mvrnorm(ndraws, beta, covmat.beta)
exp.betadraw <- exp(betadraw)
quantiles <- apply(exp.betadraw, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sds <- apply(exp.betadraw, 2, sd)
odds.ratios <- cbind(t(quantiles), sds)
colnames(odds.ratios) <- c("Median", "2.5%", "97.5%", "(se)")
rownames(odds.ratios) <- names(beta)
print(round(odds.ratios, digits=3))
print(N)
print(A)


# 4. faza: Analiza podatkov

#predvidevanje gibanja
podatki <- brezposelnost_in_obsojeni2 %>% filter(obsojeni < 10 & brezposelni < 25)

ggplot(podatki, aes(x = brezposelni, y = obsojeni)) +
  geom_point() + geom_smooth(method=lm, se = FALSE)

# izračun modela
fit <- lm(obsojeni ~ brezposelni, data=podatki)
summary(fit)

# primer predikcije
novi.brezposelni <- data.frame(brezposelni=c(25, 30,35))
predict(fit, novi.brezposelni)
napoved <- novi.brezposelni %>% mutate(obsojeni=predict(fit, .))

# izris napovedi
ggplot(podatki, aes(x = brezposelni, y = obsojeni)) +
  geom_point(shape=1) +
  geom_smooth(method=lm) +
  geom_point(data=napoved, aes(x = brezposelni, y = obsojeni), color='red', size=3)

# dodajanje enačbe kot anotacije
enacba <- function(x) {
  lm_coef <- list(a = round(coef(x)[1], digits = 2),
                  b = round(coef(x)[2], digits = 2),
                  r2 = round(summary(x)$r.squared, digits = 2));
  lm_eq <- substitute(italic(y) == a + b %.% italic(x)*","~~italic(R)^2~"="~r2,lm_coef)
  as.character(as.expression(lm_eq));
}

enacba(fit)

ggplot(podatki, aes(x = brezposelni, y = obsojeni)) +
  geom_point(shape=1) +
  geom_smooth(method=lm) +
  geom_point(data=napoved, aes(x = brezposelni, y = obsojeni), color='red', size=3) +
  annotate("text", x = 20, y = 10, label = enacba(fit), parse = TRUE) +
  ggtitle('Linearna regresija') +
  theme_bw()


library(ggplot2)
library(gridExtra)
library(MASS)
library(grDevices)
library(cowplot)
setwd("G:\\My Drive\\JHO_lab\\recall_curve_papers\\JASA\\2021-09-07\\difference_cb")
source("cp_bands_plots.r")

######Convenience functions

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

qmix <- function (p, params, pro = c(.5, .5), expand=.1, dist = "binorm") {
  nr <- 1000000
  XX <- rbinom(n=nr, size=1, prob=pro)
  if(dist == "binorm") {
    sd.s <- 1
    x = rnorm(n=nr, params[1], sd.s)*XX + rnorm(n=nr, params[2], sd.s)*(1-XX)
  } else if(dist == "bibeta") {
    x = rbeta(n=nr, params[[1]][1], params[[1]][2])*XX + rbeta(n=nr, params[[2]][1], params[[2]][2])*(1-XX)
  }
  span <- seq(min(x) - expand * diff(range(x)), max(x) + expand * diff(range(x)), length = nr)
  cdf <- vector(mode = "numeric", length = nr)
  if(dist == "binorm") {
    sd.s <- 1
    cdf = pnorm(span, params[1], sd.s)*pro[1] + pnorm(span, params[2], sd.s)*(1-pro[1])
  } else if(dist == "bibeta") {
    cdf = pbeta(span, params[[1]][1], params[[1]][2])*pro[1] + pbeta(span, params[[2]][1], params[[2]][2])*(1-pro[1])
  }
  quants <- stats::spline(cdf, span, method = "hyman", xout = p)$y
  quants[which(p < 0L | p > 1L)] <- NaN
  quants[which(p == 0L)] <- -Inf
  quants[which(p == 1L)] <- Inf
  if (any(is.nan(quants)))
    warning("Some quantile values could not be calculated. If all 'p's are within [0,1], try reducing the value of 'expand' and try again.")
  return(as.vector(quants))
}

add.alpha <- function(col, alpha=1){
  if(missing(col))
    stop("Please provide a vector of colours.")
  apply(sapply(col, col2rgb)/255, 2,
        function(x)
          rgb(x[1], x[2], x[3], alpha=alpha))
}

computeTrueKDiff <- function(){

  if(dist == "binorm" | dist == "bibeta") {
    c1 <- qmix(1-r, params[[1]], c(pi.0.true, 1-pi.0.true), expand=.1, dist = dist)
    c2 <- qmix(1-r, params[[2]], c(pi.0.true, 1-pi.0.true), expand=.1, dist = dist)
  } else {
    stop("Wrong dist")
  }

  if (dist == "binorm") {
    sd.s = 1
    F.plus1 <- pnorm(c1, mean = params[[1]][1], sd.s)
    F.plus2 <- pnorm(c2, mean = params[[2]][1], sd.s)
  } else if (dist == "bibeta") {
    F.plus1 <- pbeta(c1, params[[1]][[1]][1], params[[1]][[1]][2])
    F.plus2 <- pbeta(c2, params[[2]][[1]][1], params[[2]][[1]][2])
  }

  k.true1 <- vector(length = length(F.plus1))
  pi.true1 <- vector(length = length(F.plus1))
  k.true2 <- vector(length = length(F.plus2))
  pi.true2 <- vector(length = length(F.plus2))

  for (i in 1:length(k.true1)) {
    k.true1[i] <- 1 - F.plus1[i]
    pi.true1[i] <- k.true1[i]*pi.0.true/r[i]
    k.true2[i] <- 1 - F.plus2[i]
    pi.true2[i] <- k.true2[i]*pi.0.true/r[i]
  }

  # if k or pi is above 1, then they should actually be slightly below 1
  k.true1 <- ifelse(k.true1 > 1, 1 - 1E-10, k.true1)
  pi.true1 <- ifelse(pi.true1 > 1, 1 - 1E-10, pi.true1)
  k.true2 <- ifelse(k.true2 > 1, 1 - 1E-10, k.true2)
  pi.true2 <- ifelse(pi.true2 > 1, 1 - 1E-10, pi.true2)

  k.true1 - k.true2
}
##################################

fn.v <- c("power_band_binorm_nocorr.rdata", "power_band_binorm_corr.rdata", "power_band_bibeta_nocorr.rdata", "power_band_bibeta_corr.rdata")
m.ls <- c()
k.true.ls <- list()
dist.v <- c("binorm", "binorm", "bibeta", "bibeta")
for(idx in seq_along(fn.v)) {
  print(fn.v[idx])

  load(fn.v[idx])

  m = 150000
  pi.0.true = 1/500
  params <- k.ls[[1]][[1]]$params
  r <- k.ls[[1]][[1]]$r
  dist <- dist.v[idx]
  k.diff.true <- computeTrueKDiff()

  k.true.ls <- c(k.true.ls, rep(list(k.diff.true), 6))

  tmp.ls <- c(k.ls[[1]][1:3], k.c.ls[[1]][1:3])
  tmp.ls <- tmp.ls[c(1,4,2,5,3,6)]
  m.ls <- c(m.ls, tmp.ls)
}

pdf("cp_band_coverage.pdf", height = 9, width = 7)
cp_band_plot(m.ls, increment = c("Case 1", "Case 2", "Case 3", "Case 4"), axis.ylim = c(.15, .15), nox = 1)
dev.off()


subset(expand.grid(x=1:n, y=1:n, z=1:n), x^2 + y^2 == z^2)


#pca: componente principal a graficar
#n: limite de comp a grafica
#j desde donde se iniciara la graifcacion
graf<-function(pca,j,n)
{
	par(mfrow=c(n-j+1,1))
	for(i in j:n)
	{
		plot(-1*loadings(pca)[,i],type="h",col="blue",ylab=paste("Componente",i),xaxt = "n")
		abline(h=0)
		axis(1, at = 1:nrow(loadings(pca)),
			labels = rownames(loadings(pca)))
	}
}
graf1<-function(pca)
{
	plot(pca$sdev^2,ylab=expression(lambda),xaxt="n",pch=21,bg="blue",xlab="Componentes")
	axis(1, at = 1:ncol(loadings(pca)),
		labels = colnames(loadings(pca)))
	abline(h=mean(pca$sdev^2),col="red")
}

#Articulo
norma<-function(x)
{
	if(ncol(x)==1||is.null(ncol(x)))
	{
		x<-matrix(x,nrow=1)
		sal<-sqrt(x%*%t(x))
		return(sal)
	}
	sal<-sqrt(x%*%t(x))
	sal<-sal[col(sal)==row(sal)]
	return(sal)
}
funcion1<-function(Patrones)
{
	SIGMA<-Patrones
	A<-SIGMA-rowMeans(SIGMA)
	v1<-eigen(t(A)%*%A)$vectors
	l1<-eigen(t(A)%*%A)$values
	v<-A%*%v1
	v<-qr.Q(qr(v))
	return(list(A,v,l1))
}
funcion2<-function(A,v)
{
	Omega<-NULL
	for( h in 1:ncol(A))
	{
		WW<-NULL
		for(i in 1:ncol(v))
		{
			pesodelaimagen<-v[,i]%*%A[,h]
			WW<-c(WW,pesodelaimagen)
		}
		Omega<-cbind(Omega,WW)
	}
	return(Omega)
}
funcion3<-function(NF,v,Omega,Patrones)
{
	NFe<-NF-rowMeans(Patrones)
	WWn<-NULL
	for(i in 1:ncol(v))
	{
		pesodelaimagen<-v[,i]%*%NFe
		WWn<-c(WWn,pesodelaimagen)
	}
	OmegaN<-WWn
	clase<-1:ncol(v)
	distancia<-dist(t(cbind(OmegaN,Omega)))[1:3]
	clase<-clase[distancia==min(distancia)]
	return(list(distancia,clase))
}

Proyeccion<-function(u,v)
{
	if((ncol(u)==1||is.null(ncol(u)))&&(ncol(v)==1||is.null(ncol(v))))
	{
		sal<-((u%*%v)/(norma(v)^2))*v
		return(sal)
	}

	if(ncol(u)==1||is.null(ncol(u)))
	{
		u<-matrix(u,nrow=1)
		sal<-as.numeric(t(u%*%t(v)/norma(v)^2))*v
		return(sal)
	}

	if(ncol(v)==1||is.null(ncol(v)))
	{
		v<-matrix(v,ncol=1)
		sal<-as.numeric((u%*%v)/as.numeric(norma(v)^2))*t(matrix(rep(v,nrow(u)),ncol=nrow(u)))
		return(sal)
	}

}
Proporcion<-function(v,A)
{
	norma(v)/sum(norma(A))
}

#Combinacion muestra optima para pca
#n = numero de iteraciones
#y = muestra total 100%
#k = el numero la muestra a seleccionar el aproximado al 30%
#c = indica el varlo de la variable cor para el PCA
PCAoptimo<-function(y, n, k, c)
{
	acum <- 0
	indices_opti <- NULL

	indice<-sample(1:nrow(y),k)
	ytrain<-y[indice,1:5]

	pr <- prcomp(ytrain, scale = TRUE,cor=c)

	for(i in 1:n){
		indice<-sample(1:nrow(y),k)
		ytrain<-y[indice,1:5]

		pr <- prcomp(ytrain, scale = TRUE,cor=c)
		vars <- apply(pr$x, 2, var)
		props <- vars / sum(vars)

		if(cumsum(props)[1] > acum)
		{
			acum <- cumsum(props)[1]
			indices_opti <- indice
			print(cumsum(props))
		}
	}

	return(list(indices=indices_opti, acum=acum))
}

myTrain<-function(m,s,capas, P, P_v, target, claseT, p_ecm){

net1 <- newff(n.neurons=c(2,capas,2), learning.rate.global=p_ecm, momentum.global=m,
error.criterium="LMS", Stao=NA, hidden.layer="sigmoid",
output.layer="sigmoid", method="ADAPTgdwm")
result1 <- train(net1,P , target, error.criterium="LMS", report=TRUE, show.step=s, n.shows=5 )
s <- sim(result1$net, P)
print("Entrenando")
tasa_1<-rep(FALSE,nrow(s))
tasa_1[round(s)[,1]== target[,1] & round(s)[,2]== target[,2]]<-TRUE
tasa_1 <- sum(tasa_1==TRUE)*100/length(tasa_1)

print(tasa_1)
ECM_1 <- error.LMS(c(s,target,net1))
print(ECM_1)

print("Validando")
s <- sim(result1$net, P_v)

tasa_2<-rep(FALSE,nrow(s))
tasa_2[round(s)[,1]== claseT[,1] & round(s)[,2]== claseT[,2]]<-TRUE
tasa_2 <- sum(tasa_2==TRUE)*100/length(tasa_2)

print(tasa_2)

ECM_2 <- error.LMS(c(s,claseT,net1))
print(ECM_2)

#return(list(ecm_1=as.numeric(ECM_1), t_1=as.numeric(tasa_1), ecm_2=as.numeric(ECM_2), t_2=as.numeric(tasa_2)))
return(c(as.numeric(ECM_1), as.numeric(tasa_1),as.numeric(ECM_2), as.numeric(tasa_2)))
}

validacion_cruzada<-function(y, iteraciones) {
#########################################
#    Calculo de grupos de salida
#
# Conglomerado Total se asigna una etiqueta a cada caso segun su nota de calculo 1
sal <- y[,6]
sal
conglomeradoT<-rep(FALSE,length(sal))
conglomeradoT[sal<=10]<-1 #Nivel Bajo
conglomeradoT[sal>=11&sal<16]<-2 #Nivel Medio
conglomeradoT[sal>=16]<-3 #Nivel Alto

########################
#Generación de clase
########################
medias<-c(mean(data[conglomeradoT==1,7]),mean(data[conglomeradoT==2,7]),mean(data[conglomeradoT==3,7]))
medias
names(medias)<-c(1,2,3)
claseC<-as.numeric(names(sort(medias)))

trains <- NULL
trains
for(i in 1:iteraciones){
	print("------------------------------------------------")
	print(i*100/iteraciones)
	print("------------------------------------------------")
	indice <- PCAoptimo(y,1,87,F)$indices
	ytrain<-y[indice,1:5]
	ytest<-y[-indice,1:5]
	comp <-princomp(ytrain,cor=F)
	cargas<-comp$loadings[,]
	comT<-score(ytest,cargas)
	conglomerado_train<-conglomeradoT[indice]
	conglomerado_test<-conglomeradoT[-indice]

	clase<-matrix(NA, ncol=2, nrow=nrow(ytrain))
	clase[conglomerado_train==claseC[1],]<-matrix(rep(t(c(0,0)), sum(conglomerado_train==claseC[1])), byrow=TRUE, ncol=2 )
	clase[conglomerado_train==claseC[2],]<-matrix(rep(t(c(0,1)), sum(conglomerado_train==claseC[2])), byrow=TRUE, ncol=2 )
	clase[conglomerado_train==claseC[3],]<-matrix(rep(t(c(1,1)), sum(conglomerado_train==claseC[3])), byrow=TRUE, ncol=2 )
	claseT<-matrix(NA, ncol=2, nrow=nrow(ytest))
	claseT[conglomerado_test==claseC[1],]<-matrix(rep(t(c(0,0)), sum(conglomerado_test==claseC[1])), byrow=TRUE, ncol=2 )
	claseT[conglomerado_test==claseC[2],]<-matrix(rep(t(c(0,1)), sum(conglomerado_test==claseC[2])), byrow=TRUE, ncol=2 )
	claseT[conglomerado_test==claseC[3],]<-matrix(rep(t(c(1,1)), sum(conglomerado_test==claseC[3])), byrow=TRUE, ncol=2 )

	target<-clase
	P<-matrix(c(comp$score[,1],comp$score[,2]),ncol=2,byrow=TRUE)
	P_v <-comT[,1:2]

	trains <- matrix(rbind(trains, myTrain(0.7, 13, c(2,2), P, P_v, clase,claseT, 0.1)), byrow=FALSE, ncol=4 )
}
return (trains)

}

score<-function(y,carga)
{
yc<-y-matrix(rep(colMeans(y),nrow(y)),ncol=ncol(y),byrow=TRUE)
salida<-as.matrix(yc)%*%carga
return(salida)
}


## 2. Data Suitable for Linear Regression ##

library(readr)
williamsburg_north <- read_csv("williamsburg_north.csv")

## 3. Exploring Bivariate Relationships with Scatterplots ##

library(ggplot2)

ggplot(data = williamsburg_north,
       aes(x = year_built, y = sale_price)) +
       scale_y_continuous(labels = scales::comma) +
       geom_point()

ggplot(data = williamsburg_north,
       aes(x = gross_square_feet, y = sale_price)) +
       scale_y_continuous(labels = scales::comma) +
       geom_point()

## 4. Linearity ##

# question_1 <-
# question_2 <-
question_1 <- FALSE
question_2 <- TRUE

## 5. Strength ##

brooklyn_sales <- suppressMessages(read_csv("williamsburg_north.csv"))
library(dplyr)
set.seed(1)
williamsburg_all <- brooklyn_sales %>%
  # Remove year-built zero years (assumed to be missing data)
  filter(year_built > 0) %>%
  # Remove transactions assumed to be between family members
  filter(sale_price > 10000) %>%
  # Select condominum category
  filter(building_class_category == "13 Condos - Elevator Apartments") %>%
  # Select building class "CONDO; RESIDENTIAL UNIT IN ELEVATOR BLDG."
  filter(building_class_at_time_of_sale == "R4") %>%
  # Choose all Williamburg neighborhoods
  filter(stringr::str_detect(neighborhood, "Williamsburg")) %>%
  # Include only unique entries
  distinct() %>%
  # Select random sample of 50
  sample_n(50)

ggplot(data = williamsburg_all,
       aes(x = gross_square_feet, y = sale_price, color = neighborhood)) +
  scale_y_continuous(labels = scales::comma) +
  geom_point() +
  theme(legend.position="bottom")

stronger_relationship <- "williamsburg_north"

## 6. Outliers ##

# sale_price quartiles
quartiles <- quantile(williamsburg_north$sale_price)
# 75% minus 25% = interquartile range (iqr)
iqr <- quartiles[[4]] - quartiles[[2]]
# Outlier boundaries
lower_bound <- quartiles[[2]] - (1.5 * iqr)
upper_bound <- quartiles[[4]] + (1.5 * iqr)

# Isolate outlier(s)
outliers <- williamsburg_north %>%
  filter(sale_price > upper_bound | sale_price < lower_bound)
ggplot(data = williamsburg_north,
       aes(x = gross_square_feet, y = sale_price)) +
  geom_point(data = outliers, aes(gross_square_feet, sale_price),
             color = "orangered3", size = 4) +
  geom_point() +
  scale_y_continuous(labels = scales::comma) +
  geom_smooth(method = "lm", se = FALSE)

## 8. Correlation ##

library(tibble)
correlation_wburg_all <- williamsburg_all %>%
  select(gross_square_feet, sale_price) %>%
  cor(use = "pairwise.complete.obs") %>%
  as_tibble(rownames = "variable")

greater_correlation <- "williamsburg_north"

Data Analyst in R/Step 6 - Predictive Modeling and Machine Learning in R/1. Linear Regression Modeling in R/2. Bivariate Relationships - Correlation and Scatterplots.r


# Print correlation matrix between three instruments

#1. install and load the packages
if (!require(quantmod)) install.packages('quantmod')
library('quantmod')

if (!require(corrplot)) install.packages('corrplot')
library(corrplot)

getSymbols("USD/EUR",src="oanda",from="2018-01-01")
getSymbols("XAU/USD",src="oanda",from="2018-01-01")
getSymbols("USD/CAD",src="oanda",from="2018-01-01")

y = USDEUR
x = XAUUSD
z = USDCAD

chartSeries(y, TA = c(addSMA(50),addVo(),addBBands()), subset='2018-01::2018-04')

stocks = as.data.frame(merge(x,y,z))

cor(stocks)
plot(stocks)

plot(x ~ y,
     data=Data,
     pch=16,
     xlab = "XAU/USD",
     ylab = "USD/EUR")


#' Fitting Heffernan-Tawn model to wave data

#' @description
#' This function fits a Heffernan-Tawn (\code{ht}) model to the given wave data. The marginal distributions are
#' a mixture model with an empirical distribution below a specified threshold, and the generalised Pareto distribution
#' (GPD) above the threshold. The dependence structure is the conditional extreme value model proposed in
#' Heffernan and Tawn (2004).
#'
#' @param data the wave data in the form a \code{data.table} with wave height \code{hs} and wave period
#' \code{tp} as columns
#'
#' @param npy the number of data points per year, usually estimated by the number of rows in the
#' supplied wave data divided by the total period of data coverage (in years)
#'
#' @param margin_thresh_count an integer indicating the number of exceedances strcitly above the threshold
#' used for fitting the Generalised Pareto Distribution (GPD) for the upper tail of the marginal distribution
#' for \code{hs} and \code{tp}
#'
#' @param dep_thresh_count an integer indicating the number of exceedances (of the conditioning variable)
#' strcitly above the threshold used for fitting the conditional multivariate extreme value model of
#' Heffernan and Tawn (2004)
#'
#' @details
#' The input \code{data} must be a \code{data.table} object with \code{hs} and \code{tp} columns. This can be
#' generated by reading a CSV file using function \code{\link[data.table]{fread}}.
#'
#' By the asymptotic properties of the GPD and the HT model, the model bias is only negligible when the
#' thresholds are sufficiently high. This function prompts the user with the exceedance probability implied by
#' their choie of the arguments \code{margin_thresh_count} and \code{dep_thresh_count} to remind them that
#' the exceedance probability needs to be quite small for the fit of GPD and HT to be valid.
#'
#' @return An joint distribution object of class \code{ht} containing the key information of a fitted
#' Heffernan-Tawn model, including the marginal distribution parameters and the dependence model parameters.
#'
#' @examples
#' # Load data
#' data(ww3_pk)
#'
#' # Fit Heffernan-Tawn model
#' ht = fit_ht(data = ww3_pk, npy = nrow(ww3_pk)/10, margin_thresh_count = 100, dep_thresh_count = 100)
#'
#' @references Heffernan, Janet & A. Tawn, Jonathan. (2004). A Conditional Approach for Multivariate Extreme Values.
#' Journal of the Royal Statistical Society Series B. 66. 497-546. 10.1111/j.1467-9868.2004.02050.x.
#'
#' @seealso \code{\link{fit_wln}}, \code{\link{sample_jdistr}}
#'
#' @export
fit_ht = function(data, npy, margin_thresh_count, dep_thresh_count){

  data = as.data.table(data)
  res = list()
  class(res) = "ht"
  res$npy = npy

  # Marginal models
  hs_thresh = sort(data$hs, decreasing = T)[margin_thresh_count+1]
  tp_thresh = sort(data$tp, decreasing = T)[margin_thresh_count+1]
  p_margin_thresh = 1-margin_thresh_count/(data[,.N])

  res$margin = list(
    p_margin_thresh = p_margin_thresh,
    hs = .fit_gpd_emp(data$hs, thresh = hs_thresh),
    tp = .fit_gpd_emp(data$tp, thresh = tp_thresh))

  # Dep models
  dep_data = copy(data)
  dep_data[, u_hs:=rank(hs, ties.method = "random")/(.N+1)]
  dep_data[, u_tp:=rank(tp, ties.method = "random")/(.N+1)]
  dep_data[u_hs<0.5, l_hs:=log(2*u_hs)]
  dep_data[u_hs>=0.5, l_hs:=-log(2-2*u_hs)]
  dep_data[u_tp<0.5, l_tp:=log(2*u_tp)]
  dep_data[u_tp>=0.5, l_tp:=-log(2-2*u_tp)]

  op_hs = nlminb(
    start = c(1,0), objective = .nll_ht_pair,
    lower = c(-1, -100), upper = c(1, 1-.limit_zero),
    cond_var = dep_data[frank(u_hs)>.N-dep_thresh_count, l_hs],
    dep_var = dep_data[frank(u_hs)>.N-dep_thresh_count, l_tp])

  op_tp = nlminb(
    start = c(1,0), objective = .nll_ht_pair,
    lower = c(-1, -100), upper = c(1, 1-.limit_zero),
    cond_var = dep_data[frank(u_tp)>.N-dep_thresh_count, l_tp],
    dep_var = dep_data[frank(u_tp)>.N-dep_thresh_count, l_hs])

  p_dep_thresh = 1-dep_thresh_count/(data[,.N])
  res$dep = list(
    p_dep_thresh = p_dep_thresh,
    hs = list(
      par = c(a = op_hs$par[1], b = op_hs$par[2]),
      resid = dep_data[frank(u_hs)>.N-dep_thresh_count, (l_tp-op_hs$par[1]*l_hs)/(l_hs^op_hs$par[2])]),
    tp = list(
      par = c(a = op_tp$par[1], b = op_tp$par[2]),
      resid = dep_data[frank(u_tp)>.N-dep_thresh_count, (l_hs-op_tp$par[1]*l_tp)/(l_tp^op_tp$par[2])]),
    dep_data = dep_data)

  # Return
  message(paste0(
    "The input margin_thresh_count corresponds to an exceedance probability of ",
    signif(1-p_margin_thresh, 2),"."))
  message(paste0(
    "The input dep_thresh_count corresponds to an exceedance probability of ",
    signif(1-p_dep_thresh, 2),"."))
  return(res)
}

.nll_ht_pair = function(theta, cond_var, dep_var){
  a = theta[1]
  b = theta[2]
  resid = (dep_var-a*cond_var)/(cond_var^b)
  mean_resid = mean(resid)
  sd_resid = sd(resid)

  nll = -dnorm(
    x = dep_var, log = TRUE,
    mean = a*cond_var+(cond_var^b)*mean_resid,
    sd = (cond_var^b)*sd_resid)

  return(sum(nll))
}

.fit_gpd_emp = function(data, thresh){
  gpd = evd::fpot(data, threshold = thresh, cmax = F, std.err = F)

  res = list()
  class(res) = "gpd"
  res$par = c(loc = thresh, gpd$param[1], gpd$param[2])
  res$emp = data
  res$conv = gpd$convergence

  return(res)
}

.convert_unif_to_lap = function(unif){
  calc = data.table(unif=unif, lap=NA_real_)
  calc[unif>0.5, lap:=-log(2-2*unif)]
  calc[unif<=0.5, lap:=log(2*unif)]
  return(calc$lap)
}

.convert_lap_to_unif = function(lap){
  calc = data.table(lap=lap, unif=NA_real_)
  calc[lap>0, unif:=1-.5*exp(-lap)]
  calc[lap<=0, unif:=.5*exp(lap)]
  return(calc$unif)
}

.convert_unif_to_origin = function(unif, p_thresh, gpd_par, emp){
  calc = data.table(unif=unif, x=NA_real_)
  calc[unif<p_thresh, x:=quantile(emp, unif)]
  calc[unif>=p_thresh, x:=evd::qgpd(
    p = (unif-p_thresh)/(1-p_thresh),
    loc = gpd_par[1], scale = gpd_par[2], shape = gpd_par[3])]
  return(calc$x)
}


# Coded by Anderson Borba data: 07/07/2020 version 1.0
# Article submitted
# Fusion of Evidences in Intensities Channels for Edge Detection in PolSAR Images
# GRSL - IEEE Geoscience and Remote Sensing Letters
# Anderson A. de Borba, Maurı́cio Marengoni, and Alejandro C Frery
# Despriction (function)
# Finds the l(j) using total-likelihood
# Input: Le, Ld, mue e mud > 0 estimed parameters
#
# Output: pixel j - Edge evidence estimated
func_obj_l_L_mu <- function(param){
  j <- param
  Le <- matdf1[j,1]
  Ld <- matdf2[j,1]
  mue <- matdf1[j,2]
  mud <- matdf2[j,2]
  #
  aux1 <- Le * log(Le)
  aux2 <- Le * sum(log(z[1: j])) / j
  aux3 <- Le * log(mue)
  aux4 <- log(gamma(Le))
  aux5 <- (Le / mue) *  sum(z[1:j]) / j
  #
  aux6  <- Ld * log(Ld)
  aux7  <- Ld * sum(log(z[(j + 1): N])) / (N - j)
  aux8  <- Ld * log(mud)
  aux9  <- log(gamma(Ld))
  aux10 <- (Ld / mud) * sum(z[(j + 1): N]) / (N - j)
  #
  a1 <-  aux1 + aux2 - aux3 - aux4 - aux5
  a2 <-  aux6 + aux7 - aux8 - aux9 - aux10
  #### Beware! The signal is negative because GenSA finds the point of minimum
  func_obj_l_L_mu <- -(j * a1 + (N - j) * a2)
  return(func_obj_l_L_mu)
}


 DSTEVR Example Program Results

 Selected eigenvalues
     3.5470  8.6578
 Selected eigenvectors
          1       2
 1   0.3388  0.0494
 2   0.8628  0.3781
 3  -0.3648  0.8558
 4   0.0879 -0.3497


# linear regression using random variable selected by me
adult.poly = lm(income~education+workclass+maritalStatus+race+sex+poly(educationNum,8)+poly(hoursPerWeek,8), data=adult.data)

summary(adult.poly)

# do the prediction
yhat = predict(adult.poly,adult.test)

# if yhat is greater than .5 it is 1 else 0
yhat = ifelse(yhat >= 0.5 , 1, 0)

# get and display the mse
mean((yhat - adult.test$income) ^ 2)


#### #### #### #### #### #### #### #### #### #### ####
####
#### Regression tree boosting
#### https://cran.r-project.org/web/packages/mvtboost/vignettes/mvtboost_vignette.html
#### #### #### #### #### #### #### #### #### #### ####

rm(list=ls())

library(mvtboost)

## dataset
data("mpg",package="ggplot2")
# A data frame with 234 rows and 11 variables
#model - model name
#displ - engine displacement, in litres
#year - year of manufacture
#cyl - number of cylinders
#trans - type of transmission
#drv - f = front-wheel drive, r = rear wheel drive, 4 = 4wd
#cty - city miles per gallon
#hwy - highway miles per gallon
#fl - fuel type
#class - "type" of car
summary(mpg)

#  Consumo cittadino e su autostrada come Y
Y <- mpg[,c("cty","hwy")]
# Variabiloi vanno standardizzate
Ys <- scale(Y)

# Come X abbiamo manufacturer, displacement, year,
# cylinder, transmission,drive, class
X <- mpg[,-c(2,8:9)]
# troviamo le variabili che sono caratteri
# e trasformiamole in fattori
char.ids <- unlist(lapply(X,is.character))
X[,char.ids] <- lapply(X[,char.ids],as.factor)

## qualche plot
i = 1
par(mfrow=c(1,2))
plot(X[,i],Ys[,1], main=colnames(X)[i])
plot(X[,i],Ys[,2], main=colnames(X)[i])

# Tree Boosting
out <- mvtb(Y=Ys,X=X,          # data
        n.trees=1000,          # numero d'alberi
        interaction.depth=3)   # numero di variabili in interazione

# Stimiamo lo stesso modello utilizzando la cross validation
out2 <- mvtb(Y=Ys,X=X,
            n.trees=1000,
            interaction.depth=3,

            bag.fraction=.5,      # Frazione delle osservazioni per la CV
            cv.folds=3,           # numero di cross-validation folds
            mc.cores=1,           # numero di cores
            seednum=103)          # seed
out2$best.trees

# vediamo i due summaries
summary(out)
summary(out2)

# possiamo calcolare "manualmente" R^2
yhat <- predict(out2,newdata=X)
(r2 <- var(yhat)/var(Ys))

yhatNoCV <- predict(out2,newdata=X)
(r2NoCV <- var(yhat)/var(Ys))

# vediamo gli effetti "non-lineari" di alcuni predittori

# plot risultati
par(mfrow=c(3,3))
plot(out2, predictor.no=1, response.no=1)
plot(out2, predictor.no=2, response.no=1)
plot(out2, predictor.no=3, response.no=1)
plot(out2, predictor.no=4, response.no=1)
plot(out2, predictor.no=5, response.no=1)
plot(out2, predictor.no=6, response.no=1)
plot(out2, predictor.no=7, response.no=1)
plot(out2, predictor.no=8, response.no=1)
par(mfrow=c(1,1))
# apre una nuova finestra grafica
dev.new()

par(mfrow=c(3,3))
plot(out2, predictor.no=1, response.no=2)
plot(out2, predictor.no=2, response.no=2)
plot(out2, predictor.no=3, response.no=2)
plot(out2, predictor.no=4, response.no=2)
plot(out2, predictor.no=5, response.no=2)
plot(out2, predictor.no=6, response.no=2)
plot(out2, predictor.no=7, response.no=2)
plot(out2, predictor.no=8, response.no=2)
par(mfrow=c(1,1))

# possiao anche vedere le interazioni con un plot
k = 1
i = 1
j = 2
mvtb.perspec(out2,response.no = k,predictor.no = c(i,j),xlab=colnames(X)[i],ylab=colnames(X)[j],zlab=colnames(Y)[k] ,phi=15, theta=0)

# oppure "numericamente"
nonlin.out <- mvtb.nonlin(out2,X=X,Y=Y)
nonlin.out$hwy$rank.list
nonlin.out$cty$rank.list
nonlin.out$hwy$nonlin.full
nonlin.out$cty$nonlin.full


#: 1, generate continuous gap variable
data_dt[ , gap_between_inquiry_n_accept := difftime(ts_accepted_at_first,ts_interaction_first, units = "hours") %>% as.numeric]

data_dt[ , gap_between_reply_n_accept := difftime(ts_accepted_at_first,ts_reply_at_first, units = "mins")%>% as.numeric]

data_dt[ , gap_between_accept_n_booking := difftime(ts_booking_at,ts_accepted_at_first, units = "secs")%>% as.numeric]

data_dt[ , gap_between_inquiry_n_checkin := difftime(ds_checkin_first,ts_interaction_first, units = "days") %>% as.numeric]

data_dt[ , length_of_stay := difftime(ds_checkout_first,ds_checkin_first, units = "days")%>% as.numeric]

#: 2, investigate range and spreadness of gap
foreach (var = c("gap_between_inquiry_n_reply", "gap_between_inquiry_n_accept", "gap_between_inquiry_n_checkin","gap_between_reply_n_accept","gap_between_accept_n_booking", "length_of_stay")) %do% {

  var_value = data_dt[, var, with = FALSE] %>% unlist %>% as.numeric

  message("look at var:", var)
  sum(is.na(var_value)) %>% message("na values: ",.)

  var_value %>% length  %>% message("length: ",.)

  message("Range is: ")
  var_value %>% range(., na.rm = TRUE) %>% cat

  sum(var_value <= 1, na.rm = TRUE) %>% message("# of <= 1: ",.)

  sum(var_value <= 5, na.rm = TRUE) %>% message("# of <= 5: ",.)

  sum(var_value <= 10, na.rm = TRUE) %>% message("# of <= 10: ",.)

  sum(var_value <= 120, na.rm = TRUE) %>% message("# of <= 120: ",.)

  catt("================")

}

#: 3, generate equal sized bins, preferrable from more # of bins to less # of bins, automatically
foreach (var = c("gap_between_inquiry_n_reply", "gap_between_inquiry_n_accept", "gap_between_inquiry_n_checkin","gap_between_reply_n_accept","gap_between_accept_n_booking", "length_of_stay")) %do% {

  var_value = data_dt[, var, with = FALSE] %>% unlist %>% as.numeric

  message("look at var:", var)

  var_value[is.na(var_value)] = max(var_value, na.rm = TRUE) # assign missing value to be the maximal outlier, then categorize

  n_bin = 6
  var_value_binned <- try(ggplot2::cut_number(var_value, n_bin))

  while (inherits(var_value_binned, "try-error") & n_bin > 2) {
    # dynamic assign equal sized bins, try from 6 to 2.
    n_bin = n_bin - 1
    var_value_binned <- try(ggplot2::cut_number(var_value, n_bin))

  }

  message(levels(var_value_binned))

  # if at least n_bin >= 2, then generate the new variables xxxx_binned.
  if (!inherits(var_value_binned, "try-error")) {
    data_dt[, sprintf("%s_binned", var) := var_value_binned]
  }

  message("================")

}


#############################################
# M-H Algorithm does
#############################################
# 1. Propose a new value
# 2. Calculate the probability of accepting the new value
# 3. Flip a coin to determine if we accept the proposal or not
# 4. Update the state of the chain
## A generic MH sampler
mh.sample <- function( U.data, old.state,
                       cc.log.density, proposal.function ) {

        ## Step 1: Call the proposal function
        prop <- proposal.function( old.state )
        ## which returns:
        ## ... prop$param.name, the name of the parameter
        ## ... prop$state, the new state object
        ## ... prop$log.density, the log density of the proposal

        ## Step 2: Calculate the (log) acceptance probability
        log.alpha.star <- (
                ## Complete conditional at the proposal
                cc.log.density(   U.data, prop$state )
                ## Complete conditional at the "old" value
                - cc.log.density( U.data, old.state )
                ## Proposal density calculated to the proposal
                + prop$log.density( prop$state, old.state )
                ## Proposal density calculated to the "old" value
                - prop$log.density( old.state, prop$state )
        )

        ## Step 3: Accept proposal draws
        ## ... Flip coins with the calculated probabilities
        acc.new <- ifelse(
                log(runif( length(log.alpha.star) )) <= log.alpha.star,
                1, 0 )
        ##
        ## ... Update the chain to its "current" state
        ## ... ... Copy the old state object
        cur.state  <- old.state
        ## ... ... Update the state object for this parameter
        cur.state[[ prop$param.name ]] <- ifelse(
                acc.new==1,
                prop$state[[ prop$param.name ]],
                old.state[[  prop$param.name ]])

        ## Step 4: Update the acceptance probability
        ## ... add the new average acceptance probability
        cur.state$ACC[[ prop$param.name ]]  <- (
                old.state$ACC[[ prop$param.name ]] + mean( acc.new )
        )
        ## ... record that we added a new acceptance probability
        name.n <- paste( prop$param.name, ".n", sep="")
        cur.state$ACC[[ name.n ]] <-  old.state$ACC[[name.n]] + 1

        ## Step 5: Return the current state
        return(cur.state)
}


library(tidyverse)
library(caret)
library(glmnet)
LASSO = 1
RIDGE = 0
ELASTIC = 0.3
x <- model.matrix(age~., train)[,-c(1,2,3,4,5)]
cv <- cv.glmnet(x, train$age, alpha = LASSO)
# Display the best lambda value
cv$lambda.min
model <- glmnet(x, train$age, alpha = LASSO, lambda = cv$lambda.min)
# Display regression coefficients
coef(model)

get.data <- function(fnc.path,loading.path,target.path) {
fnc_df = read.csv(fnc.path)
loading_df = read.csv(loading.path)
labels_df = read.csv(target.path)
require(tidyr)#drop_na()
df <- merge(fnc_df,loading_df,by="Id")
labels_df$is.train  = T
df <- merge(x=labels_df, y=df, all.x=TRUE)
df<-drop_na(df)
df<-df[,-c(1,7)]
head(df)
return(df)
}
data<-get.data("../input/trends-assessment-prediction/fnc.csv","../input/trends-assessment-prediction/loading.csv","../input/trends-assessment-prediction/train_scores.csv")
smp_size <- floor(0.75 * nrow(data))
## set the seed to make your partition reproducible
set.seed(123)
train_ind <- sample(seq_len(nrow(data)), size = smp_size)
train <- data[train_ind, ]
test <- data[-train_ind, ]
dim(train)
dim(test)
head(train)
library(tidyverse)
library(caret)
library(glmnet)
library(doMC)
library(tictoc)
set.seed(123)
x <- model.matrix(domain1_var1~., train)[,-c(1,2,3,4,5)]#input must be in model.matrix()
y <- train$domain1_var1
tic("cv-ing....")
#1--lassoo 0---ridge
cv <- cv.glmnet(x,y, alpha = 1,parallel = TRUE
# Performing CV to get the best lambda value
toc()
cv$lambda.min
#fitting using optimum lambda(penalty)
model <- glmnet(x, y, alpha = 1, lambda =0.1)
print(model)
#Elastic-net using caret library....CV performed to select best alpha & lambda
set.seed(123)
tic("training")
model <- train(
  domain1_var2 ~., data = train[,-c(1,2,4,5)], method = "glmnet",
  trControl = trainControl("cv", number = 10),
  tuneLength = 10, parallel=TRUE
)
toc()
# Best tuning parameter
model$bestTune
#coef(model$finalModel, model$bestTune$lambda)


# Tool for visulising the harmonic metrics in one plot.
source("utils/load-data.r")

alldata = LoadClassificationData()

tscurve = function(classname, ...)
{
    clsi = alldata@data$dominant == classname & alldata@data$pure
    curvefunc = function(x)
    {
        # 1 -> 0, 13 -> tau
        x = x-1 # 0-12
        x = x/12*2*pi
        mean(alldata@data[clsi,"mean.ndvi"])+
        mean(alldata@data[clsi,"amplitude1"])*cos(x+mean(alldata@data[clsi,"phase1"]))+
        mean(alldata@data[clsi,"amplitude1"])*sin(x+mean(alldata@data[clsi,"phase1"]))+
        mean(alldata@data[clsi,"amplitude2"])*cos(2*(x+mean(alldata@data[clsi,"phase2"]))) +
        mean(alldata@data[clsi,"amplitude2"])*sin(2*(x+mean(alldata@data[clsi,"phase2"])))
    }
    curve(curvefunc, from=1, to=13, ylab="NDVI", xlab="Month", xaxp=c(1, 12, 11), ylim=c(-0.1, 1.1), ...)
}

pdf("../thesis/thesis-figures/timeseries.pdf", width=7, height=4)
opar = par()
par(mar=c(5.1,4.1,1.1,8.1))
tscurve("cropland", col="gold")
tscurve("dec.trees", col="green3", add=TRUE)
tscurve("evgr.trees", col="darkgreen", add=TRUE)
tscurve("shrubland", col="purple", add=TRUE)
tscurve("grassland", col="lawngreen", add=TRUE)
tscurve("wetland", col="springgreen", add=TRUE)
tscurve("bare.soil", col="khaki4", add=TRUE)
tscurve("urban", col="red", add=TRUE)
tscurve("water", col="blue", add=TRUE)
par(xpd=TRUE)
legend(13.5, 1, lty=1,
    legend=c("Crops", "Dec. trees", "Evgr. trees", "Shrubs", "Grass", "Wetland", "Barren", "Built-up", "Water"),
    col=c("gold", "green3", "darkgreen", "purple", "lawngreen", "springgreen", "khaki4", "red", "blue"))
par(opar)
dev.off()


#The below function replicates the operation of Rnd() from Visual Basic 6 when a positive input parameter is used.
ExcelRand64<-function(ExcelSeed,outputmax)
{
	vara = as.integer64(ExcelSeed)
	varb = as.integer64(1140671485)
	varc = as.integer64(12820163)
	firstflag<-TRUE
	ValueA<-0
	while(ValueA>=outputmax | firstflag){
		firstflag<-FALSE
		vara = as.integer64(ExcelSeed)
		ExcelSeed<-as.integer64(vara *varb +varc )%%as.integer64(2^24)
		ValueA<- outputmax*ExcelSeed/2^24+1
	}
	returnHelp<-list()
	returnHelp[["Step"]]<-ExcelSeed
	returnHelp[["ExcelOutput"]]<-ExcelSeed/2^24
	returnHelp[["RATSTAT"]]<-ValueA
	returnHelp
}

#The below function replicates the operation of the Visual Based 6 function Randomize()
ExcelRandomize64<-function(startingpoint,ExcelSeed){
	testhelptemp<-writeBin(as.double(startingpoint),raw(),size=8)
	bitlist<-rawToBits(testhelptemp)[33:64]
	bitseed<-intToBits(as.integer(ExcelSeed))
	vara<-packBits(c(bitlist[1:16],intToBits(0)[1:16]),"integer")
	varb<-packBits(c(bitlist[17:32],intToBits(0)[1:16]),"integer")
	moshedbitsA<-intToBits(bitwXor(vara,varb))
	finalmosh<-(c(intToBits(0)[1:8],moshedbitsA[1:16],intToBits(0)[1:8]) | c(bitseed[1:8],intToBits(0)[1:24]))
	newSeed<-packBits(finalmosh ,"integer")
	newSeed
}

#The below function replicates the operation of the Visual Basic 6 function Rnd() when a negative input parameter is used.
ExcelRandInit<-function(initvar)
{
	testhelp<-writeBin(as.double(initvar),raw(),size=4)
	testhelp<-rawToBits(testhelp)
	packBits(c(testhelp[25:32],intToBits(0)[1:24]),"integer") +packBits( c(testhelp[1:24],intToBits(0)[1:8]),"integer")
}

#This replication requires the "bit64" library.
library(bit64)

#Emulates Rnd(-1)
CurrentSeed<-ExcelRandInit(-1)
#Emulates Rnd()
CurrentSeed<-ExcelRand64(CurrentSeed,30269)[["Step"]]
#The above two lines of code result in the value 3758214 which is listed in Step 1 of the detailed specification

#Emulates the Visual Basic function Randomize() given the seed entered by the user or the system clock if no seed is provided
CurrentSeed<-ExcelRandomize64(102284,CurrentSeed)
#The above line of code equates to steps 2 through 5 in the detailed specification document

#Emulates the three calls to the Visual Basic 6 function Rnd().
ResA<-ExcelRand64(CurrentSeed,30269)
ResB<-ExcelRand64(ResA[["Step"]],30307)
ResC<-ExcelRand64(ResB[["Step"]],30323)
#The above three lines of code equate to Steps 6 through 15 in the detailed specification document

#Given the three seed generated from the Excel functions Rnd() and Randomize(), RAT-STATS uses the standard Wichmann-Hill algorithm
#to generate the actual random numbers. The below code emulates the algorithm using R.

Seed_A<-floor(ResA[["RATSTAT"]])
Seed_B<-floor(ResB[["RATSTAT"]])
Seed_C<-floor(ResC[["RATSTAT"]])
samsiz<-70
RandomNumber<-NA*(1:samsiz)
Lowb<-0
Upb<-101
repcheck<-0*(1:(Upb-Lowb+1))
for(j in 1:samsiz){
	repflag=TRUE
	while(repflag){
		Term_1=floor(Seed_A/177)
		Term_2=Seed_A - (177*Term_1)
		Seed_A = 171*Term_2 - 2*Term_1
		if (Seed_A <= 0) {Seed_A = Seed_A +30269}

		Term_1=floor(Seed_B/176)
		Term_2=Seed_B - (176*Term_1)
		Seed_B = 172*Term_2 - 35*Term_1
		if (Seed_B <= 0){Seed_B = Seed_B +30307}

		Term_1=floor(Seed_C/178)
		Term_2=Seed_C - (178*Term_1)
		Seed_C = 170*Term_2 - 63*Term_1
		if (Seed_C <= 0) {Seed_C = Seed_C +30323}

		Term_4 = Seed_A/30269 +  Seed_B/30307 + Seed_C/30323
		RandomNumber[j] = floor((Term_4 - floor(Term_4))*(Upb-Lowb+1))+Lowb
		if(repcheck[RandomNumber[j]-Lowb]==0)
		{
			repcheck[RandomNumber[j]-Lowb]=1
			repflag=FALSE
		}
	}
}

sum(RandomNumber)
print(RandomNumber)
print(sum(RandomNumber))

sdk/contrib/Function - Single Stage Random Numbers/randomReplicate_03js.r


#' Compute discharge and hyrdaulic geometry
#' @param Ac Vector of catchment area for calibration points in $m^2$
#' @param Qc Vector of discharge for calibration points in $m^3/s$
#' @param Ap Vector or raster of catchment area for prediction
#' @param use_prior Logical, use the prior for scaling? See 'details'
#' @details Computes discharge from catchment area as \eqn{\log Q = \log b + m \log A}.
#' 		If a single point in `calib` is included, the relationship will be re-parameterised by
#'  	adjusting the intercept parameter `b` so that the calibration point falls on the line
#' 		(while keeping the slope the same).
#'
#' 		With multiple points, a regression model is fit. If `use_prior == TRUE`, this is a Bayesian model
#' 		using the parameters from Burgers et al (2014). These priors are calibrated from a variety of rivers,
#' 		and the prior is quite strong, so it is possible with a small number of calibration points that the line
#' 		is quite far from the calibration. In this case, either re-run this function with a single calibration point,
#' 		or run with `use_prior = FALSE` (but this is only recommended if `range(Ac)` is similar to `range(Ap)`.
#'
#' 		For discharge scaling, catchment area units are expected to be in
#' 		\eqn{m^2}, and discharge will be computed in \eqn{m^3 s^{-1}}.
#'
#' 		Following computation of discharge, other aspects of hydralic geometry are computed following Raymond et al (2012).
#' @references Burgers HE et al. 2014. Size relationships of water discharge in rivers: scaling
#' 		of discharge with catchment area, main-stem lengthand precipitation.
#' 		*Hydrological Processes*. **28**:5769-5775.
#'
#' Raymond, PA et al. 2012. Scaling the gas transfer velocity and hydraulic
#' 		geometry in streams and small rivers. *Limnology and Oceanography: Fluids and
#' 		Environments*. **2**:41-53.
#' @examples
#' \donttest{
#'     library(sf)
#'     data(kamp_q)
#'     data(kamp_dem)
#'
#'     kamp = delineate(kamp_dem)
#'     kamp_Tp = pixel_topology(kamp)
#'     CA = catchment(kamp, type = 'reach', Tp = kamp_Tp)
#'
#'     ## need to transform coordinate system for kamp_q to match
#'     ## need to snap to stream
#'     ## need to make sure this works
#'     ## should probably update kamp_q projection to match kamp_dem
#'
#'     kamp_q$ca = catchment(kamp, type = 'points', y = st_geometry(kamp_q), Tp = kamp_Tp)
#'     x = hydraulic_geometry(kamp_q$ca, kamp_q$discharge, CA)
#' }
#' @return A data.frame with the following variables:
#'     * CA; the input catchment area
#'     * Q; discharge
#'     * v; water velocity
#'     * z; water depth
#'     * w; width
#'     * Ax; stream cross-sectional area
#' @export
hydraulic_geometry = function(Ac, Qc, Ap, use_prior = TRUE) {
	if(length(Ac) != length(Qc))
		stop("Ac and Qc must have the same length")

	## set up units to make conversion easy
	if(!is(Ap, "units")) {
		warning("No units set for Ap, assuming m^2")
		Ap = units::set_units(Ap, "m^2")
	}
	if(!is(Ac, "units")) {
		warning("No units set for Ac, assuming m^2")
		Ac = units::set_units(Ac, "m^2")
	}
	if(!is(Qc, "units")) {
		warning("No units set for Qc, assuming m^3/s")
		Qc = units::set_units(Qc, "m^3/s")
	}

	## convert the input units to those expected from Burgers et al, then drop the units
	Ap_km = units::set_units(Ap, "km^2")
	Ac = units::set_units(Ac, "km^2")
	Qc = units::set_units(Qc, "km^3/day")
	Ap_km = units::drop_units(Ap_km)
	Ac = units::drop_units(Ac)
	Qc = units::drop_units(Qc)

	if(length(Ac) == 1) {
		pars = .q_prior[1,]
		pars["log_intercept"] <- log(Qc) - pars["slope"] * log(Ac)
	} else {
		pars = .q_calib(Ac, Qc)
	}
	qq = .q_predict(pars, Ap_km)
	Qp = units::set_units(qq, "km^3/day")
	Qp = units::set_units(Qp, "m^3/s")

	## parameters from Raymond et al
	res = data.frame(
		CA = Ap,
		Q =	Qp,
		v = units::set_units(exp(-1.64 + 0.285 * log(qq)), "m/s"),
		z = units::set_units(exp(-0.895 + 0.294 * log(qq)), "m"),
		w = units::set_units(exp(2.56 + 0.423 * log(qq)), "m"))
	res
}

#' @name q_calib
#' @rdname q_calib
#' @title Calibrate discharge
#' Runs a bayesian linear regression to compute discharge from catchment area
#' @param x A [raster] stream map, such as one created by [delineate()].
#' @return An `sf` stream layer
#' @keywords internal
.q_calib = function(a, q) {
	par = rnorm(3, .q_prior()[1,], .q_prior()[2,]*2)
	names(par) = c("log_intercept", "slope", 'log_sd')
	optim(par, .q_lpost, a = a, q = q, control=list(fnscale=-1))$par
}

#' @rdname q_calib
#' @keywords internal
.q_prior = function() {
	matrix(c(log(6.3e-6), 0.4137399, 0.78, 0.03571429, 0, 5), nrow=2,
		   dimnames = list(c("pr_mean", "pr_sd"), c("log_intercept", "slope", 'log_sd')))
}

#' @rdname q_calib
#' @keywords internal
.q_predict = function(par, a) {
	exp(par["log_intercept"] + par["slope"] * log(a))
}

#' @rdname q_calib
#' @keywords internal
.q_lpost = function(par, a, q) {
	sum(dnorm(q, .q_predict(par, a), exp(par['log_sd']), log=TRUE)) +
		sum(dnorm(par, .q_prior()[1,], .q_prior()[2,], log=TRUE))
}


n <- 1000
x <- 1:n
S <- sum(x)
onethird <- function(n) sum(3/10^c(1:n))
1/3 - onethird(4)
1/3 - onethird(10)
1/3 - onethird(16)
# integral example
width <- 0.01
x <- seq(2,4,width)
areaofbars <- f(x)*width
f = function(n) n^1.5
areaofbars <- f(x)*width
sum(areaofbars)
head(dat)
view(dat)
View(dat)
library(dplyr)
control <- filter(dat, Diet=="chow")  %>%
select(Bodyweight)  %>%
unlist
treatment <- filter(dat,Diet=="nf")  %>%
select(Bodyweight) %>%
unlist
print(mean(treatment))
treatment <- filter(dat,Diet=="hf")  %>%
select(Bodyweight) %>%
unlist
print( mean(treatment))
print( mean(control))
obsdiff <- mean(treatment) - mean(control)
print(obsdiff)
# Random Variables
filename <- "femaleControlsPopulation.csv"
if (!file.exists(filename))
download(url,destfile=filename)
population <- read.csv(filename)
population unlist(population)
population <- unlist(population)
control <- sample(population,12)
mean(control)
control <- sample(population,12)
mean(control)
control <- sample(population,12)
mean(control)
View(population )
# The Null Hypothesis
url <- "https://raw.githubusercontent.com/genomicsclass/dagdata/master/inst/extdata/femaleControlsPopulation.csv"
filename <- "femaleControlsPopulation.csv"
if (!file.exists(filename))
download(url,destfile=filename)
download(url,destfile=filename)
population <- read.csv(filename)
population <- unlist(population)
control <- samlpe(population,12)
control <- sample(population,12)
mean(control)
mean(control)
mean(control)
mean(control)
# The Null Hypothesis
control <- sample(population,12)
treatment <- sample(population,12)
print(mean(treatment) - mean(treatment))
print(mean(treatment) - mean(control))
# Now let's do this 10000 times
n <- 10000
null <- vector("numeric",n)
for (i in 1:n){}
for (i in 1:n){
treatment <- sample(population,12)
control <- sample(population,12)
null[i] <- mean(treatment) - mean(control)
}
mean(null >= obsdiff)
View(n)
# Distributions
library(UsingR)
install.packages("UsingR")
library(UsingR)
x <- father.son$fheight
round(sample(x,10),1)
smallest <- floor( min(x))
largest <- ceiling( max(x))
values <- seq(smallest, largest, len=300)
heightecdf <- ecdf(x)
View(x)
plot(values, heightecdf(values), type="l", xlab="a (Height in inches)", ylab="Pr(x <= a)")
?ecdf
plot(values, heightecdf(values), type="l", xlab="a (Height in inches)", ylab="Pr(x <= a)")
# Histograms
hist(x)
bins <- seq(smallest, largest)
hist(x,breaks=bins,xlab="Height (in inches)", main="Adult men heights")
hist(x)
hist(x,breaks=bins,xlab="Height (in inches)", main="Adult men heights")
# Probability Distribution
n <- 500
library(rafalib)
nullplot(-5,5,1,30, xlab="Observed differences (grams)", ylab="Frequency")
totals <- vector("numeric",11)
for (i in 1:n) {
control <- sample(population, 12)
treatment <- sample(population,12)
nulldiff <- mean(treatment) - mean(control)
j <- pmax(pmin(round(nulldiff)+6,11),1)
totals[j] <- totals[j]+1
text(j-6,totals[j],pch=15,round(nulldiff,1))
if(i <15) Sys.sleep(1)
}
hist(null, freq=TRUE)
abline(v=obsdiff, col="red", lwd=2)
# Normal Distribution
pnorm(obsdiff,mean(null),sd(null))
# Populations, Samples and Estimates
url <- "https://raw.githubusercontent.com/genomicsclass/dagdata/master/inst/extdata/mice_pheno.csv"
filename <- "mice_pheno.csv"
download(url,destfile=filename)
dat <- read.csv(filename)
controlPopulation <- filter(dat,Sex == "F" & Diet == "chow")  %>%
select(Bodyweight)  %>%
unlist
View(dat)
controlPopulation <- filter(dat,Sex == "F" & Diet == "chow")  %>%
select("Bodyweight")  %>%
unlist
controlPopulation <- filter(dat,Sex == "F" & Diet == "chow")  %>%
select("Bodyweight")  %>%
unlist
controlPopulation <- filter(dat,Sex == "F" & Diet == "chow")  %>% select(Bodyweight)  %>% unlist
library(dplyr)
controlPopulation <- filter(dat, Sex=="F" & Diet=="chow")  %>%
select(Bodyweight)
select(Bodyweight) <- controlPopulation unlist
controlPopulation <- controlPopulation unlist
controlPopulation <- unlist controlPopulation
unlist(controlPopulation)
controlPopulation <- unlist(controlPopulation)
hfPopulation <- filter(dat, Sex == "F" & Diet=="hf")  %>%
select(Bodyweight)
hfPopulation <- unlist(hfPopulation)
library(rafalib)
mypar(1,2)
hist(hfPopulation)
hist(controlPopulation)
mypar(1,2)
qqnorm(hfPopulation)
qqline(hfPopulation)
qqnorm(controlPopulation)
qqline(controlPopulation)
# The Central Limit Theorem in Practice
dat <- read.csv("mice_pheno.csv")
head(dat)
library(dplyr)
controlPopulation <- filter(dat,Sex=="F" & Diet == "chow")  %>%
select(Bodyweight)  %>% unlist
hfPopulation <- filter(dat,Sex=="F" & Diet=="hf")  %>%
select(Bodyweight)  %>% unlist
mu_hf <- mean(hfPopulation)
mu_control <- mean(controlPopulation)
print(mu_hf - mu_control)
x <- controlPopulation
N <- length(x)
populationvar <- mean((x-mean(x))^2)
identical var(x), populationvar)
identical(var(x), populationvar)
var(x)
identical(var(x)*(N-1)/N, populationvar)
library(rafalib)
sd_hf <- popsd(hfPopulation)
sd_control <- popsd(controlPopulation)
N <- 12
hf <- sample(hfPopulation, 12)
control <- sample(controlPopulation, 12)
Ns <- c(3,12,25,50)
B <- 10000 # number of simulations
res <- sapply(Ns,function(n) {
replicate(B,mean(sample(hfPopulation,n)) - mean(sample(controlPopulation,n)))
})
mypar(2,2)
for (i in seq(along=Ns)) {}
for (i in seq(along=Ns)) {
titleavg <- signif(mean(res[,i],3),3)
titlesd <- signif(popsd(res[,i]),3)
title <- paste0("N=",Ns[i]," Avg=",titleavg,"SD=",titlesd)
qqnorm(res[,i],main=title)
qqline(res[,i],col=2)
}
computestat <- function(n) {}
y <- sample(hfPopulation,n)
computestat <- function(n) {
y <- sample(hfPopulation,n)
x <- sample(controlPopulation,n)
(mean(y)-mean(x))/sqrt(var(y)/n+var(x)/n)
}
res < sapply(Ns,function(n) {)
res < sapply(Ns,function(n) {
replicate(B,computestat(n))
})
mypar(2,2)
for (i in seq(along=Ns)) {}
for (i in seq(along=Ns)) {
qqnorm(res[,i],main=Ns[i])
qqline(res[,i],col=2)
}
# t-tests in practice
# Read in and prepare data
dat <- read.csv("femaleMiceWeights.csv")
control <- filter(dat, Diet=="chow")  %>%
select(Bodyweight)  %>% unlist
treatment <- filter(dat, Diet=="hf")  %>%
select(Bodyweight)  %>% unlist
diff <- mean(treatment) - mean(control)
pritn(diff)
print(diff)
# calculate SE
sd(control)/sqrt(length(control))
se <- sqrt(
var(treatment)/length(treatment) +
var(control)/length(control)
)
tstat <- diff/se
righttail <- 1 - pnorm(abs(tstat))
lefttail <- pnorm(-abs(tstat))
pval <- lefttail + righttail
print(pval)
# The t-distribution in practice
mypar(1,2)
qqnorm(treatment)
qqline(treatment,col=2)
qqnorm(control)
qqline(control,col=2)
t.test(treatment, control)
result <- t.test(treatment, control)
result$p.value
dat <- read.csv("mice_pheno.csv")
control <- filter(dat, Diet=="chow")  %>%
select(Bodyweight)
treatment <- filter(dat, Diet=="hf")
treatment <- filter(dat, Diet=="hf")  %>%
select(Bodyweight)
t.test(treatment, control)
# Confidence Intervals
dat <- read.csv("mice_pheno.csv")
chowPopulation <- dat[dat$Sex=="F" & dat$Diet=="chow",3]
View(chowPopulation)
mu_chow <- mean(chowPopulation)
pritn(mu_chow)
print(mu_chow)
N <- 30
chow <- sample(chowPopulation,N)
print(mean(chow))
se <- sd(chow)/sqrt(N)
print(se)
pnorm(2) - pnorm(-2)
pnorm(1-0.02/2) - pnorm(-2)
pnorm(1-0.05/2) - pnorm(-2)
Q <- qnorm(1- 0.05/2)
interval <- c(mean(chow)-Q*se, mean(chow)+Q*se )
interval
interval[1] < mu_chow & interval[2] > mu_chow
B <- 250
mypar()
plot(mean(chowPopulation)+c(-7,7),c(1,1),type="n", xlab="weight",ylab="interval",ylim=c(1,B))
abline(v=mean(chowPopulation))
for (i in 1:B) {}
for (i in 1:B) {
chow <- sample(chowPopulation,N)
se <-sd(chow)/sqrt(N)
interval <- c(mean(chow)-Q*se, mean(chow)+Q*se)
covered <- mean(chowPopulation) <= interval[2] & mean(chowPopulation) >= interval[1]
color <- ifelse(covered,1,2)
lines(interval, c(i,i),col=color)
}
plot(mean(chowPopulation)+c(-7,7),c(1,1),type="n", xlab="weight",ylab="interval",ylim=c(1,B))
abline(v=mean(chowPopulation))
Q <- qnorm(1- 0.05/2)
N <- 5
for (i in 1:B) {
chow <- sample(chowPopulation,N)
se <- sd(chow)/sqrt(N)
interval <- c(chowPopulation) <= interval[2] & mean(chowPopulation) >= interval[1]
color <- ifelse(covered,1,2)
lines(interval, c(i,i),col=color)
}
}
plot(mean(chowPopulation)+c(-7,7),c(1,1),type="n", xlab="weight",ylab="interval",ylim=c(1,B))
abline(v=mean(chowPopulation))
Q <- qnorm(1- 0.05/2)
N <- 5
for (i in 1:B) {
chow <- sample(chowPopulation,N)
se <- sd(chow)/sqrt(N)
interval <- c(mean(chow)-Q*se, mean(chow)+Q*se)
covered <- mean(chowPopulation) <= interval[2] & mean(chowPopulation) >= interval[1]
color <- ifelse(covered,1,2)
lines(interval, c(i,i),col=color)
}
plot(mean(chowPopulation)+c(-7,7),c(1,1),type="n", xlab="weight",ylab="interval",ylim=c(1,B))
abline(v=mean(chowPopulation))
Q <- qt(1- 0.05/2, df=4)
N <- 5
for (i in 1:B) {
chow <- sample(chowPopulation,N)
se <- sd(chow)/sqrt(N)
interval <- c(mean(chow)-Q*se, mean(chow)+Q*se)
covered <- mean(chowPopulation) <= interval[2] & mean(chowPopulation) >= interval[1]
color <- ifelse(covered,1,2)
lines(interval, c(i,i),col=color)
}
qt(1- 0.05/2, df=4)
qnorm(1- 0.05/2)
# Power Calculations
dat <- read.csv("mice.pheno.csv") # Previously downloaded
dat <- read.csv("mice_pheno.csv") # Previously downloaded
controlPopulation <- filter(dat,Sex=="F" & Diet=="chow")  %>% select(Bodyweight)  %>% unlist
hfPopulation <- filter(dat,Sex=="F" & Diet=="hf")  %>%
select(Bodyweight)  %>% unlist
mu_hf <- mean(hfPopulation)
mu_control <- mean(controlPopulation)
print(mu_hf - mu_control)
print((mu_hf - mu_control)/mu_control*100) # percent increase
set.seed(1)
N<-5
hf <- sample(controlPopulation,N)
control <- sample(controlPopulation,N)
t.test(hf,control)$p.value
hf <- sample(controlPopulation,N)
control <- sample(controlPopulation,N)
t.test(hf,control)$p.value
# Type I error - False Posotive
# Type II error - False Negative
N <- 12
alpha  <- 0.05
B  <- 2000
reject  <- function(N, alpha=0.05){
hf <- sample(hfPopulation,N)
control <- sample(controlPopulation,N)
pval <- t.test(hf,control)$p.value
pval <- alpha
}
reject  <- function(N, alpha=0.05){
hf <- sample(hfPopulation,N)
control <- sample(controlPopulation,N)
pval <- t.test(hf,control)$p.value
pval < alpha
}
reject(12)
rejections  <- replicate(B,reject(N))
mean(rejections)
Ns  <- seq(5, 50, 5)
power  <-  sapply(NS,function(N){
rejections  <- replicate(B, reject(N))
mean(rejections)
})
power  <-  sapply(Ns,function(N){
rejections  <- replicate(B, reject(N))
mean(rejections)
})
plot(Ns, power, type="b")
N  <- 30
alphas  <- c(0.1,0.05,0.01,0.001,0.0001)
power  <- sapply(alphas,function(alpha){
rejections  <- replicate(B,reject(N,alpha=alpha))
mean(rejections)
})
plot(alphas, power, xlab="alpha", type="b", log="x")
# p-valueas are arbitrary under the Alternative Hypothesis
calculatePvalue <- function(N) {
hf  <- sample(hfPopulation,N)
control <- sample(controlPopualtion,N)
control <- sample(controlPopulation,N)
t.test(hf,control)$p.value
}
Ns  <- seq(10,200,by=10)
Ns_rep <- rep(Ns,each=10)
pvalueas  <- sapply(Ns_rep, calculatePvalue)
calculatePvalue <- function(N) {
hf  <- sample(hfPopulation,N)
control <- sample(controlPopulation,N)
t.test(hf,control)$p.value
}
pvalues  <- sapply(Ns_rep, calculatePvalue)
plot(Ns_rep, pvalues, log="y", xlab="sample size", ylab="p-values")
abline(h=c(.01, .05), col="red", lwd=2)
N <- 12
hf <- sample(hfPopulation,N)
control <- sample(controlPopulation, N)
diff <- mean(hf) - mean(control)
diff / mean(control) * 100
control <- sample(controlPopulation, N)
hf <- sample(hfPopulation,N)
diff <- mean(hf) - mean(control)
diff / mean(control) * 100
t.test(hf, control)$conf.int / mean(control) * 100
# Cohen's d
sd_pool  <- sqrt(((N-1)*var(hf) + (N-1)*var(control))/(2*N-2))
diff/sd_pool
## Monte Carlo Simulation
library(dplyr)
dat <- read.csv("mice_pheno.csv")
controlPopulation  <- filter(Sex=="F" & Diet=="chow")
controlPopulation  <- filter(dat,Sex=="F" & Diet=="chow")  %>% select(Bodyweight)  %>% unlist
ttestgenerator  <- function(n) {
#note that here we have a false "high fa" group where we actually sample from the nonsmokers. this is because we are modeling the *null*
cases  <- sample(controlPopulation,n)
controls <- sample(controlPopulation,n)
tstat <- (mean(cases)-mean(controls)) / sqrt(var(cases)/n + var(controls)/n)
return(tstat)
}
ttests <-replicate(1000,ttestgenerator(10))
hist(ttests)
qqnorm(ttests)
abline(0,1)
# how about a sample size of three
ttests  <- replicate(1000, ttestgenerator(3))
qqnorm(ttests)
abline(0,1)
ps <- (seq(0,999)+0.5)/1000
qqplot(qt(ps,df=2*3-2),ttests,xlim=c(-6,6),ylim=c(-6,6))
abline(0,1)
qqnorm(controlPopulation)
qqline(controlPopulation)
# Parametric Simulations for the Observations
controls <- rnorm(5000, mean=24, sd=3.5)
ttestgenerator <- function(n, mean=24, sd=3.5) {
cases <- rnorm(n,mean,sd)
controls <- rnorm(n,mean,sd)
tstat <- (mean(cases)-mean(controls))/sqrt(var(cses)/n + var(controls)/n)
return(tstat)
}
# Permutation tests
dat=read.csv("femaleMiceWeights.csv")
control <- filter(dat,Diet=="chow")  %>%
select(Bodyweight) %>%
unlist
treatment <- filter(dat,Diet=="hf") %>%
select(Bodyweight) %>%
unlist
obsdiff <- mean(treatment)-mean(control)
N <- 12
avgdiff <- replicate(1000, {
all <- sample(c(control,treatment))
newcontrols <- all[1:N]
newtreatments <- all[(N+1):(2*N)]
return(mean(newtreatments) - mean(newcontrols))
})
hist(avgdiff)
abline(v=obsdiff, col="red", lwd=2)
# the proportion of permutations with larger difference
(sum(abs(avgdiff) > abs(obsdiff))+1) / (length(avgdiff) + 1)
# and again with a smaller dataset
N <- 5
control <- sample(control,N)
treatment <- sample(treatment,N)
obsdiff<- mean(treatment) - mean(control)
avgdiff <- replicate(1000,{
all <- sample(c(control,treatment))
newcontrols <- all[1:N]
newtreatments <- all[(N+1):(2*N)]
return(mean(newtreatments) - mean(newcontrols))
})
hist(avgdiff)
abline(v=obsdiff, col="red", lwd=2)
# Association Tests
tab <- matrix(c(3,1,1,3),2,2)
rownames(tab)<-c("poured Before", "Poured After")
colnames(tab) <- c("Guessed before","Guessed after")
tab
rownames(tab)<-c("Poured Before", "Poured After")
tab
fisher.text(tab,alternative="greater")
fisher.test(tab,alternative="greater")
# Chi-squared test
disease = factor(c(rep(0,180),rep(1,20),rep(1,40),rep(1,10)),labels=c("control","cases"))
genotype=factor(c(rep("AA/Aa",200),rep("aa",50)),levels=c("AA/Aa","aa"))
dat <- data.frame(disease,genotype)
dat <- dat[sample(nrow(dat)),]
head(dat)
dat <- dat[sample(nrow(dat)),] # shuffle them up
head(dat)
table(genotype)
table(disease)
tab <- table(genotype,disease)
tab
# Odds Ratio
(tab[2,2]/tab[2,1]) / (tab[1,2]/tab[1,1])
disease = factor(c(rep(0,180),rep(1,20),rep(1,40),rep(1,10)),labels=c("control","cases")))
disease = factor(c(rep(0,180),rep(1,20),rep(0,40),rep(1,10)),labels=c("control","cases"))
dat <- data.frame(disease, genotype)
dat <- dat[sample(nrow(dat)),] # shuffle it up
head(dat)
tab <- table(genotype,disease)
tab
(tab[2,2]/tab[2,1]) / (tab[1,2]/tab[1,1])
p=mean(disease=="cases")
expected <- rbind(c(1-p,p)*sum(genotype=="AA/Aa"),c(1-p,p)*sum(genotype=="aa"))
dimnames(expected)dimnames(tab)
dimnames(expected) <- dimnames(tab)
expected
chisq.test(tab)$p.value
tab <- tab*10
chisq.test(tab)$p.value
# Large Samples, Small p-values
# Confidence Intervals For The Odd Ratio
fit <- glm(disease~genotype,family="binomial",data=dat)
coeftab <- summary(fit)$coef
coaeftab
coeftab
ci <- coeftab[2,1] + c(-2,2)*coeftab[2,2]
exp(ci)
savehistory("~/repos/RLifeSciences/Chappie1/worklog.r")


################################################################################
# The contents of this file are Teradata Public Content
# and have been released to the Public Domain.
# Licensed under BSD; see "license.txt" file for more information.
# Copyright (c) 2021 by Teradata
################################################################################
#
# R And Python Analytics with SCRIPT Table Operator
# Orange Book supplementary material
# Alexander Kolovos - October 2021 - v.2.1
#
# Example 5: Linear Regression with the CALCMATRIX table operator (R version)
# File     : ex5r.r
#
# (Adapted from the Teradata Developer Exchange online example by Mike Watzke:
#  http://developer.teradata.com/extensibility/articles/
#  in-database-linear-regression-using-the-calcmatrix-table-operator)
#
# Use case:
# A simple example of linear regression with one dependent and two independent
# variables (univariate, multiple variable regression). For the regression
# computations, we need to calculate the sums of squares and cross-products
# matrix of the data. The example illustrates how to use the CALCMATRIX table
# operator for this task. The script returns the estimates of the regression
# coefficients.
#
# Script accounts for the general scenario that an AMP might have no data.
#
# Required input:
# - ex5tbl table data from file "ex5dataTblDef.sql"
#
# Output:
# - varName: Regression coefficient name
# - B      : Regression coefficient estimated value
#
################################################################################

DELIMITER='\t'

stdin <- file(description="stdin",open="r")

inputDF <- data.frame();

# Need to know in advance the type of all input columns. Cite them in following
# vector to feed the colClasses argument of the read.table() function.
cv <- c("numeric","character","numeric","numeric","numeric","numeric","numeric")
inputDF <- try(read.table(stdin, sep=DELIMITER, flush=TRUE, header=FALSE,
                      quote="", na.strings="", colClasses=cv, strip.white=TRUE),
               silent=TRUE)

close(stdin)

# For AMPs that receive no data, choose to simply quit the script immediately.
if (class(inputDF) == "try-error") {
    inputDF <- NULL
    quit()
}

nObs <- nrow(inputDF)
colnames(inputDF) <- c('rownum', 'rowname', 'c', 's', 'x1', 'x2', 'y')

# Determine the position of the independent variable columns
xcols <- which(!names(inputDF) %in% c('rownum','rowname','c','y'))
# Extract partial X'X
pXX <- inputDF[ inputDF[['rowname']] != 'y' , c(xcols)]
# Extract observation count
obscount <- inputDF[ inputDF[['rowname']] == 'y' , c('c')]
# Extract X variable summations
Xsum <- inputDF[ inputDF[['rowname']] != 'y' , c('s')]
# Build first row of matrix X'X
XX <- data.matrix(obscount)
XX <- cbind(XX, t(data.matrix(Xsum)))
# Append partial X'X
XX <- rbind(XX, data.matrix(pXX))
# Invert X'X
iXX <-solve(XX)

# Extract Y variable summations
Ysum <- inputDF[ inputDF[['rowname']] == 'y' , c('s')]
# Extract partial X'Y
XY <- inputDF[ inputDF[['rowname']] != 'y' , 'y']
# Build X'Y of matrix
XY <- rbind(data.matrix(Ysum), data.matrix(XY))
# Multiply inverted X'X * X'Y to obtain coefficients
B <- iXX %*% XY

# Gather names of variables
varName <- inputDF[ inputDF[['rowname']] != 'y' , c('rowname')]
varName <- c("Intercept", varName)

# Build export data frame:
output <- data.frame(varName, B)

# Export results to the SQL Engine database through standard output
write.table(output, file=stdout(), col.names=FALSE, row.names=FALSE,
            quote=FALSE, sep="\t", na="")


library(nlme)
library(ggplot2)
library(repr)

# See: https://stats.idre.ucla.edu/r/examples/alda/r-applied-longitudinal-data-analysis-ch-4/

alcohol1 <- read.table("https://stats.idre.ucla.edu/stat/r/examples/alda/data/alcohol1_pp.txt",
                       header=T, sep=",")

head(alcohol1)

alcohol1$cpeer[3] <- NA
alcohol1$alcuse[5] <- NA

model.g <- lme(alcuse ~ ccoa+cpeer*age_14 , data=alcohol1, random= ~ age_14 | id,
               na.action=na.exclude)
summary(model.g)

table(alcohol1$age_14)

# expand.grid will create a data set with all possible combinations of the inputs
# this is the fake data set I will use for visualization
newdata <- expand.grid(age_14=c(0,2),
                       cpeer=0.7708544,
                       ccoa=unique(alcohol1$ccoa))

newdata

# I need to manually assign fake IDs
# Since I know the structure of my fake data set (that each ID has two rows),
# I can do this easily by repeating each fake ID twice
# To make sure that ID's are fake, I'm going to start numbering from the maximum ID in the original data set
newdata$id <- rep(1:(nrow(newdata)/2), each=2) + max(alcohol1$id)

newdata

newdata$alcuse_pred0 <- predict(model.g, newdata = newdata, level = 0)
# including `level=0` as an argument for predict means that we are not going to bring
# in random effects for prediction (we cannot, anyway, because the IDs we assigned to
# the fake data points do not exist in the original data set)

options(repr.plot.width=5, repr.plot.height=3)
p <- ggplot(newdata, aes(x=age_14, y=alcuse_pred0, group=id, color=factor(ccoa))) +
     geom_line() + geom_point() +
     theme_bw() + ggtitle("Population-level (fixed) effects")
p

# this prediction incorporates fixed + random effects
alcohol1$alcuse_pred <- predict(model.g)

# this prediction is based on fixed effects only
alcohol1$alcuse_pred0 <- predict(model.g, level=0)

p <- ggplot(subset(alcohol1, !is.na(alcuse_pred)),
            aes(x=age_14, y=alcuse_pred, group=id, color=factor(ccoa))) +
     geom_line() + geom_point() +
     theme_bw() + ggtitle("Individual fitted values based on fixed + random effects")
p

p <- ggplot(subset(alcohol1, !is.na(alcuse_pred0)),
            aes(x=age_14, y=alcuse_pred0, group=id, color=factor(ccoa))) +
     geom_line() + geom_point() +
     theme_bw() + ggtitle("Individual fitted values based on fixed effects only")
p


#' Power Analysis for Two Sided T-Test
#'
#' @description This is a function that performs
#' a power analysis of the two-sided t-test.
#' Given the effect size, significance level, and power,
#' the required sample size can be calculated
#' (although the control or treatment sample size must be given).
#' Also, given the sample size of the two groups, effect size,
#' and significance level, the power can be calculated.
#' Given the sample size of two groups, significance level,
#' and power of the two groups, the effect size can be calculated.
#' Given the sample size of two groups, effect size,
#' and power of the two groups, the significance level can be calculated.
#'
#' @param n0 numeric. Number of observations in the control.
#' @param n1 numeric. Number of observations in the treatment.
#' @param d numeric. Effect size.
#' @param alpha numeric. Statistically significance
#' (probability of Type I error).
#' @param power numeric. Power (1 - probability of Type II error).
#'
#' @importFrom stats pt
#' @importFrom stats qt
#' @importFrom stats uniroot
#'
#' @export
#'
#'
ttest_power <- function(n0,
                        n1,
                        d,
                        alpha,
                        power) {
  # extract arguments
  comp <- as.list(match.call())[-1]
  full_args <- c("n0", "n1", "d", "alpha", "power")
  miss_arg <- full_args[!(full_args %in% names(comp))]

  # check length(comp) == 4
  if (length(comp) != 4) abort_empty_num(5 - length(comp), 1)

  # define function which returns specified power - calculated power
  power_func <- function(n0, n1, d, alpha, power) {
    delta <- d * sqrt(1 / n1 + 1 / n0) ^ (-1)
    df <- n1 + n0 - 2
    critical <- qt(alpha / 2, df = df)
    power - (pt(-critical, df = df, ncp = delta, lower.tail = FALSE) +
      pt(critical, df = df, ncp = delta, lower.tail = TRUE))
  }
  comp$f <- power_func

  # set interval
  if (missing(n0) | missing(n1)) {
    comp$interval <- c(0, 1e+09)
  } else if (missing(d)) {
    comp$interval <- c(0, 10)
  } else {
    comp$interval <- c(0, 1)
  }
  message(paste0(
    "Find value between [", comp$interval[1], ",", comp$interval[2], "]."
  ))

  # find missing value satisfying specified power - claculated power = 0
  comp[[miss_arg]] <- do.call("uniroot", comp)$root

  # output
  data.frame(comp[full_args])
}

#'
#' @importFrom dplyr bind_rows
#' @importFrom stats model.frame
#' @importFrom stats model.matrix
#' @importFrom stats formula
#' @importFrom rlang enquo
#' @importFrom rlang eval_tidy
#'
#'
power_calculation <- function(treat = NULL,
                              data = NULL,
                              treat_levels = NULL,
                              treat_labels = NULL,
                              ctrl = NULL,
                              subset = NULL,
                              sd = 1,
                              ...) {
  # clean data
  order_d <- reorder_arms(treat_levels, treat_labels, ctrl)
  model <- formula(paste("~", treat))
  clean <- clean_RCTdata(
    model,
    data = data,
    treat_levels = order_d$levels,
    treat_labels = order_d$labels,
    subset = enexpr(subset)
  )
  use <- clean$design[, -1]

  # perform power analysis
  pass_ttest_power <- list(...)
  pass_ttest_power$n0 <- sum(1 - rowSums(use))
  pwr <- apply(use, MARGIN = 2, function(n) {
    pass_ttest_power$n1 <- sum(n)
    do.call("ttest_power", pass_ttest_power)
  })

  # output dataframe
  out <- bind_rows(pwr)
  out$arms <- gsub(treat, "", names(pwr))

  # calculate unstandarized effect
  out$sd <- sd
  out$diff_mean <- out$d * out$sd

  # add row containing control information
  out <- bind_rows(
    data.frame(
      n0 = pass_ttest_power$n0,
      n1 = pass_ttest_power$n0,
      arms = order_d$labels[1]
    ),
    out
  )

  # convert character of treatment to factor
  out$arms <- factor(out$arms, order_d$labels)

  # output
  out
}


# Classification using Fuzzy rules
# Author: Deepak Sharma
# Date: 3 April 2017

# Import libraries --------------------------------------------------------

require(frbs)

depression_vs_control <- read.csv("depression_vs_control_fuzzy.csv")
dvc <- depression_vs_control
attach(dvc)

# 3 Input and 1 Output variable

## Split the data to be training and testing datasets
data.train <- dvc[sample(nrow(dvc), 90),]
data.tst <- dvc[-sample(nrow(dvc), 90),]
real.val <- as.numeric(as.factor(matrix(dvc[45:52,4])))

## Define interval of data
range.data <-apply(data.train, 1,range)

method.type <- "WM"
control <- list(num.labels = 10, type.mf = "GAUSSIAN", type.defuz = "WAM",
                type.tnorm = "MIN", type.snorm = "MAX", type.implication.func = "ZADEH",
                name = "sim-0")

## Learning step: Generate an FRBS model
object.reg <- frbs.learn(data.train,range.data=NULL,method.type,control)

## Predicting step: Predict for newdata
res.test <- predict(object.reg, data.tst)

## Display the FRBS model
summary(object.reg)

## Plot the membership functions
par(mar = rep(2, 4))
plotMF(object.reg)


source("fibonacci.r")

cat('Fibonacci Sequence:\n')

sprintf('-7: %i', calculate(-7) )
sprintf('-1: %i', calculate(-1) )
sprintf('0: %i', calculate(0) )
sprintf('1: %i', calculate(1) )
sprintf('2: %i', calculate(2) )
sprintf('4: %i', calculate(4) )
sprintf('7: %i', calculate(7) )