## Difference that maintains original array size by appending a row

.fdiff <- function(X) rbind(diff(X), rep(NA,ncol(X)))

## Ghiglia and Pritt's wrap operator. Thanks to Steve K.

wrap <- function(phase) (phase+pi)%%(2*pi) - pi

## Calculate residue map
## A "positive" charged residue has value +1
## A "negative" charge has value -1

rmap <- function(phase, dx=NULL, dy=NULL, plot=FALSE, ...) {
  nr <- nrow(phase)
  nc <- ncol(phase)

  if (is.null(dx)) {
    dx <- wrap(.fdiff(phase))
  }
  if (is.null(dy)) {
    dy <- wrap(t(.fdiff(t(phase))))
  }
  d2y <- rbind(dy[1:(nr-1),]-dy[2:nr,],rep(NA,nc))
  d2x <- cbind(dx[,2:nc]-dx[,1:(nc-1)],rep(NA,nr))
  residues <- round((d2y+d2x)/(2*pi))
  if (plot) {
    ## positive charges
    chp <- which(residues ==1, arr.ind=TRUE)
    ## negative charges
    chm <- which(residues == -1, arr.ind=TRUE)
    image(1:nr, 1:nc, phase, col=grey256, asp=1, xlab="X", ylab="Y", useRaster=TRUE, ...)
    if(length(chp)>0) {
      points(chp, col="green", pch=20)
    }
    if(length(chm)>0) {
      points(chm, col="red", pch=20)
    }
    nr <- sum(abs(residues),na.rm=TRUE)
    nr
  } else {
    residues
  }
}

## "Itoh's" method for phase unwrapping.

## integrate the wrapped phase differences
## This is called by brcutpuw, or it can be called
## directly by the user.

## Note: as of July 2020 the unwrapper is written in C++ using Rcpp.
## It's fastest to bypass the computation of dx and dy in R
## and unwrap with a call to id_uw.
## netflowpuw (in lppuw, and at present unsupported) passes values of dx and dy with ucall==TRUE.
## brcutpuw passes dx and dy with ucall==FALSE.
## The call to id_dxy_uw is slower by about 40%.

idiffpuw <- function(phase, mask=phase, ucall=TRUE, dx=NULL, dy=NULL) {

    nr <- nrow(phase)
    nc <- ncol(phase)

    if (ucall) {
        if (is.null(dx)) {
          puw <- id_uw(as.integer(nr), as.integer(nc), as.vector(phase)/(2*pi))
          puw <- matrix(puw, nr, nc)
        } else {
          puw <- id_dxy_uw(as.integer(nr), as.integer(nc), as.vector(phase)/(2*pi),
                           as.vector(mask), as.vector(dx/(2*pi)), as.vector(dy/(2*pi)),
	                   integer(nr*nc))
          puw <- matrix(puw, nr, nc)
        }
        puw[is.na(phase)] <- NA
        class(puw) <- "pupil"
        puw
    } else {
      if (is.null(dx)) dx <- wrap(.fdiff(phase))
      if (is.null(dy)) dy <- wrap(t(.fdiff(t(phase))))
      uw <- integer(nr*nc)
      puw <- id_dxy_uw(as.integer(nr), as.integer(nc), as.vector(phase)/(2*pi),
                       as.vector(mask), as.vector(dx/(2*pi)), as.vector(dy/(2*pi)),
	               uw)
      puw <- matrix(puw, nr, nc)
      puw[is.na(phase)] <- NA
      uw <- matrix(as.logical(uw), nr, nc)
      class(puw) <- "pupil"
      list(puw=2*pi*puw, uw=uw)
    }
}

## Quality guided unwrapper.
## This is mostly a wrapper for a call to the C++ function "q_uw".

qpuw <- function(phase, qual) {
    nr <- nrow(phase)
    nc <- ncol(phase)

    phase <- phase/(2*pi)
    qual[is.na(phase)] <- 0

    puw <- q_uw(as.integer(nr), as.integer(nc), as.vector(phase), as.vector(qual))
    puw <- matrix(puw, nr, nc)
    puw[is.na(phase)] <- NA
    class(puw) <- "pupil"
    puw
}

##
##  Branch cut algorithm.
## This now solves a variant of the assignment problem to minimize
## the total length of all branch cuts.
##
## note: parameter pen is a penalty added to distances from charges to edges.
##         I'm not sure this is really useful. Seems to work fine with the default
##         of 0.
##

brcutpuw <- function(phase, pen=0, details=FALSE) {

    require(clue)

    ## distance between points specified by their x,y coordinates.

    dmat <- function(p1, p2) {
        fn <- function(x,y) abs(y-x)
        xleg <- outer(p1[,1], p2[,1], FUN=fn)
        yleg <- outer(p1[,2], p2[,2], FUN=fn)
        xleg+yleg
    }

    ## Make a branch cut

    brcut <- function(startp, endp, mask) {
        xl <- endp[1]-startp[1]
        yl <- endp[2]-startp[2]
        if (abs(yl) <= abs(xl)) {
            slope <- yl/xl
            ix <- startp[1]:endp[1]
            iy <- startp[2] + round(slope*(ix-startp[1]))
        } else {
            slope <- xl/yl
            iy <- startp[2]:endp[2]
            ix <- startp[1] + round(slope*(iy-startp[2]))
        }
        mask[cbind(ix,iy)] <- NA
        mask
    }

    res <- rmap(phase)
    ## no residues, so a single call to idiffpuw is all we need
    if (sum(abs(res),na.rm=TRUE) == 0) {
        return(idiffpuw(phase,ucall=TRUE))
    }

    nr <- nrow(phase)
    nc <- ncol(phase)
    dx <- wrap(.fdiff(phase))
    dy <- wrap(t(.fdiff(t(phase))))

    mask <- matrix(1,nr,nc)
    mask[is.na(phase)] <- NA

    ## positive charges
    chp <- which(res==1, arr.ind=TRUE)
    ncp <- nrow(chp)
    ## negative charges
    chm <- which(res== -1, arr.ind=TRUE)
    ncm <- nrow(chm)
    ## get the boundary points - ones one pixel outside the area of defined phase.
    ## step in
    ptsb <- which(is.na(phase) & (!is.na(rbind(phase[-1,], rep(NA, nc)))), arr.ind=TRUE)
    ptsb <- rbind(ptsb, which(is.na(phase) & (!is.na(cbind(phase[,-1], rep(NA, nr)))), arr.ind=TRUE))
    ## step out
    ptsc <- which((!is.na(phase)) & is.na(rbind(phase[-1,], rep(NA, nc))), arr.ind=TRUE)
    ptsc[,1] <- ptsc[,1]+1
    ptsb <- rbind(ptsb, ptsc)
    ptsc <- which((!is.na(phase)) & is.na(cbind(phase[,-1], rep(NA, nr))), arr.ind=TRUE)
    ptsc[,2] <- ptsc[,2]+1
    ptsb <- rbind(ptsb, ptsc)

    if ((ncp>0) & (ncm>0)) {

      ## distances between residues
      dpm <- dmat(chp, chm)

      ## distance from each positive charge to nearest edge
      dce <- dmat(chp, ptsb)
      ipb <- apply(dce, 1, which.min)
      dpe <- apply(dce, 1, min)+pen
      pec <- matrix(ptsb[ipb,], ncp, 2)

      ## distance from each negative charge to nearest edge
      dce <- dmat(chm, ptsb)
      ipb <- apply(dce, 1, which.min)
      dme <- apply(dce, 1, min)+pen
      mec <- matrix(ptsb[ipb,], ncm, 2)

      ## cost matrix of assigning p to edge and m to edge for each (p,m). This has the same dimension as dpm
      cost.ec <- outer(dpe, dme, "+")
      isd <- (dpm <= cost.ec)

      ## elementwise minimum of dpm and cost.ec.
      ## Idea is if dpm[p,m] < cost.ec[p,m] we should connect dipole, otherwise connect both to edge
      minc <- pmin(dpm, cost.ec)
      pecuts <- NULL
      mecuts <- NULL

      ## use Hungarian algorithm from package clue to get optimal assigments from p to m.
      ## Then figure out which are dipole cuts and which are edge cuts.
      ## If ncm > ncp there have to be some unassigned m's. Those connect to edge.

      if (ncm >= ncp) {
        yp <- solve_LSAP(minc)
        ass <- cbind(seq_along(yp), as.integer(as.vector(yp)))
        mecuts <- setdiff(1:ncm, ass[,2])
      } else {
        yp <- solve_LSAP(t(minc))
        ass <- cbind(as.integer(as.vector(yp)), seq_along(yp))
        pecuts <- setdiff(1:ncp, ass[,1])
      }
      dpcuts <- matrix(ass[which(isd[ass]),], ncol=2)
      edgecuts <- matrix(ass[which(!isd[ass]),], ncol=2)
      pecuts <- c(pecuts, edgecuts[,1])
      mecuts <- c(mecuts, edgecuts[,2])
      cost.dpcuts <- dpm[dpcuts]
      cost.pe <- dpe[pecuts]
      cost.me <- dme[mecuts]

      if (details) {
        cat(paste(nrow(dpcuts),"dipole connections, total cost =",sum(cost.dpcuts),"\n"))
        cat(paste(length(pecuts),"+ to edge, total cost =",sum(cost.pe),"\n"))
        cat(paste(length(mecuts),"- to edge, total cost =",sum(cost.me),"\n"))
      }

      cutlen <- sum(cost.dpcuts)+sum(cost.pe)+sum(cost.me)

      for (i in seq_along(dpcuts[,1])) {
          startp <- chp[dpcuts[i, 1],]
          endp <- chm[dpcuts[i, 2],]
          mask <- brcut(startp, endp, mask)
      }
      for (i in seq_along(pecuts)) {
          startp <- chp[pecuts[i],]
          endp <- pec[pecuts[i],]
          mask <- brcut(startp, endp, mask)
      }
      for (i in seq_along(mecuts)) {
          startp <- chm[mecuts[i],]
          endp <- mec[mecuts[i],]
          mask <- brcut(startp, endp, mask)
      }
    }
    ## if there are only plus or minus charges connect to nearest edge (should be rare case, but...)
    else if (ncp > 0) {
      ## distance from each positive charge to nearest edge
      dce <- dmat(chp, ptsb)
      ipb <- apply(dce, 1, which.min)
      dpe <- apply(dce, 1, min)+pen
      pe <- matrix(ptsb[ipb,],ncp,2)
      for (i in 1:ncp) {
          startp <- chp[i,]
          endp <- pe[i,]
          mask <- brcut(startp, endp, mask)
      }
    }
    else if (ncm > 0) {
      ## distance from each negative charge to nearest edge
      dce <- dmat(chm, ptsb)
      ipb <- apply(dce, 1, which.min)
      dme <- apply(dce, 1, min)+pen
      me <- matrix(ptsb[ipb,],ncm,2)
      for (i in 1:ncm) {
          startp <- chm[i,]
          endp <- me[i,]
          mask <- brcut(startp, endp, mask)
      }
    }

    ## call idiffpuw to unwrap all unmasked pixels
    uwum <- idiffpuw(phase, mask, ucall=FALSE, dx=dx, dy=dy)
    puw <- uwum$puw
    uw <- uwum$uw
    uw[is.na(phase)] <- NA
    ## fill in whatever was left wrapped
    ## This inverts the logic of fill algorithm in idiffpuw
    ## todo initially contains a list of pixels that haven't been unwrapped
    ## that should be. We look for neighbors that have been unwrapped
    ## and unwrap from them, removing the newly unwrapped pixels from
    ## the todo list.
    ## This should work because branch cuts are just a pixel wide and should
    ## adjoin unmasked regions. It's possible that cuts could completely
    ## enclose an area, in which case it will still be filled
    ## with most likely erroneous values as we fill through the cuts.

    todo <- which(!uw)
    kn <- c(-1, 1, -nr, nr)
    while (length(todo) > 0) {
        for (i in 1:4) {
            b <- todo + kn[i]
            subs <- which(uw[b])
            puw[todo[subs]] <- puw[b[subs]] + switch(i, dx[b[subs]], -dx[todo[subs]],
             dy[b[subs]], -dy[todo[subs]])
            uw[todo[subs]] <- TRUE
            todo <- todo[-subs]
            if (length(todo)==0) break
        }
    }
    if (details) {
        bcuts <- matrix(NA, nr, nc)
        bcuts[is.na(mask) & (!is.na(phase))] <- 1
        list(puw=puw/(2*pi), cutlen=cutlen, bcuts=bcuts,
                    dpm=dpm, dpe=dpe, dme=dme,
                    dpcuts=dpcuts, pecuts=pecuts, mecuts=mecuts,
                    cost.dpcuts=cost.dpcuts, cost.pe=cost.pe, cost.me=cost.me
        )
    } else
        puw/(2*pi)
}


# install.packages('lmtest')
# install.packages('car')
#install.packages("tseries")
#install.packages("forecast")
library(forecast)
library(tseries)
library(lmtest)
library(car)

setwd('/Users/demg/Projects/FA/Course III/ECONOMETRICS/task8')
data <- read.csv('./check.csv', sep = ";")

y <- data$GDP
x1 <- data$t
x2 <- data$d1
x3 <- data$d2
x4 <- data$d3

# Корреляционная матрица
cor(data)

# Диаграммы рассеяния
plot(y, x1, col = 'red')
plot(y, x2, col= 'blue')
plot(y, x3, col = 'green')
plot(y, x4, col = 'yellow')

########################################################################################
# Множественная модель
p_many <- lm(y~x1+x2+x3+x4)
s_many <- summary(p_many)
s_many

A_many <- sum(abs(s_many$residuals/y)) / length(y) * 100 # Апроксимация
A_many

confint(p_many, level = 0.95) # Доверительные интервалы

# Сравнение моделей
determ <- s_many$r.squared
adjust_determ <- s_many$adj.r.squared
st_error <- error_many
approx <- A_many
f_test <- s_many$fstatistic[1]

#######В) Проверьте значимость модели регрессии в целом и каждого коэффициента модели по отдельности.######
compare <- data.frame(
  Коэффициент_детерминации=determ,
  Скорректированный_коэффициент=adjust_determ,
  Стандартная_ошибка_модели=st_error,
  Ошибка_аппроксимации=approx,
  F_тест=f_test
)
print(compare)

"
Качество модели хорошее:
Модель очень качественная R^2 = 0.9628084
R^2 = 0.9628 (приближено к 1)
Se = 1051 (относительно у не очень много — качество нормальное (умеренное отношение))
F = 226.5
p-value = < 2.2e-16
Ошибка_аппроксимации < 7 - модель хорошая (5.371801)
"

#прогнозирование по модели с фиктивными переменными
pred=data.frame(c(41,42,43),c(1,0,0),c(0,1,0),c(0,0,1))
colnames(pred)=c("x1","x2","x3","x4")
predictGDP=predict(p_many, newdata = pred)
predictGDP
pred

dwtest(p_many) # Тест Дарбина-Ватсона
#  2.676e-08
bgtest(p_many, order = 1, order.by = NULL, type = c("Chisq", "F")) # Тест Бреуша-Годфри
#pv 4.028e-06 > 0.1,0.05, 0.01 =>H0 принимается, автокорреляция первого порядка отсутствует

gqtest(p_many, order.by = x1, fraction = 0) # Тест Голдфельда-Квандта для x1
#p-value = 0.1982 - больше 0.1 0.05 0.01, отсутствует проблема гетероскедастичности

bptest(p_many, studentize = TRUE) # Тест Бреуша-Пагана
#p-value = 0.546, - больше 0.1 0.05 0.01, отсутствует проблема гетероскедастичности

error_many <- sqrt(deviance(p_many)/df.residual(p_many))

#работа с временным рядом GDP
GDP <- c(data$GDP)
GDP1 <- ts(data=GDP,start=c(2009), name="GDP", frequency = 4)
GDP1
ACF <- Acf(GDP1) # выборочная автокорреляция
ACF
PACF <- Pacf(GDP1) # частная автокорреляиця
PACF
tsdisplay(GDP1)
#вывод: ряд нестационарный


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


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


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


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


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


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


Please read the source of NAGComplexExample.java for a better understanding of how to use NAGComplex

*****BASICS*****

Constructing z1 and z2;
z1 = (0.0, 0.0)
z2 = (2.0, 3.0)

Changing z1 values using NAGComplex.setRe() and NAGComplex.setIm();
z1 = (3.0, 4.0)

Copying z2 to z3 using NAGComplex.clone();
z3 = (2.0, 3.0)
Copying z1 to z4 using static method NAGComplex.clone(NAGComplex z)
z4 = (3.0, 4.0)

Array created using NAGComplex.createArray(5);
(0.0, 0.0) (0.0, 0.0) (0.0, 0.0) (0.0, 0.0) (0.0, 0.0)

The same array updated using NAGComplex[i].setRe() and NAGComplex[i].setIm();
(1.0, 9.0) (2.0, 8.0) (3.0, 7.0) (4.0, 6.0) (5.0, 5.0)

*****ARITHMETIC*****

z1 = (3.0, 4.0)
z2 = (2.0, 3.0)
z3 = (6.0, -2.0)
z4 = (4.0, -5.0)

z1 + z2 = (5.0, 7.0)
z3 + z4 = (10.0, -7.0)

z1 - z2 = (1.0, 1.0)
z3 - z4 = (2.0, 3.0)

z1 * z2 = (-6.0, 17.0)
z3 * z4 = (14.0, -38.0)

z1 / z2 = (1.3846153846153846, -0.07692307692307696)
z3 / z4 = (0.829268292682927, 0.5365853658536587)

-(z1) = (-3.0, -4.0)
-(z2) = (-2.0, -3.0)

conjugate(z1) = (3.0, -4.0)
conjugate(z2) = (2.0, -3.0)

z3 == z4? - false
z4 = (6.0, -2.0)
z3 == z4? - true
|z1| = 5.0
|z2| = 3.6055512754639896

arg(z1) = 0.9272952180016122
arg(z2) = 0.982793723247329

z5 = (-5.0, 12.0)
z6 = (-9.0, 40.0)
Sqrt(z5) = (2.0, 3.0)
Sqrt(z6) = (4.0, 5.0)


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)

  return(k.true1 - k.true2)
}

fig_label <- function(text, region="figure", pos="topleft", cex=NULL, ...) {

  region <- match.arg(region, c("figure", "plot", "device"))
  pos <- match.arg(pos, c("topleft", "top", "topright",
                          "left", "center", "right",
                          "bottomleft", "bottom", "bottomright"))

  if(region %in% c("figure", "device")) {
    ds <- dev.size("in")
    # xy coordinates of device corners in user coordinates
    x <- grconvertX(c(0, ds[1]), from="in", to="user")
    y <- grconvertY(c(0, ds[2]), from="in", to="user")

    # fragment of the device we use to plot
    if(region == "figure") {
      # account for the fragment of the device that
      # the figure is using
      fig <- par("fig")
      dx <- (x[2] - x[1])
      dy <- (y[2] - y[1])
      x <- x[1] + dx * fig[1:2]
      y <- y[1] + dy * fig[3:4]
    }
  }

  # much simpler if in plotting region
  if(region == "plot") {
    u <- par("usr")
    x <- u[1:2]
    y <- u[3:4]
  }

  sw <- strwidth(text, cex=cex) * 60/100
  sh <- strheight(text, cex=cex) * 60/100

  x1 <- switch(pos,
               topleft     =x[1] + sw,
               left        =x[1] + sw,
               bottomleft  =x[1] + sw,
               top         =(x[1] + x[2])/2,
               center      =(x[1] + x[2])/2,
               bottom      =(x[1] + x[2])/2,
               topright    =x[2] - sw,
               right       =x[2] - sw,
               bottomright =x[2] - sw)

  y1 <- switch(pos,
               topleft     =y[2] - sh,
               top         =y[2] - sh,
               topright    =y[2] - sh,
               left        =(y[1] + y[2])/2,
               center      =(y[1] + y[2])/2,
               right       =(y[1] + y[2])/2,
               bottomleft  =y[1] + sh,
               bottom      =y[1] + sh,
               bottomright =y[1] + sh)

  old.par <- par(xpd=NA)
  on.exit(par(old.par))

  text(x1, y1, text, cex=cex, ...)
  return(invisible(c(x,y)))
}


# simple example of data cloning taken from their web pages (with slight modification)

# Copyright 2017 Province of British Columbia
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and limitations under the License.

set.seed(23423423)
n <- 25
p <- .3
y <- rbinom(n=1, size=n, p=p)

library(dclone)
library(rjags)

model <- dclone::custommodel("
model {
   y ~ dbin(p, n)  # likelihood

   p ~ dunif(.001, .999)  # prior

   # compute the likelihood
   loglik <- log( pbin(y, p, n))
}
")

data.list <- list(y=y, n=n)
data.list

monitor.list <- c("p","loglik")

fit <- jags.fit(data   =data.list,
                params =monitor.list,
                model  = model)

summary(fit)
plot(fit)

#---------------------------------------------------
# Now for the data cloning

model.clone <- dclone::custommodel("
model {
  for(k in 1:K){  # cloning loop
    y[1,k]   ~ dbin(p, n)  # likelihood
    loglikc[1,k] <- log( dbin(y[1,k], p, n))
  }

  loglik <- mean(loglikc[1,1:K])  # the mean loglikelihood?
  p ~ dunif(.001, .999)  # prior
 }
")

data.list.clone <- list( y=dcdim(data.matrix(y)), n=n, K=1)
data.list.clone

monitor.list <- c("p", "loglik")

fit.clone <- dc.fit(data  =data.list.clone,
                    params=monitor.list,
                    model =model.clone,
                    n.clones=c(1,2,4,8,16),
                    unchanged="n",
                    multiply="K")

summary(fit.clone)
phat <- summary(fit.clone)$statistics["p","Mean"]
phat
# actual log likelihood
dbinom(y, n, phat, log=TRUE )

coef(fit.clone)
phat <- y/n
cat("MLE ", phat, "\n" )
dcsd(fit.clone)
cat('Theoretical SE ', sqrt(p*(1-p)/n), "\n")
cat("Empirical   SE ", sqrt(phat*(1-phat)/n), "\n")

vcov(fit.clone)
confint(fit.clone)


#### SimulationFunctions
CorrMatrixNegFixed <- function(blocks, a, corr, off) {
    Corr <- NULL
    for (i in 1:blocks) {
        Corr[[i]] <- matrix(NA, ncol = a, nrow = a)
        diag= rep(1,a)
        offdiag = corr
        Corr[[i]][lower.tri(Corr[[i]])] <- offdiag
        Corr[[i]][upper.tri(Corr[[i]])] <- t(Corr[[i]])[upper.tri(t(Corr[[i]]))]
        diag(Corr[[i]]) <- diag
        for ( k in ((ncol(Corr[[i]])/2)+1):(ncol(Corr[[i]])) ) {
            for( j in 1:(nrow(Corr[[i]])/2) ) {
                Corr[[i]][j,k] <- -1*Corr[[i]][j,k]
            }
        }

        for ( k in ((nrow(Corr[[i]])/2)+1):(nrow(Corr[[i]])) ) {
            for( j in 1:(ncol(Corr[[i]])/2) ) {
                Corr[[i]][k,j] <- -1*Corr[[i]][k,j]
            }
        }

    }
    res <- as.matrix(bdiag(Corr))
    res[which(res == 0, arr.ind = TRUE)] <- off
    return(res)
}

##################################################################################
## This function Simulates complete data sets.
## We are creating a dataset of size N (samples) by p (Metabolites)
##################################################################################

SimulatedData <- function(n, p, covar, low, high)  {
	## No of Samples == N
	## No of Metabolites = p
        Means <- runif(p, min = low, max = high)
        data <- rmvnorm(n, mean = Means, sigma = covar)
	return(data)
}

##################################################################################
###### Create MissingValues Datasets
##################################################################################

MissingData <- function(data, totalmiss, mar, perc) {
	missdata <- data

      ## First create Missing Not At Random (MNAR)
        belowthresh <- which(data < quantile(data, probs = c(totalmiss-mar)/100), arr.ind = TRUE)
        missdata[belowthresh] <- NA

	## Next create Missing At Random (MAR)
        dataVector <- c(1:length(data))
        randommiss <- sample(dataVector[-which(is.na(missdata))], (mar/100)*length(data) )
        missdata[randommiss] <- NA

	## Next exclude metabolites with more that 'perc' missing
        NumberMissing <- apply(missdata, 2, function(x) length(which(is.na(x))))

        ind  <- which(NumberMissing >= (nrow(data)*perc))
        if(length(ind) > 0 ){
            missdata <- missdata[,-ind]
            data <- data[,-ind]
        }

	return(list(missdata, data, NumberMissing))
}