###############
## Section 4 ##
###############

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

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

financedata <- read.csv("ANES_2016.csv", header=T)

###############
## Table 4.1 ##
###############

finance.ologit <- clm(as.ordered(prospective_persfin) ~ pred_favored_win+health+mortgage+gender+age, data = financedata, link="logit")
finance.ologit.results <- cbind(finance.ologit$coefficients, sqrt(diag(vcov(finance.ologit))), confint.default(finance.ologit, level=0.95))
N <- length(finance.ologit$fitted.values)
colnames(finance.ologit.results) <- c("Coeff", "(se)", "2.5%", "97.5%")
print((round(finance.ologit.results, digits=3)))
print(N)

## Note: Warning about formula can be ignored -- clm mistakenly throws an error for long formulas

###############
## Table 4.2 ##
###############

beta <- finance.ologit$coefficients
covmat.beta <- vcov(finance.ologit)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

baseline.x <- apply(finance.ologit$model[,-1], 2, median)

hypo.case.A <- baseline.x

hypo.case.B <- baseline.x
hypo.case.B["pred_favored_win"] <- 0

# multiply by -1 because the formula is tau - XB
hypo.matrix.A <- matrix(hypo.case.A, 4, 5, byrow=TRUE) * -1
hypo.matrix.tau.A <- cbind(diag(4), hypo.matrix.A)

hypo.matrix.B <- matrix(hypo.case.B, 4, 5, byrow=TRUE) * -1
hypo.matrix.tau.B <- cbind(diag(4), hypo.matrix.B)

simprob.A <- plogis(betadraw%*%t(hypo.matrix.tau.A))
simprob.A.1 <- simprob.A[,1]
simprob.A.2 <- simprob.A[,2] - simprob.A[,1]
simprob.A.3 <- simprob.A[,3] - simprob.A[,2]
simprob.A.4 <- simprob.A[,4] - simprob.A[,3]
simprob.A.5 <- 1 - simprob.A[,4]

simprob.B <- plogis(betadraw%*%t(hypo.matrix.tau.B))
simprob.B.1 <- simprob.B[,1]
simprob.B.2 <- simprob.B[,2] - simprob.B[,1]
simprob.B.3 <- simprob.B[,3] - simprob.B[,2]
simprob.B.4 <- simprob.B[,4] - simprob.B[,3]
simprob.B.5 <- 1 - simprob.B[,4]

simprob.diff.1 <- simprob.B.1 - simprob.A.1
simprob.diff.2 <- simprob.B.2 - simprob.A.2
simprob.diff.3 <- simprob.B.3 - simprob.A.3
simprob.diff.4 <- simprob.B.4 - simprob.A.4
simprob.diff.5 <- simprob.B.5 - simprob.A.5

all.results <- cbind(
simprob.A.1, simprob.B.1, simprob.diff.1,
simprob.A.2, simprob.B.2, simprob.diff.2,
simprob.A.3, simprob.B.3, simprob.diff.3,
simprob.A.4, simprob.B.4, simprob.diff.4,
simprob.A.5, simprob.B.5, simprob.diff.5)

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("Much Worse:Yes", "Much Worse:No", "Much Worse:Diff", "Somewhat Worse:Yes", "Somewhat Worse:No", "Somewhat Worse:Diff", "The Same:Yes", "The Same:No", "The Same:Diff", "Somewhat Better:Yes", "Somewhat Better:No", "Somewhat Better:Diff", "Much Better:Yes", "Much Better:No", "Much Better:Diff")
print(round(first.differences, digits=3))

################
## Figure 4.1 ##
################

beta <- finance.ologit$coefficients
covmat.beta <- vcov(finance.ologit)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

baseline.x <- apply(finance.ologit$model[,-1], 2, median)
baseline.matrix <- matrix(baseline.x, 4, 5, byrow=TRUE) * -1  # multiply by -1 because the formula is t - XB
baseline.matrix.tau <- cbind(diag(4), baseline.matrix)
colnames(baseline.matrix.tau) <- names(finance.ologit$coefficients)

colors <- c("#004D7380", "#1C82A380", "#17A1CC80", "#0ABA9E80", "#00DBA680")

age.range <- c(10:100)

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

ologit.mean.probs <- matrix(NA, 5, length(age.range))

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

	baseline.matrix.tau[,"age"] <- (age.range[i] * -1)
	oprobs <- plogis(betadraw%*%t(baseline.matrix.tau))
	ologit.probs1[,i] <- oprobs[,1]
	ologit.probs2[,i] <- oprobs[,2] - oprobs[,1]
	ologit.probs3[,i] <- oprobs[,3] - oprobs[,2]
	ologit.probs4[,i] <- oprobs[,4] - oprobs[,3]
	ologit.probs5[,i] <- 1 - oprobs[,4]

	oprobs.mean <- plogis(beta%*%t(baseline.matrix.tau))
	ologit.mean.probs[1,i] <- oprobs.mean[1]
	ologit.mean.probs[2,i] <- oprobs.mean[2] - oprobs.mean[1]
	ologit.mean.probs[3,i] <- oprobs.mean[3] - oprobs.mean[2]
	ologit.mean.probs[4,i] <- oprobs.mean[4] - oprobs.mean[3]
	ologit.mean.probs[5,i] <- 1 - oprobs.mean[4]
}

pdf("fig41.pdf")
par(mar=c(5.1, 4.1, 4.1, 5.6), mgp=c(2.5, 1, 0), cex.lab=1.5)
plot(ologit.mean.probs[1,]~age.range, xlim=c(18,90), ylim=c(0,0.6), type="n", xlab="Age", ylab="Probability", xaxt="n", las=1, lwd=2)
axis(1, at=c(18, 30, 40, 50, 60, 70, 80, 90))
for (i in 1:length(age.range)){
	points(ologit.probs1[i,] ~ age.range, type="l", col=colors[1], lwd=1)
	points(ologit.probs2[i,] ~ age.range, type="l", col=colors[2], lwd=1)
	points(ologit.probs3[i,] ~ age.range, type="l", col=colors[3], lwd=1)
	points(ologit.probs4[i,] ~ age.range, type="l", col=colors[4], lwd=1)
	points(ologit.probs5[i,] ~ age.range, type="l", col=colors[5], lwd=1)
}
lines(ologit.mean.probs[1,]~age.range, col=rgb(0,0,0,0.5), lwd=2)
lines(ologit.mean.probs[2,]~age.range, col=rgb(0,0,0,0.5), lwd=2)
lines(ologit.mean.probs[3,]~age.range, col=rgb(0,0,0,0.5), lwd=2)
lines(ologit.mean.probs[4,]~age.range, col=rgb(0,0,0,0.5), lwd=2)
lines(ologit.mean.probs[5,]~age.range, col=rgb(0,0,0,0.5), lwd=2)
mtext("Much Worse", side=4, at=ologit.mean.probs[1,82], cex=1.1, las=1, line=0.5)
mtext("Somewhat", side=4, at=ologit.mean.probs[2,82]-0.01, cex=1.1, las=1, line=0.5)
mtext("Worse", side=4, at=ologit.mean.probs[2,82]-0.03, cex=1.1, las=1, line=0.5)
mtext("The Same", side=4, at=ologit.mean.probs[3,82], cex=1.1, las=1, line=0.5)
mtext("Somewhat", side=4, at=ologit.mean.probs[4,82]+0.03, cex=1.1, las=1, line=0.5)
mtext("Better", side=4, at=ologit.mean.probs[4,82]+0.01, cex=1.1, las=1, line=0.5)
mtext("Much Better", side=4, at=ologit.mean.probs[5,82], cex=1.1, las=1, line=0.5)
dev.off()

###############
## Table 4.3 ##
###############

beta <- finance.ologit$coefficients
covmat.beta <- vcov(finance.ologit)
ndraws <- 1000
betadraw <- mvrnorm(ndraws, beta, covmat.beta)

# AME

ologit.X <- cbind(0,0,0,0, finance.ologit$model[,-1]) * -1  # multiply by -1 because the formula is t - XB
w <- financedata$sample_weight

for (i in 1:4) {

	ologit.X.temp <- ologit.X
	ologit.X.temp[,i] <- 1
	ologit.p.temp <- plogis(betadraw %*% t(ologit.X.temp))
	assign(paste("ologit.p", i, sep="."), ologit.p.temp)
	assign(paste("ologit.d", i, sep="."), ologit.p.temp * (1 - ologit.p.temp))
}

# multiply each row by draws of health coefficients
ame.1 <- diag(betadraw[,"health"]) %*% (0 - ologit.d.1)
ame.2 <- diag(betadraw[,"health"]) %*% (ologit.d.1 - ologit.d.2)
ame.3 <- diag(betadraw[,"health"]) %*% (ologit.d.2 - ologit.d.3)
ame.4 <- diag(betadraw[,"health"]) %*% (ologit.d.3 - ologit.d.4)
ame.5 <- diag(betadraw[,"health"]) %*% (ologit.d.4)

ologit.ame.1 <- apply(ame.1, 1, function(x){sum(x * w)/sum(w)})
ologit.ame.2 <- apply(ame.2, 1, function(x){sum(x * w)/sum(w)})
ologit.ame.3 <- apply(ame.3, 1, function(x){sum(x * w)/sum(w)})
ologit.ame.4 <- apply(ame.4, 1, function(x){sum(x * w)/sum(w)})
ologit.ame.5 <- apply(ame.5, 1, function(x){sum(x * w)/sum(w)})

ologit.ame <- cbind(ologit.ame.1, ologit.ame.2, ologit.ame.3, ologit.ame.4, ologit.ame.5)

ae.1 <- ame.1 * ((1/ologit.p.1) %*% diag(finance.ologit$model[,"health"]))
ae.2 <- ame.2 * ((1/(ologit.p.2 - ologit.p.1)) %*% diag(finance.ologit$model[,"health"]))
ae.3 <- ame.3 * ((1/(ologit.p.3 - ologit.p.2)) %*% diag(finance.ologit$model[,"health"]))
ae.4 <- ame.4 * ((1/(ologit.p.4 - ologit.p.3)) %*% diag(finance.ologit$model[,"health"]))
ae.5 <- ame.5 * ((1/(1 - ologit.p.4)) %*% diag(finance.ologit$model[,"health"]))

ologit.ae.1 <- apply(ae.1, 1, function(x){sum(x * w)/sum(w)})
ologit.ae.2 <- apply(ae.2, 1, function(x){sum(x * w)/sum(w)})
ologit.ae.3 <- apply(ae.3, 1, function(x){sum(x * w)/sum(w)})
ologit.ae.4 <- apply(ae.4, 1, function(x){sum(x * w)/sum(w)})
ologit.ae.5 <- apply(ae.5, 1, function(x){sum(x * w)/sum(w)})

ologit.ae <- cbind(ologit.ae.1, ologit.ae.2, ologit.ae.3, ologit.ae.4, ologit.ae.5)

quantiles.ame <- apply(ologit.ame, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sd.ame <- apply(ologit.ame, 2, sd)
summary.marginal.ame <- cbind(t(quantiles.ame), sd.ame)

quantiles.ae <- apply(ologit.ae, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sd.ae <- apply(ologit.ae, 2, sd)
summary.elasticity.ame <- cbind(t(quantiles.ae), sd.ae)

# MEM

mean.x <- apply(finance.ologit$model[,-1], 2, mean)
mean.x.matrix <- matrix(mean.x, 4, 5, byrow=TRUE) * -1
mean.x.all <- cbind(diag(4), mean.x.matrix)

mem.probs <- plogis(betadraw%*%t(mean.x.all))

mem.1 <- -1 * (mem.probs[,1] * (1 - mem.probs[,1])) * betadraw[,"health"]
mem.2 <- ((mem.probs[,1] * (1 - mem.probs[,1])) - (mem.probs[,2] * (1 - mem.probs[,2]))) * betadraw[,"health"]
mem.3 <- ((mem.probs[,2] * (1 - mem.probs[,2])) - (mem.probs[,3] * (1 - mem.probs[,3]))) * betadraw[,"health"]
mem.4 <- ((mem.probs[,3] * (1 - mem.probs[,3])) - (mem.probs[,4] * (1 - mem.probs[,4]))) * betadraw[,"health"]
mem.5 <- (mem.probs[,4] * (1 - mem.probs[,4]))  * betadraw[,"health"]

ologit.mem <- cbind(mem.1, mem.2, mem.3, mem.4, mem.5)

me.1 <- mem.1 * (mean.x["health"]/(mem.probs[,1]))
me.2 <- mem.2 * (mean.x["health"]/(mem.probs[,2] - mem.probs[,1]))
me.3 <- mem.3 * (mean.x["health"]/(mem.probs[,3] - mem.probs[,2]))
me.4 <- mem.4 * (mean.x["health"]/(mem.probs[,4] - mem.probs[,3]))
me.5 <- mem.5 * (mean.x["health"]/(1 - mem.probs[,4]))

ologit.me <- cbind(me.1, me.2, me.3, me.4, me.5)

quantiles.mem <- apply(ologit.mem, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sd.mem <- apply(ologit.mem, 2, sd)
summary.marginal.mem <- cbind(t(quantiles.mem), sd.mem)

quantiles.me <- apply(ologit.me, 2, function(x) {quantile(x, probs=c(0.5, 0.025, 0.975))})
sd.me <- apply(ologit.me, 2, sd)
summary.elasticity.mem <- cbind(t(quantiles.me), sd.me)

marginal.effects.elasticities <- rbind(summary.marginal.ame, summary.marginal.mem, summary.elasticity.ame, summary.elasticity.mem)
colnames(marginal.effects.elasticities) <- c("Median", "2.5%", "97.5%", "(se)")
category.names <- c("MW", "SW", "S", "SB", "MB")
rownames(marginal.effects.elasticities) <- c(paste("Marginal Effect (AME)", category.names, sep="."), paste("Marginal Effect (MEM)", category.names, sep="."), paste("Elasticity (AME)", category.names, sep="."), paste("Elasticity (MEM)", category.names, sep="."))
print(round(marginal.effects.elasticities, digits=3))

## coefficient ratios

mortgage.age.ratio <- betadraw[,"mortgage"]/betadraw[,"age"]
ratio.results <- quantile(mortgage.age.ratio, probs=c(0.5, 0.025, 0.975))
print(ratio.results)

###############
## Table 4.4 ##
###############

N <- length(finance.ologit$fitted.values)

beta <- finance.ologit$coefficients
covmat.beta <- vcov(finance.ologit)
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)


 DGEEVX Example Program Results

 Eigenvalues

          Eigenvalue           rcond    error
  1   7.9948E-01               0.9936    -
  2 (-9.9412E-02, 4.0079E-01)  0.7027    -
  3 (-9.9412E-02,-4.0079E-01)  0.7027    -
  4  -1.0066E-01               0.5710    -

 Eigenvectors

          Eigenvector          rcond    error

  1   6.5509E-01               0.8181    -
      5.2363E-01
     -5.3622E-01
      9.5607E-02

  2 (-1.9330E-01, 2.5463E-01)  0.3996    -
    ( 2.5186E-01,-5.2240E-01)
    ( 9.7182E-02,-3.0838E-01)
    ( 6.7595E-01, 0.0000E+00)

  3 (-1.9330E-01,-2.5463E-01)  0.3996    -
    ( 2.5186E-01, 5.2240E-01)
    ( 9.7182E-02, 3.0838E-01)
    ( 6.7595E-01,-0.0000E+00)

  4   1.2533E-01               0.3125    -
      3.3202E-01
      5.9384E-01
      7.2209E-01

 Errors below 10*machine precision are not displayed


#rows in the theatre and the scores given to the each movie corresponding to the rows
first_row <- c(6,8,7,9, 9, 10)
second_row <- c(6,8,7,5,9, 6)
third_row <- c(5,4,6,6,7, 8)
fourth_row <- c(4,5,3,4,6,8)

#Create a theatre matrix
scores <- rbind(first_row, second_row, third_row, fourth_row)
print(scores)

#Calculate the row wise scores
total_sum <- rowSums(scores)
print(total_sum)

#Merging the total sum to the existing theatre matrix
scores <- cbind(scores, total_sum)
print(scores)

#Adding Column and Row names
rownames(scores) <- c("row1","row2","row3","row4")
colnames(scores) <- c("c1","c2","c3","c4","c5","c6","total")

#Final Theatre Matrix
print(scores)


#' @title gini
#' @description gini index of patchniness from a stratified survey (Myers and Cadigan 1995)
#' @param \code{x} : within strata mean per tow
#' @param \code{y} : strata areas in trawlable units
#' @param \code{plot} : makes the Lorenz plot if set to \code{true}
#' @return estimate of gini index as well as plot if plot=T
#' @examples
#' y=c(2454,	656,	2374,	230,	1221,	619,	172,	2980,	360,	3245,	1016,	2569,	424,	390,	454)
#' x=c(0,	0,	0,	0,	0,	0.25,	1.81,	2.52,	2.6,	3.68,	7.58,	10.07,	13.33,	13.33,	24.99)
#' gini(x,y,plot=T)
#' #0.453 same as example in http://www.nefsc.noaa.gov/publications/crd/pdfs/crd9605f.pdf
#' @author  Adam Cook, \email{Adam.Cook@@dfo-mpo.gc.ca}
#' @export

gini <- function(x,y,plot=F){
			Xi <- data.frame(yh=x,Ah=y)
		    Xi$P = Xi$yh * Xi$Ah
		    Xi = Xi[order(Xi$P),]
		    Xi$cP = cumsum(Xi$P) / sum(Xi$P)
		    Xi$cA = cumsum(Xi$Ah) / sum(Xi$Ah)
		      if(plot) {
		    	with(Xi,plot(cA,cP,type='l'))
		    	abline(a=0,b=1,col='blue')
		    	}
		  gI=NA

		  if(nrow(Xi)>1)  gI = 1-(2*sum(rowMeans(embed(Xi$cP,2)) * diff(Xi$cA)))
		  if(is.finite(gI)){
		  		if(gI<0){
		  			gI = NA
		  		}
		  	}
		    return(gI)
			}


#'@title Return the change points of the trend for the given time series
#'
#'@description Change points are transition points that optionally exceed a certain magnitude and/or
#'             continue in a certain direction for a specified length of time.
#'
#'
#'@details Transition points are defined as indices at which the time series changes direction.
#'         We can think of the trend of a univariate time series as analogous to a smooth function
#'         \eqn{f(t)} defined over a given interval of real numbers, \eqn{[a,b]}.  We know that
#'         for \eqn{t in [a,b]}, \eqn{f} is increasing on \eqn{[a,b]} if \eqn{f'(t) > 0},
#'         \eqn{f} is decreasing on \eqn{[a,b]} if \eqn{f'(t) < 0} and
#'         \eqn{f} is constant on \eqn{[a,b]} if \eqn{f'(t) = 0}.
#'         Similarly, we can examine the sign of the difference of a time series at two subsequent
#'         points in time, to determine if the time series is increasing, decreasing, or constant from one
#'         point in time to the next.
#'         Additionally, if we think of the time series as moving through space, a geometric interpretation
#'         would allow us to treat the time series as a vector with a direction (increasing, decreasing, or constant)
#'         and magnitude (the percent change of the time series from one period of time to the next).  This perspective
#'         allows one to adapt what is considered a change point.  Thus, a change point can merely be a transition point,
#'         or it can be a transition point whose percent change from the previous value exceeds some threshold,
#'         or it can be a transition point that causes the time series to continue in the new direction for a
#'         specified period of time.
#'
#'
#'@usage  tsData.cp <- getTrendChangePoints(tsData, minPctChange, nPeriods)
#'
#'@param tsData A time series object.
#'@param minPctChange The optional lower bound a magnitude must exceed
#'@param nPeriods An optional number of periods the transition must continue into the future
#'
#'@return A vector of integers corresponding to indices of change points in the given time series trend
#'
#'@export

getTrendChangePoints <- function(tsData, minPctChange = NULL, nPeriods = NULL)
{
	# Search neighborhood for points that:
	# i) Transition
	# ii) Optionally greater than some threshold minPctChange
	# iii) Optionally continue in the new direction for nPeriods

	nHood <- getNeighborhoodDf(getTrend(tsData))

	# If neither magnitude of change nor the length of the new direction
    # are specified, the change points are merely the transition points

	nHood.cp <- which(nHood$IS_TP)

	# If a magnitude is specified, transition points must exceed a minimum percent change
	# to be considered a change point

	if (!is.null(minPctChange))
		nHood.cp <- which(nHood$IS_TP & nHood$PCT_CHANGE > minPctChange)

	# If nPeriods is given, each transition point must continue in the new
	# direction for nPeriods

	if (!is.null(nPeriods)) {
		cp <- integer()
		for (k in nHood.cp)
			if (length(unique(nHood$DIFF_SIGN[k:(k+nPeriods)])) == 1)
				cp[length(cp)+1] <- k
		nHood.cp <- cp
	}

	return (nHood.cp)
}


# Large-Sample Approximation
n=25
B=13
# test statstic
Bst=(B-(n/2))/(sqrt(n/4))
print(Bst)
# critical value
alpha=0.05
z.alpha=qnorm(1-alpha/2)
print(z.alpha)
print("e BST is not greater than z.alpha, we fail to reject H0")
pvalue=1-pnorm(Bst)
print(pvalue)


=begin
  # sample-elementary-divisor01.rb

  require "algebra"

  M = SquareMatrix(Rational, 4)
  a = M[
    [2, 0, 0, 0],
    [0, 2, 0, 0],
    [0, 0, 2, 0],
    [5, 0, 0, 2]
  ]
  P = Polynomial(Rational, "x")
  MP = SquareMatrix(P, 4)

  ac = a._char_matrix(MP)
  ac.display; puts #=>
  #x - 2,   0,   0,   0
  #  0, x - 2,   0,   0
  #  0,   0, x - 2,   0
  # -5,   0,   0, x - 2

  p ac.elementary_divisor #=> [1, x - 2, x - 2, x^2 - 4x + 4]

  require "algebra/matrix-algebra-triplet"
  at = ac.to_triplet.e_diagonalize

  at.body.display; puts #=>
  #  1,   0,   0,   0
  #  0, x - 2,   0,   0
  #  0,   0, x - 2,   0
  #  0,   0,   0, x^2 - 4x + 4

  at.left.display; puts #=>
  #  0,   0,   0, -1/5
  #  0,   1,   0,   0
  #  0,   0,   1,   0
  #  5,   0,   0, x - 2

  at.right.display; puts #=>
  #  1,   0,   0, 1/5x - 2/5
  #  0,   1,   0,   0
  #  0,   0,   1,   0
  #  0,   0,   0,   1

  p at.left * ac * at.right == at.body #=> true
((<_|CONTENTS>))
=end


trajanja <- faithful$eruptions
cekanja <- faithful$waiting

sredina.trajanja <- sum(trajanja)/length(trajanja)
sredina.trajanja
sredina.trajanja <- mean(trajanja)
sredina.trajanja

sredina.cekanja <- mean(cekanja)
sredina.cekanja

mediana.trajanja <- median(trajanja)
mediana.trajanja

mediana.cekanja <- median(cekanja)
mediana.cekanja

kvartili.trajanja <- quantile(trajanja)
kvartili.trajanja

kvartili.trajanja <- quantile(trajanja, c(0,0.25,0.5,0.75,1) )
kvartili.trajanja

percentili.trajanja <- quantile(trajanja,
    c(0,0.1,0.2,0.3,0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1) )
percentili.trajanja

opseg.trajanja <- range(trajanja)[2] - range(trajanja)[1]
opseg.trajanja
opseg.trajanja <- max(trajanja) - min(trajanja)
opseg.trajanja

opseg.medju.kvartilima.trajanja <- IQR(trajanja)
opseg.medju.kvartilima.trajanja

boxplot(trajanja)

disperzija.trajanja <- var(trajanja)
disperzija.trajanja

standardna.devijacija.trajanja <- sqrt(var(trajanja))
standardna.devijacija.trajanja
standardna.devijacija.trajanja <- sd(trajanja)
standardna.devijacija.trajanja

kovarijansa.cekanja.i.trajanja = cov(cekanja, trajanja)
kovarijansa.cekanja.i.trajanja

koeficiejnat.korelacije.cekanja.i.trajanja <-  cor(cekanja, trajanja)
koeficiejnat.korelacije.cekanja.i.trajanja

filter.kratko <- faithful$eruptions < 3
filter.kratko
podaci.kratko <- faithful[filter.kratko,]
podaci.kratko
cor(podaci.kratko$waiting, podaci.kratko$eruptions)


# SIMPLE IMPLEMENTATION OF HAMILTONIAN MONTE CARLO.
#
# Radford M. Neal, 2010.
#
# This program appears in Figure 2 of "MCMC using Hamiltonian dynamics",
# to appear in the Handbook of Markov Chain Monte Carlo.
#
# The arguments to the HMC function are as follows:
#
#   U          A function to evaluate minus the log of the density of the
#              distribution to be sampled, plus any constant - ie, the
#              "potential energy".
#
#   grad_U     A function to evaluate the gradient of U.
#
#   epsilon    The stepsize to use for the leapfrog steps.
#
#   L          The number of leapfrog steps to do to propose a new state.
#
#   current_q  The current state (position variables only).
#
# Momentum variables are sampled from independent standard normal
# distributions within this function.  The value return is the vector
# of new position variables (equal to current_q if the endpoint of the
# trajectory was rejected).
#
# This function was written for illustrative purposes.  More elaborate
# implementations of this basic HMC method and various variants of HMC
# are available from my web page, http://www.cs.utoronto.ca/~radford/

HMC = function (U, grad_U, epsilon, L, current_q)
{
  q = current_q
  p = rnorm(length(q),0,1)  # independent standard normal variates
  current_p = p

  # Make a half step for momentum at the beginning

  p = p - epsilon * grad_U(q) / 2

  # Alternate full steps for position and momentum

  for (i in 1:L)
  {
    # Make a full step for the position

    q = q + epsilon * p

    # Make a full step for the momentum, except at end of trajectory

    if (i!=L) p = p - epsilon * grad_U(q)
  }

  # Make a half step for momentum at the end.

  p = p - epsilon * grad_U(q) / 2

  # Negate momentum at end of trajectory to make the proposal symmetric

  p = -p

  # Evaluate potential and kinetic energies at start and end of trajectory

  current_U = U(current_q)
  current_K = sum(current_p^2) / 2
  proposed_U = U(q)
  proposed_K = sum(p^2) / 2

  # Accept or reject the state at end of trajectory, returning either
  # the position at the end of the trajectory or the initial position

  if (runif(1) < exp(current_U-proposed_U+current_K-proposed_K))
  {
    return (q)  # accept
  }
  else
  {
    return (current_q)  # reject
  }
}


#Series temporais e analises preditivas - Fernando Amaral

library(forecast)
library(ggplot2)
library(seasonal)
library(seasonalview)
library(urca)

#importar dados do hotel
dados = read.csv(file.choose(),header = F)
print(dados)

#treino/teste
ocupacaotreino = ts(dados, start = c(2003,1), end = c(2015,12), frequency=12)
ocupacaoteste  = ts(dados, start = c(2016,1), end = c(2017,12), frequency=12)

#ARIMA
modeloarima = auto.arima(ocupacaotreino,  trace = F,stepwise = F, approximation = F )
preverarima = forecast(modeloarima, h=24)

#ets
modeloets = ets(ocupacaotreino)
preverets = forecast(modeloets, h=24)

plot(preverarima)
lines(preverets$mean, col="red")

accuracy(preverarima,ocupacaoteste)
accuracy(preverets,ocupacaoteste)

plot(ocupacao)
lines(preverarima$mean, col="blue")
lines(preverets$mean, col="green")

Udemy/Series Temporais e Analises Preditivas/Resources/Codigo/11.2.Comparando Modelos.r


MSR=11128.14
MSC=544.44
t=5
MSE=2887.29
# relative efficiency of this Latin square design relative to a completely randomized design is
re=(MSR+MSC+(t-1)*MSE)/((t+1)*MSE)
re


print ("first task")

a <- c( -1, 0, 2, 3, -5, 6, 0, 5, -1, 0, 5, -6, 0, 6, -8, 9)
b <- c( 6, 1, -6, -3, -8, 7, 0, 10, -4, -6, 4, 1, -3, 0, -2, 4)
p <- c ( -4, 6, -7, 3, 0, -7, 5, 4, 3, -6, 7, 1, 0, 4, -2, 3)
fir <- ((7)*a)+(2*b)
print ("first answer")
fir
sec <- ((-2)*as.numeric(a%*%b))*p+5*(norm(p, type="2"))*a
print ("second answer")
sec
thr <- (-2)*(norm(p, type="2"))*p-7*as.numeric(a%*%b)*p+9*as.numeric(b%*%p)*a
print ("third answer")
thr

Задача 2

print ("second task")
mat <- rbind(c(0,0,0,-1,8,0,6,-1),c(0,0,0,8,4,0,-5,4),c(0,0,0,11,3,0,0,6),c(7,0,0,0,0,8,0,-2),c(4,0,0,0,0,-4,-2,-6),c(-3,0,-4,0,-2,0,0,0),c(13,-7,0,8,1,0,0,0),c(-4,0,0,9,-5,0,0,0))
rua <- c(5,-5,-14,10,-6,2,2,8)
X <- solve(mat)%*%rua
print ("Answer for the sec task")
X
mat%*%X
rua

задача 4

print ("fourth task")
A <- rbind(c(19, 0 ,0 ,0 ,0 ,0 ,0 ,20),c(0 ,7 ,0 ,0, 0, 0, 0, 0),c(0, 0, 13, 0, 0, 0, 0, 0),c(0, 0, 0, 11, 0, 0, 0, 0),c(0, 9, 0, 0, 17, 0, 0, 0),c(0, 0, 0, 0, 0, 5, 0, 0),c(0, 0, 0, 0, 0, 0, 3, 0),c(0, 0, 0, 0, 0, 0, 0, 1))
A
options(digits=3) # Задать количество значащих цифр для вывода
print ("собственные числа ")
d <- eigen(A)$values; d # Собственные значения матрицы A
print ("собственные вектора")
P <- eigen(A)$vectors; P # Собственные векторы A, стоящие в столбцах матрицы
P
print (" Проверим ортогональность полученного собственного базиса ")
sum(P[,1]^2) # Например, длина первого собственного вектора
P[,1] %*% P[,2] # Например, скалярное произведение (f1, f2)
sum(P[,2]^2); P[,2] %*% P[,3] # длина 2 собственного вектора и (f2, f3)
sum(P[,3]^2); P[,3] %*% P[,4] # длина 3 собственного вектора и (f3, f4)
sum(P[,4]^2); P[,4] %*% P[,5] # длина 4 собственного вектора и (f4, f5)
sum(P[,5]^2); P[,5] %*% P[,6] # длина 5 собственного вектора и (f5, f6)
sum(P[,6]^2); P[,6] %*% P[,7] # длина 6 собственного вектора и (f6, f7)
sum(P[,7]^2); P[,7] %*% P[,8] # длина 7 собственного вектора и (f7, f8)
sum(P[,8]^2); P[,8] %*% P[,1] # длина 8 собственного вектора и (f8, f1)
print ("Таким образом, получили что полученный базис составляют нормированные и
ортогональные между собой вектора, т.е ортонормированный базис.
Таким образом, получили что полученный базис составляют нормированные и
ортогональные между собой вектора, т.е ортонормированный базис.")

задача 6

print ("sixth task")
install.packages("lpSolveAPI") # Загружаем библиотеку
library(lpSolveAPI) # Активируем библиотеку линейного программирования
M <- make.lp(ncol= 2) # Объявляем количество неотрицательных переменных в M
name.lp(M, "Example") # Объявляем название "Example"для задачи(модели) М
colnames(M) <- c("X1", "X2") # Объявляем названия переменных в модели М
lp.control(M, sense = "max")$sense# Объявляем задачу на минимум модели М
set.objfn(M, c(10, 15)) # Задаем целевую функцию: f = 5*X1 +3*X2 для модели М
add.constraint(M, c(1,4), ">=", 4) # Задаем ограничение:
add.constraint(M, c(-3, 1), ">=", -10) # Аналогично
add.constraint(M, c(-8, 5), "<=", 29) # Аналогично
add.constraint(M, c(5, 2), "<=", 54) # Аналогично
rownames(M) <- c("A", "B", "C", "D") # Называем ограничения в модели М
M
solve.lpExtPtr(M)
get.variables(M) # Оптимальный план
get.objective(M)
X1.opt<- get.variables(M)[1]; X1.opt # Оптимальное значение для X1
X2.opt<- get.variables(M)[2]; X2.opt # Оптимальное значение для X2
f.max<- get.objective(M); f.max


deg <- function(radians) 180*radians/pi
rad <- function(degrees) degrees*pi/180
sind <- function(ang) sin(rad(ang))
cosd <- function(ang) cos(rad(ang))
tand <- function(ang) tan(rad(ang))
asind <- function(v) deg(asin(v))
acosd <- function(v) deg(acos(v))
atand <- function(v) deg(atan(v))

r <- pi/3
rd <- deg(r)

print( c( sin(r), sind(rd)) )
print( c( cos(r), cosd(rd)) )
print( c( tan(r), tand(rd)) )

S <- sin(pi/4)
C <- cos(pi/3)
T <- tan(pi/4)

print( c( asin(S), asind(S) ) )
print( c( acos(C), acosd(C) ) )
print( c( atan(T), atand(T) ) )


# Get data
digits.train <- read.table(url("http://www.amlbook.com/data/zip/features.train"))
digits.test <- read.table(url("http://www.amlbook.com/data/zip/features.test"))

colnames(digits.train) <- c("digit", "symmetry", "intensity")
colnames(digits.test) <- c("digit", "symmetry", "intensity")

digits.train$digit <- factor(digits.train$digit)
digits.test$digit <- factor(digits.test$digit)

# Visualize
ggplot(digits.train, aes(x = symmetry, y = intensity, color = digit)) +
  geom_point()

summary(digits.train)
summary(digits.train$digit)

q2_4 <- t(sapply(0:9, function(myDigit) {
  fit <- svm(digit == myDigit ~ ., data = digits.train,
             scale = FALSE,
             kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = 0.01,
             type = "C-classification")

  # fit
  pred <- predict(fit, digits.train[-1])

  Ein = sum(pred != (digits.train$digit == myDigit))/nrow(digits.train)
  table(pred, (digits.train$digit == myDigit))
  cbind(myDigit, Ein, fit$tot.nSV)
}))

digits.train.sub <- subset(digits.train, digit == 1 | digit == 5)
digits.test.sub <- subset(digits.test, digit == 1 | digit == 5)

q5 <- t(sapply(c(0.0001, 0.001, 0.01, 0.1, 1), function(cst) {
  myDigit = 5
  fit <- svm(digit == myDigit ~ ., data = digits.train.sub,
             scale = FALSE,
             kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = cst,
             type = "C-classification")
  pred <- predict(fit, digits.train.sub[-1])

  Ein = sum(pred != (digits.train.sub$digit == myDigit))/nrow(digits.train.sub)

  pred <- predict(fit, digits.test.sub[-1])
  Eout = sum(pred != (digits.test.sub$digit == myDigit))/nrow(digits.test.sub)

  cbind(cst, Ein, Eout, fit$tot.nSV)
}))

# q6, run q5 with degree = 5

myDigit = 5
q7 <- tune(svm,digit == myDigit ~ ., data = digits.train.sub,
           scale = FALSE,      type = "C-classification",
           kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1,
           ranges = list(cost = c(.0001, .001, .01, .1, 1)),
           tunecontrol = tune.control(sampling = "cross", cross = 10, nrepeat = 100))

q7

# Another way
rslts <- lapply(1:100, function(x) {
  ordIdx <- sample(nrow(digits.train.sub))
  fit.0001 <- svm(digit == myDigit ~ ., data = digits.train.sub[ordIdx, ],
                  scale = FALSE, seed = x,
                  kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = 0.0001,
                  type = "C-classification", cross = 10)

  fit.001 <- svm(digit == myDigit ~ ., data = digits.train.sub[ordIdx, ],
                 scale = FALSE, seed = x,
                 kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = 0.001,
                 type = "C-classification", cross = 10)

  fit.01 <- svm(digit == myDigit ~ ., data = digits.train.sub[ordIdx, ],
                scale = FALSE, seed = x,
                kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = 0.01,
                type = "C-classification", cross = 10)

  fit.1 <- svm(digit == myDigit ~ ., data = digits.train.sub[ordIdx, ],
               scale = FALSE, seed = x,
               kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = 0.1,
               type = "C-classification", cross = 10)

  fit1 <- svm(digit == myDigit ~ ., data = digits.train.sub[ordIdx, ],
              scale = FALSE, seed = x,
              kernel = "polynomial", degree = 2, gamma = 1, coef0 = 1, cost = 1,
              type = "C-classification", cross = 10)

  1 - cbind(fit.0001$tot.accuracy, fit.001$tot.accuracy, fit.01$tot.accuracy, fit.1$tot.accuracy, fit1$tot.accuracy)/100
})

summary(sapply(rslts, function(x) which(x == min(x))[1]))
summary(sapply(rslts, function(x) x[2]))

myDigit = 5
q9_10 <- t(sapply(c(1e-2, 1, 1e2, 1e4, 1e6), function(cst) {
  fit <- svm(digit == myDigit ~ ., data = digits.train.sub,
             scale = FALSE,
             kernel = "radial", gamma = 1, cost = cst,
             type = "C-classification")
  pred <- predict(fit, digits.train.sub[-1])

  Ein = sum(pred != (digits.train.sub$digit == myDigit))/nrow(digits.train.sub)

  pred <- predict(fit, digits.test.sub[-1])
  Eout = sum(pred != (digits.test.sub$digit == myDigit))/nrow(digits.test.sub)

  cbind(cst, Ein, Eout, fit$tot.nSV)
}))

q9_10


df = NULL

# Fixed parameters
s <- .2
gl <- .01
delta <- .05
alpha <- .3
lambda <- .9
phi <- -.2
theta <- .01
gR <- .01

# Initialize dynamic process
kycurr <- s/(gl+delta+.02) # start near a BGP
kyalt <- s/(gl+delta+.02) # start near a BGP
Rcurr <- 10 # start everyone with same R stock
Acurr <- 2
Aalt  <- 20

df = NULL # initialize a dataframe
dfalt = NULL # initialize a dataframe
name = "A"
namealt = "B"

for (t in 1:250) # do for this many periods
{
  gA <- theta*(Rcurr^lambda)/(Acurr^(1-phi)) # calculate growth in k/y given current k/y
  gky <- (1-alpha)*(s/kycurr - delta - gA - gl)
  df = rbind(df, data.frame(t,Acurr,gA,gky,kycurr,name)) # add to dataframe
  kycurr <- (1+gky)*(kycurr)
  Acurr <- (1+gA)*(Acurr) # update current k/y for next period
  gA <- theta*(Rcurr^lambda)/(Aalt^(1-phi))
  gky <- (1-alpha)*(s/kyalt - delta - gA - gl)
  dfalt = rbind(dfalt, data.frame(t,Aalt,gA,gky,kyalt,namealt)) # add to dataframe
  kyalt <- (1+gky)*(kyalt)
  Aalt <- (1+gA)*(Aalt)
  Rcurr <- (1+gR)*Rcurr
}

colnames(dfalt) <- c("t","Acurr","gA","gky","kycurr","name")
dfgraph = rbind(df,dfalt)

dfgraph$lny <- (alpha/(1-alpha))*log(dfgraph$ky) + 4 + log(dfgraph$Acurr)
dfgraph$gy <- (alpha/(1-alpha))*dfgraph$gky + dfgraph$gA

df <-dfgraph[order(dfgraph$name, dfgraph$t),]

fig <- plot_ly(df,
               x = ~t,
               y = ~lny,
               color = ~name,
               hoverinfo = "text",
               type = 'scatter',
               mode = 'lines'
)

fig <- fig %>% animation_slider(
  hide = T
)
fig <- fig %>% animation_button(
  x = 1, xanchor = "right", y = 0.4, yanchor = "bottom"
)
fig <- layout(fig, title = list(text = 'Level of GDP per capita over time', x=0),
              xaxis = list(title = 'Time', range=c(0,30),dtick=5),
              yaxis = list (title = 'Log GDP per capita'
              )
)

#api_create(fig, filename = "me-lny-prodanimated")


minCanopyTemperature = minTair + cropHeatFlux / ((rhoDensityAir * specificHeatCapacityAir * conductance / lambdaV) * 1000)
maxCanopyTemperature = maxTair + cropHeatFlux / ((rhoDensityAir * specificHeatCapacityAir * conductance / lambdaV) * 1000)


# Euler1 in R

mySum <- function (n, size) {
    n * (ceiling(size/n)**2 + ceiling(size/n)) / 2
}

euler1 <- function (size) {
    return (mySum(3,size) + mySum(5,size) - mySum(15,size))
}

euler1(999)


# Algorithms_potts
# Extend algorithms to work on pott sampler.

# library(extraDistr)  # CHECK -- do we need this?
source("tools.r")

# Simulate states from the Potts model, using auxiliary Gaussian variables.
#
# A: adjacency matrix
# beta: inverse-temperatures
# init: intial state for the chain
# n_states: number of states each particle can adopt.
# n_iter: number of sampling iteration.
# B (not implemented): external magnetic field.
# alpha_modif: modification along diagonal of A to make it semi-positive def.
# retain_alpha: whether to use alpha_modif or instead use min eigenvalue.
# pertub (not implemented): if TRUE, adds flip transition.
#
# return: matrix with samples.
ag_potts_simple <- function (A, beta, init, n_states = 2, n_iter = 1000, B = 0,
                             alpha_modif = 1e-7, retain_alpha = FALSE,
                             perturb = FALSE) {
  if (B != 0) print("WARNING: non-zero magnetic field is not supported.")
  if (perturb) print("WARNING: pertub = TRUE is not supported.")

  if (retain_alpha) {
    alpha = alpha_modif
  } else {
    alpha = abs(min(eigen(A, symmetric = TRUE, only.values = TRUE)$values))
    alpha = alpha + alpha_modif
  }

  n_particles = nrow(A)
  C = 2 * beta * (A + alpha * diag(n_particles))
  L = t(chol(solve(C)))
  X = matrix(NA, nrow = n_iter, ncol = n_particles)
  x = init
  X[1, ] = x

  # Auxiliary Gaussians
  Q = matrix(NA, nrow = n_particles, ncol = n_states)

  for (i in 2:n_iter) {
    for (l in 1:n_states) {
      mu_q = rep(0, n_particles)
      mu_q[X[i - 1, ] == l] = 1
      Q[, l] = mvrnorm_cholesky(n = 1, mu = mu_q, L = L)
    }

    P = C %*% Q

    u = runif(n_particles, 0, 1)

    for (j in 1:n_particles) {
      p = rep(NA, n_states)
      for (l in 1:n_states) {
        p[l] = exp(P[j, l])
      }
      norm_const = sum(p)

      state = 1
      p_current = p[state] / norm_const
      while (u[j] > p_current) {
        state = state + 1
        p_current = p_current + p[state] / norm_const
      }

      X[i, j] = state
    }
  }
  X
}

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

# Simulate states from the Potts model, using auxiliary Gaussian variables,
# and a low rank approximation. Takes in the modified adjacency matrix,
# C_tilde. See the wrapper below, which takes in A and beta.
#
#
# C_tilde: modified adjacency matrix, which is low rank, semi+ def,
#          and scaled by the inverse-temperature beta.
# init: intial state for the chain
# n_states: number of states each particle can adopt.
# n_iter: number of sampling iteration.
# epsilon: value below which an eigenvalue is considered to be 0.
# eigenvalue_rounding: determines how different two eigen values need to
#                      be in order to be considered non-identical.
#                      Required to handle numerical precision of LAPACK.
#
# return: matrix with samples.
ag_potts_lowrank__ <- function (C, init, n_states = 2, n_iter = 1000,
                                epsilon = 1e-12, eigenvalue_rounding = 1e12) {
  n_particles = nrow(C)
  spectral_decomposition = eigen(C, symmetric = TRUE)

  n_rank = length(
    spectral_decomposition$values[spectral_decomposition$values > epsilon])
  eigen_values_sqrt = sqrt(spectral_decomposition$values[1:n_rank])

  scaled_eigenvectors <- matrix(NA, nrow = n_particles, ncol = n_rank)
  for (i in 1:n_rank) {
    scaled_eigenvectors[, i] = spectral_decomposition$values[i] *
      spectral_decomposition$vectors[, i]
  }

  X = matrix(NA, nrow = n_iter, ncol = n_particles)
  x = init
  X[1, ] = x

  # Auxiliary Gaussians
  Q = matrix(NA, nrow = n_rank, ncol = n_states)

  for (i in 2:n_iter) {
    for (l in 1:n_states) {
      Y = rep(0, n_particles)
      Y[X[i - 1, ] == l] = 1
      mu_q = t(spectral_decomposition$vector[, 1:n_rank]) %*% Y

      # set.seed(1954)
      standard_normal = rnorm(n_rank)
      Q[, l] = standard_normal / eigen_values_sqrt + mu_q
    }

    P = scaled_eigenvectors %*% Q

    u = runif(n_particles, 0, 1)

    for (j in 1:n_particles) {
      p = exp(P[j, ])
      norm_const = sum(p)

      state = 1
      p_current = p[state] / norm_const
      while (u[j] > p_current) {
        state = state + 1
        p_current = p_current + p[state] / norm_const
      }

      X[i, j] = state
    }
  }
  X
}

# Wrapper around the above function, which takes A and beta.
ag_potts_lowrank <- function(A, beta, init, n_states = 2, n_iter = 1000,
                             alpha_modif = 1e-7, epsilon = 1e-12) {
  n_particles = nrow(A)
  # spectral_decomposition = eigen(2 * beta * A, symmetric = TRUE)
  # n_rank = length(
  #   spectral_decomposition$values[abs(spectral_decomposition$values) > epsilon])
  #
  # A_tilde = matrix(0, nrow = n_particles, ncol = n_particles)
  # for (i in 1:n_rank) {
  #   A_tilde = A_tilde +
  #     spectral_decomposition$values[i] * spectral_decomposition$vectors[, i] %*%
  #       t(spectral_decomposition$vectors[, i])
  # }
  #
  # alpha <- abs(min(eigen(A_tilde, symmetric = TRUE, only.values = TRUE)$values))
  # C_tilde <- A_tilde + alpha * diag(n_particles)

  alpha = abs(min(eigen(A, symmetric = TRUE, only.values = TRUE)$values))
  alpha = alpha + alpha_modif
  C = 2 * beta * (A + alpha * diag(n_particles))

  ag_potts_lowrank__(C, init, n_states, n_iter, epsilon)
}

## Test code

# x <- init_potts
# H = 0
# for (i in 1:n_part) {
#   for (j in 1:n_part) {
#     H = H + (x[i] == x[j]) * C[i, j]
#   }
# }

# 1) Reduce rank
# n_particles <- 16
# A <- adjacency_graph(n_particles, "complete")
# eigen_output <- eigen(A, symmetric = TRUE)
# epsilon <- 1e-12
# eigenvalue_rounding <- 1e12
# n_rank = length(round(
#   eigen_output$values[abs(eigen_output$values) > epsilon] *
#     eigenvalue_rounding) / eigenvalue_rounding)
#
# # Nake sure we have eigenvalues and eigenvectors
# # index <- 4
# # t(A %*% eigen_output$vectors[, index])
# # t(eigen_output$values[index] * eigen_output$vectors[, index])
#
# A_tilde = matrix(0, nrow = n_particles, ncol = n_particles)
# for (i in 1:n_rank) {
#   A_tilde = A_tilde +
#     eigen_output$values[i] * eigen_output$vectors[, i] %*% t(eigen_output$vectors[, i])
# }
# # QUESTION: why does A_tilde not recover A??
#
# alpha <- abs(min(eigen(A_tilde, symmetric = TRUE, only.values = TRUE)$values))
# C_tilde <- A_tilde + alpha * diag(n_particles)
# init <- sample(1:n_states, n_particles, replace = T)
# n_states = 4

# B_tilde <- eigen_output$values + eigen_output$vectors[, 1] %*% t(eigen_output$vectors[, 1])
# eigen_output$values[3] * eigen_output$vectors[, 3]
# A %*% eigen_output$vectors[, 3]

  # # NOTE: The Auxiliary variable I introduce is an overcomplication.
  # # The ag_potts_simple for a simpler version.
  # # DEPRECATE.
  # ag_potts <- function (A, beta, init, n_states = 2, n_iter = 1000, B = 0,
  #                       alpha_modif = 1e-7, retain_alpha = FALSE,
  #                       perturb = FALSE) {
  #   print("WARNING: We recommend using ag_potts_simple.")
  #   if (retain_alpha) {
  #     alpha = alpha_modif
  #   } else {
  #     # CHECK ME!
  #     alpha = abs(min(eigen(A, symmetric = TRUE, only.values = TRUE)$values))
  #     alpha = alpha + alpha_modif
  #   }
  #
  #   n_particles = nrow(A)
  #   C = beta * (A + alpha * diag(n_particles))
  #   L = 2 * t(chol(solve(C)))
  #   X = matrix(NA, nrow = n_iter, ncol = n_particles)
  #   x = init
  #   X[1, ] = x
  #
  #   # Auxiliary Gaussians
  #   Q = matrix(NA, nrow = n_particles, ncol = n_states)
  #
  #   for (i in 2:n_iter) {
  #     for (l in 1:n_states) {
  #       mu_q = rep(-1, n_particles)
  #       mu_q[X[i - 1, ] == l] = 1
  #       Q[, l] = mvrnorm_cholesky(n = 1, mu = mu_q, L = L)
  #     }
  #
  #     P = C %*% Q
  #     P_row_sum_term = 0.25 * rowSums(P)
  #     P_half = 0.5 * P
  #
  #     u = runif(n_particles, 0, 1)
  #
  #     for (j in 1:n_particles) {
  #       p = rep(NA, n_states)
  #       for (l in 1:n_states) {
  #         p[l] = exp(P_half[j, l] - P_row_sum_term[j])
  #       }
  #       norm_const = sum(p)
  #
  #       state = 1
  #       p_current = p[state] / norm_const
  #       while (u[j] > p_current) {
  #         state = state + 1
  #         p_current = p_current + p[state] / norm_const
  #       }
  #
  #       X[i, j] = state
  #     }
  #   }
  #   X
  # }


# MIT License
# Copyright (c) 2020 Abhinav Prakash, Vijay Panchang, Yu Ding, and Lewis Ntaimo

# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:

# The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.

# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

############## FUNCTION DEFINITIONS #################################

#function to calculate the log-likelihood for nonstationary GEV model with trend in location parameter
GEV.likelihood = function(mu,muslope,sigma,epsilon,data,time_index){
  t = (1+epsilon*((data-mu-(muslope*time_index))/sigma))^(-1/epsilon)
  pdf = (t^(epsilon+1))*exp(-t)/sigma
  log.likelihood = sum(log(pdf))
  return(log.likelihood)
}

#function to create time index for any baseyear
time.index = function(Year,ReferenceYear){
  t = Year - ReferenceYear
  return(t)
}
#function to calculate nonstationary return period for event z
calc.nstat.ret.period = function(mu_0,mu_1,scale,shape,z,baseyear,analysisyear){
  i = 0
  accept_prob = 1
  prod_accept_prob = 1
  t = 1
  while (accept_prob > 0){
    accept_prob = exp(-((1 + (shape*((z-(mu_0+mu_1*(analysisyear-baseyear)+(mu_1*i)))/scale)))^(-1/shape)))
    prod_accept_prob = prod_accept_prob*accept_prob
    t = t + prod_accept_prob
    i = i+1
  }
  return(t)
}

#function to calculate nonstationary "n" year return event (n>=2)
calc.nstat.ret.event = function(mu_0,mu_1,scale,shape,n,baseyear,analysisyear,epsilon){
  stat_params.default = 1
  if (mu_1<=0){
    z = mu_0  - scale*(1-(-log(1 - (1/n)))^(-shape))/shape
    return(z)
  } else {
    #calculate lower bound of n year event
    lb = mu_0  - scale*(1-(-log(1 - (1/n)))^(-shape))/shape
    t_lb = n
    while (t_lb > n-epsilon){
      t_lb = calc.nstat.ret.period(mu_0,mu_1,scale,shape,lb,baseyear,analysisyear)
      if(t_lb>n-epsilon){lb = 0.9*lb}
    }
    #calculate upper bound of n year event
    ub = mu_0 + mu_1*(analysisyear-baseyear) +mu_1*n - scale*(1-(-log(1 - (1/(n))))^(-shape))/shape
    t_ub = n
    while (t_ub < n+epsilon){
      t_ub = calc.nstat.ret.period(mu_0,mu_1,scale,shape,ub,baseyear,analysisyear)
      if(t_ub<n+epsilon){ub = 1.5*ub}
    }
    #get n year event iteratively with epsilon level of accuracy.
    t = 0
    while (abs(t - n) > epsilon) {
      z = (lb+ub)/2
      t = calc.nstat.ret.period(mu_0,mu_1,scale,shape,z,baseyear,analysisyear)
      if (t < n) {
        lb = z
      } else {ub = z}
    }
  return(z)
  }

}

#function to plot return event with respect to return period
ret.event.plot.data = function(baseyear_par_data, min_ret_index, max_ret_index,mle_year_index, avg_year_index, analysisyear){
  t = seq(5,100,5)
  epsilon_seq = 0.01*t
  min = NULL
  max = NULL
  mle = NULL
  avg = NULL
  for (i in 1:length(t)){
    min[i] =  calc.nstat.ret.event(baseyear_par_data$location_intercept[min_ret_index],baseyear_par_data$location_slope[min_ret_index],baseyear_par_data$scale[min_ret_index],baseyear_par_data$shape[min_ret_index],t[i],baseyear_par_data$year[min_ret_index],analysisyear,epsilon_seq[i])
    max[i] = calc.nstat.ret.event(baseyear_par_data$location_intercept[max_ret_index],baseyear_par_data$location_slope[max_ret_index],baseyear_par_data$scale[max_ret_index],baseyear_par_data$shape[max_ret_index],t[i],baseyear_par_data$year[max_ret_index],analysisyear,epsilon_seq[i])
    mle[i] = calc.nstat.ret.event(baseyear_par_data$location_intercept[mle_year_index],baseyear_par_data$location_slope[mle_year_index],baseyear_par_data$scale[mle_year_index],baseyear_par_data$shape[mle_year_index],t[i],baseyear_par_data$year[mle_year_index],analysisyear,epsilon_seq[i])
    avg[i] =  calc.nstat.ret.event(baseyear_par_data$location_intercept[avg_year_index],baseyear_par_data$location_slope[avg_year_index],baseyear_par_data$scale[avg_year_index],baseyear_par_data$shape[avg_year_index],t[i],baseyear_par_data$year[avg_year_index],analysisyear,epsilon_seq[i])
  }
  y_data = data.frame(t,min,max,mle,avg)
  write.table(y_data, file = paste0(output_file,"_reteventplot_data.csv"), row.names=FALSE, na="", col.names=c("year","min","max","mle","avg"), sep=",")
  return(y_data)
}
#function to plot return event trend with respect to analysis year for a given return period
ret.event.trend = function(baseyear_par_data,min_ret_index, max_ret_index,mle_year_index, avg_year_index, return_period,first_analysis_year,last_analysis_year,interval){
  epsilon = 0.01*return_period
  analysisyear = seq(first_analysis_year,last_analysis_year,interval)
  min = NULL
  max = NULL
  mle = NULL
  avg = NULL
  for (i in 1:length(analysisyear)){
    min[i] =  calc.nstat.ret.event(baseyear_par_data$location_intercept[min_ret_index],baseyear_par_data$location_slope[min_ret_index],baseyear_par_data$scale[min_ret_index],baseyear_par_data$shape[min_ret_index],return_period,baseyear_par_data$year[min_ret_index],analysisyear[i],epsilon)
    max[i] =  calc.nstat.ret.event(baseyear_par_data$location_intercept[max_ret_index],baseyear_par_data$location_slope[max_ret_index],baseyear_par_data$scale[max_ret_index],baseyear_par_data$shape[max_ret_index],return_period,baseyear_par_data$year[max_ret_index],analysisyear[i],epsilon)
    mle[i] =  calc.nstat.ret.event(baseyear_par_data$location_intercept[mle_year_index],baseyear_par_data$location_slope[mle_year_index],baseyear_par_data$scale[mle_year_index],baseyear_par_data$shape[mle_year_index],return_period,baseyear_par_data$year[mle_year_index],analysisyear[i],epsilon)
    avg[i] =  calc.nstat.ret.event(baseyear_par_data$location_intercept[avg_year_index],baseyear_par_data$location_slope[avg_year_index],baseyear_par_data$scale[avg_year_index],baseyear_par_data$shape[avg_year_index],return_period,baseyear_par_data$year[avg_year_index],analysisyear[i],epsilon)
  }
  ret_trend_data = data.frame(analysisyear,min,max,mle,avg)
  write.table(ret_trend_data, file = paste0(output_file,"_retevent_trend_data.csv"), row.names=FALSE, na="", col.names=c("analysisyear","min","max","mle","avg"), sep=",")
  return(ret_trend_data)
}

#function to calculate likelihood value
likelihood.val = function(data,time_index,mu0,mu1,scale,shape){
  k =(1 + (shape*(data-(mu0+(mu1*time_index)))/scale))^(-1/shape)
  pdf = (1/scale)*((k)^(shape+1))*exp(-k)
  llf = -sum(log(pdf))
  return(llf)
}

#function to calculate stationary return event
calc.stat.ret.event = function(mu, scale, shape, n){
  z = mu  - scale*(1-(-log(1 - (1/n)))^(-shape))/shape
  return(z)
}

#function to do MCMC sampling
draw.MCMC.samples = function(Data,time_index,InitialValues,LocationInterceptPrior,LocationSlopePrior,ScalePrior,ShapePrior,ProposalWidth,n_samples){
  mu_lb = LocationInterceptPrior[1]
  mu_ub = LocationInterceptPrior[2]
  muslope_lb = LocationSlopePrior[1]
  muslope_ub = LocationSlopePrior[2]
  scale_lb = ScalePrior[1]
  scale_ub = ScalePrior[2]
  shape_lb = ShapePrior[1]
  shape_ub = ShapePrior[2]
  mu = InitialValues[1]
  muslope = InitialValues[2]
  scale = InitialValues[3]
  shape = InitialValues[4]
  mu_proposal_width = ProposalWidth[1]
  muslope_proposal_width = ProposalWidth[2]
  scale_proposal_width = ProposalWidth[3]
  shape_proposal_width = ProposalWidth[4]
  mu_post=NULL
  muslope_post=NULL
  scale_post=NULL
  shape_post=NULL
  rng_seed = 1
  sample = 0
  rng = 0
  set.seed(rng_seed)

  #start the algorithm; (NOTE: if likelihood not finite for initial values of parameters, select different values).

  if(is.finite(GEV.likelihood(mu,muslope,scale,shape,Data,time_index))==FALSE){
    while (is.finite(GEV.likelihood(mu,muslope,scale,shape,Data,time_index))==FALSE){
      mu = runif(1,mu_lb,mu_ub)
      muslope = runif(1,muslope_lb,muslope_ub)
      scale = runif(1,scale_lb,scale_ub)
      shape = runif(1,shape_lb,shape_ub)
      rng = rng+1
    }
  }

  while (sample < n_samples){

    #start sampling proposals from jump distribution
    mu_proposed = rnorm(1,mu,mu_proposal_width)
    muslope_proposed = rnorm(1,muslope,muslope_proposal_width)
    scale_proposed = rnorm(1,scale,scale_proposal_width)
    shape_proposed = rnorm(1,shape,shape_proposal_width)
    #counter for random number generated
    rng = rng+1

    #check if all the values are finite for acceptance ratio calculation

    suppressWarnings(if (is.finite(GEV.likelihood(mu_proposed,muslope_proposed,scale_proposed,shape_proposed,Data,time_index))==TRUE & is.finite(dunif(mu_proposed,mu_lb,mu_ub,log = TRUE)) == TRUE & is.finite(dunif(scale_proposed,scale_lb,scale_ub,log = TRUE)) == TRUE & is.finite(dunif(shape_proposed,shape_lb,shape_ub,log = TRUE)) == TRUE & is.finite(dunif(muslope_proposed,muslope_lb,muslope_ub,log = TRUE))==TRUE) {

      log.r = GEV.likelihood(mu_proposed,muslope_proposed,scale_proposed,shape_proposed,Data,time_index) + dunif(mu_proposed,mu_lb,mu_ub,log = TRUE) + dunif(muslope_proposed,muslope_lb,muslope_ub,log = TRUE) + dunif(scale_proposed,scale_lb,scale_ub,log = TRUE) + dunif(shape_proposed,shape_lb,shape_ub,log = TRUE) - GEV.likelihood(mu,muslope,scale,shape,Data,time_index) - dunif(mu,mu_lb,mu_ub,log = TRUE) - dunif(scale,scale_lb,scale_ub,log = TRUE) - dunif(shape,shape_lb,shape_ub,log = TRUE) - dunif(muslope,muslope_lb,muslope_ub,log = TRUE)

      #collect new sample if criteria satisfied
      if (log.r > log(runif(1,0,1))){
        mu = mu_proposed
        muslope = muslope_proposed
        scale = scale_proposed
        shape = shape_proposed

      }
    })
    mu_post = c(mu_post,mu)
    scale_post = c(scale_post,scale)
    shape_post = c(shape_post,shape)
    muslope_post = c(muslope_post,muslope)
    sample = sample + 1
  }
  parameters = data.frame(mu_post,muslope_post,scale_post,shape_post)
  return(parameters)
}


# Imitating the amount of expenses in following:
# A person, older than 65 y.o., buys some medicine during 1 year.
# The number of purchases ~ Po(25), purchase's amount of money ~ U(5,95)

# calculating total costs for each year by the number of purchases
CostCalculate <- function(num)
{
  return(sum(runif(num, 5, 95)))
}

DrawPlot <- function(title, x = Timeline, y)
{
  ggplot(data = NULL, aes(x, y)) + geom_path() + ggtitle(title) + xlab(substitute(x)) + ylab(substitute(y))
}

library(ggplot2)

# number of years to imitate independently
Y <- 1000
Timeline <- seq(from = 1, to = Y, by = 1)

# imitating Y years for one person:
# number of purchases
PurchaseNum <- rpois(Y,25)
Expenses <- sapply(PurchaseNum, CostCalculate)

DrawPlot(y = PurchaseNum, title = "Purchase Number")
DrawPlot(y = Expenses, title = "Expenses")

AvgCost <- mean(Expenses)
print("Average expenses cost is:")
print(AvgCost)

# P{costs per year >= 2000} - ?
p <- length(Expenses[Expenses >= 2000])/length(Expenses)
print("P{costs per year >= 2000} is:")
print(p)


#' Quantile Sheets with pya's constraint
#'
#' Estimate conditional quantile sheet Schlossmacher's
#'  Alternating b/w weighted regression and recomputing weights
#' @param x vector or matrix whose rows contains predictors
#'          of each observations.
#' @param y vector of the variable we want to estimate its condtional cdf
#' @param arg_bs  argument for b-spline
#' @param dims knots number
#' @param ords  order of splien
#' @param opt   optimization methods
#' @param maxit maximum iteration for Schlossmacherl's method
#' @param ntaus number of taus to be considered
#' @param analysis  indicator whther plot analysis
#' @param trace
#' @param sp    smoothing coefficients
#' @param tol   tolerance for Schlossmacher's
#' @param ...   additional arguement pass into scam (eg. gamma, weights)
#'
#' @import scam
#'
#' @return a scam object
#'

qs_scam <- function(x, y, maxit = 10, ntaus = 10,
                    arg_bs = c("tesmi1", "ps"),
                    opt = "bfgs", dims = c(5, 15), ords = NA,
                    analysis = F, trace = F, sp = NULL, tol = 5e-2,
                    bnd = 1e-5, ...) {
    if (is.vector(x)) {
        s_k <- 1
    } else if (is.matrix(x)) {
        s_k <- ncol(x)
    } else {
        stop("input x type not support")
    }

    # initialization
    fit <- cq.reg(x, y, arg_bs, opt, dims, ords, sp = sp, ...)
    v_coef <- coef(fit)
    # fit <- f_descent(y, x, dims - ords, ords, maxit = 0)
    # v_coef <- fit$beta

    # repeat Y ntaus times
    ystar <- rep(y, ntaus)

    # data
    v_taus <- seq(bnd, 1 - bnd, length.out = ntaus)
    v_wog <- v_taus[cut(seq_along(ystar), breaks = ntaus, labels = FALSE)]
    xnam <- c("tau", paste0("x", seq_len(s_k)))
    newx <- cbind(v_wog, rep(x, ntaus))
    dat <- data.frame(ystar, newx)
    colnames(dat) <- c("y", xnam)

    # get info
    v_pred <- predict(fit, dat)
    # v_pred <- c(cq_prediction(v_taus, fit))
    v_resid <- ystar - v_pred

    # Schlossmacher's method
    for (iter in seq(maxit)) {
        # weights
        v_idx <- ystar <= v_pred
        v_weight <- v_wog
        v_weight[v_idx] <- 1 - v_weight[v_idx]
        v_weight <- v_weight / sqrt(v_resid^2 + 1e-8 * max(abs(v_resid))^2)
        v_weight <- v_weight / mean(v_weight)
        # fit the model
        fit <- scam(y ~ s(tau, x1, k = dims, m = ords, bs = arg_bs),
            data = dat, optimizer = opt, sp = c(sp), weights = c(v_weight),
            start = v_coef, ...
        )

        # get info
        v_pred <- fit$fitted.values
        v_resid <- fit$residual
        s_diff <- norm_2(v_coef - c(coef(fit))) / norm_2(v_coef)
        v_coef <- c(coef(fit))
        # plot the trace
        if (trace) {
            fit$x <- x
            fit$y <- y
            fit$xnam <- xnam
            sub <- paste("Iter:", iter, "diff:", round(s_diff, 3))
            main <- paste("Smoothing:", fit$sp, "dim:", dims)
            cq_regplot(fit, sub = sub, main = main)
        }
        # terminate
        if (s_diff <= tol) break
    }

    fit$x <- x
    fit$y <- y
    fit$xnam <- xnam
    if (analysis) {
        dev.new()
        par(mfrow = c(2, 2), mar = c(4, 4, 2, 2))
        plot(fit, se = TRUE)
        plot(fit, pers = TRUE, theta = 30, phi = 40)
        plot(ystar, fit$fitted.values,
            xlab = "Real Data",
            ylab = "Fitted data", pch = ".", cex = 3
        )
        cq_regplot(fit, sub = sub, main = main)
    }
    fit$ntaus <- ntaus
    fit$bnd <- bnd
    fit$dat <- dat
    fit$wog <- v_wog
    fit$idx <- v_idx
    return(fit)
}

#' Quantile Sheets(original)
#'
#' Estimate conditional quantile sheet Schlossmacher's
#'  Alternating b/w weighted regression and recomputing weights
#' @param x vector or matrix whose rows contains predictors
#'          of each observations.
#' @param y vector of the variable we want to estimate its condtional cdf
#' @param ords  order of splien
#' @param opt   optimization methods
#' @param maxit maximum iteration for Schlossmacherl's method
#' @param ntaus number of taus to be considered
#' @param analysis  indicator whther plot analysis
#' @param trace
#' @param sp    smoothing coefficients
#' @param tol   tolerance for Schlossmacher's
#' @param ...   additional arguement pass into scam (eg. gamma, weights)
#'
#' @import mgcv
#'
#' @return a gam object
#'

qs_gam <- function(x, y, maxit = 10, ntaus = 10,
                   dims = c(10, 10), ords = NA,
                   analysis = F, trace = F, sp = NULL, tol = 1e-3, ...) {
    if (is.vector(x)) {
        s_k <- 1
    } else if (is.matrix(x)) {
        s_k <- ncol(x)
    } else {
        stop("input x type not support")
    }
    # repeat Y ntaus times
    ystar <- rep(y, ntaus)

    # data
    v_taus <- seq(0, 1, length.out = ntaus)
    v_wog <- v_taus[cut(seq_along(ystar), breaks = ntaus, labels = FALSE)]
    xnam <- c("tau", paste0("x", seq_len(s_k)))
    newx <- cbind(v_wog, rep(x, ntaus))
    dat <- data.frame(ystar, newx)
    colnames(dat) <- c("y", xnam)

    # initialization
    fit <- mgcv::gam(y ~ te(tau, x1, k = dims, m = ords),
        data = dat, sp = c(sp), ...
    )
    v_coef <- coef(fit)

    # get info
    v_pred <- predict(fit, dat)
    v_resid <- ystar - v_pred

    # Schlossmacher's method
    for (iter in seq(maxit)) {
        # weights
        v_idx <- ystar <= v_pred
        v_weight <- v_wog
        v_weight[v_idx] <- 1 - v_weight[v_idx]
        v_weight <- v_weight / sqrt(v_resid^2 + 1e-8 * max(abs(v_resid))^2)
        v_weight <- v_weight / mean(v_weight)
        # fit the model
        fit <- mgcv::gam(y ~ te(tau, x1, k = dims, m = ords),
            data = dat, sp = c(sp), weights = c(v_weight),
            start = v_coef, ...
        )

        # terminate
        s_diff <- norm_2(v_coef - coef(fit)) / norm_2(v_coef)
        v_coef <- coef(fit)
        # plot the trace
        if (trace) {
            fit$x <- x
            fit$y <- y
            fit$xnam <- xnam
            sub <- paste("Iter:", iter, "diff:", round(s_diff, 3))
            main <- paste("Smoothing:", fit$sp, "dim:", dims)
            cq_regplot(fit, sub = sub, main = main)
        }
        if (s_diff <= tol) break
        # get info
        v_pred <- fit$fitted.values
        v_resid <- ystar - v_pred
    }

    fit$x <- x
    fit$y <- y
    fit$xnam <- xnam
    if (analysis) {
        dev.new()
        par(mfrow = c(2, 2), mar = c(4, 4, 2, 2))
        plot(fit, se = TRUE)
        plot(fit, pers = TRUE, theta = 30, phi = 40)
        plot(ystar, fit$fitted.values,
            xlab = "Real Data",
            ylab = "Fitted data", pch = ".", cex = 3
        )
        cq_regplot(fit, sub = sub, main = main)
    }
    fit$ntaus <- ntaus
    fit$dat <- dat
    fit$wog <- v_wog
    fit$idx <- v_idx
    return(fit)
}

#' Expectile Sheets with pya's constraint
#'
#' Estimate conditional quantile sheet iterative evalution
#' @param x vector or matrix whose rows contains predictors
#'          of each observations.
#' @param y vector of the variable we want to estimate its condtional cdf
#' @param arg_bs  argument for b-spline
#' @param dims knots number
#' @param ords  order of splien
#' @param opt   optimization methods
#' @param maxit maximum iteration for Schlossmacherl's method
#' @param ntaus number of taus to be considered
#' @param analysis  indicator whther plot analysis
#' @param trace
#' @param sp    smoothing coefficients
#' @param tol   tolerance for Schlossmacher's
#' @param ...   additional arguement pass into scam (eg. gamma, weights)
#'
#' @import scam
#'
#' @return a scam object
#'
es_scam <- function(x, y, maxit = 10, ntaus = 10,
                    arg_bs = c("tesmi1", "ps"),
                    opt = "nlm.fd", dims = c(5, 10), ords = NA,
                    analysis = F, trace = F, sp = NULL, tol = 1e-2, ...) {
    if (is.vector(x)) {
        s_k <- 1
    } else if (is.matrix(x)) {
        s_k <- ncol(x)
    } else {
        stop("input x type not support")
    }

    # initialization
    fit <- cq.reg(x, y, arg_bs, opt, dims, ords, sp = sp, ...)
    v_coef <- coef(fit)

    # repeat Y ntaus times
    ystar <- rep(y, ntaus)

    # data
    v_taus <- seq(0, 1, length.out = ntaus)
    v_wog <- v_taus[cut(seq_along(ystar), breaks = ntaus, labels = FALSE)]
    xnam <- c("tau", paste0("x", seq_len(s_k)))
    newx <- cbind(v_wog, rep(x, ntaus))
    dat <- data.frame(ystar, newx)
    colnames(dat) <- c("y", xnam)

    # get info
    v_pred <- predict(fit, dat)

    # Schlossmacher's method
    for (iter in seq(maxit)) {
        # weights
        v_idx <- ystar <= v_pred
        v_weight <- v_wog
        v_weight[v_idx] <- 1 - v_weight[v_idx]
        v_weight <- v_weight / mean(v_weight)
        # fit the model
        fit <- scam(y ~ s(tau, x1, k = dims, m = ords, bs = arg_bs),
            data = dat, optimizer = opt, sp = c(sp), weights = c(v_weight),
            start = v_coef, ...
        )

        # terminate
        s_diff <- norm_2(v_coef - coef(fit)) / norm_2(v_coef)
        v_coef <- coef(fit)
        # plot the trace
        if (trace) {
            fit$x <- x
            fit$y <- y
            fit$xnam <- xnam
            sub <- paste("Iter:", iter, "diff:", round(s_diff, 3))
            main <- paste("Smoothing:", fit$sp, "dim:", dims)
            cq_regplot(fit, sub = sub, main = main)
        }
        if (s_diff <= tol) break
        # get info
        v_pred <- fit$fitted.values
    }

    fit$x <- x
    fit$y <- y
    fit$xnam <- xnam
    if (analysis) {
        dev.new()
        par(mfrow = c(2, 2), mar = c(4, 4, 2, 2))
        plot(fit, se = TRUE)
        plot(fit, pers = TRUE, theta = 30, phi = 40)
        plot(ystar, fit$fitted.values,
            xlab = "Real Data",
            ylab = "Fitted data", pch = ".", cex = 3
        )
        cq_regplot(fit, sub = sub, main = main)
    }
    fit$ntaus <- ntaus
    fit$dat <- dat
    fit$wog <- v_wog
    fit$idx <- v_idx
    return(fit)
}

#' Expectile Sheets(original)
#'
#' Expectile sheet
#'
#' @param x vector or matrix whose rows contains predictors
#'          of each observations.
#' @param y vector of the variable we want to estimate its condtional cdf
#' @param ords  order of splien
#' @param opt   optimization methods
#' @param maxit maximum iteration for Schlossmacherl's method
#' @param ntaus number of taus to be considered
#' @param analysis  indicator whther plot analysis
#' @param trace
#' @param sp    smoothing coefficients
#' @param tol   tolerance for Schlossmacher's
#' @param ...   additional arguement pass into scam (eg. gamma, weights)
#'
#' @import mgcv
#'
#' @return a gam object
#'

es_gam <- function(x, y, maxit = 10, ntaus = 10,
                   dims = c(10, 10), ords = NA,
                   analysis = F, trace = F, sp = NULL, tol = 1e-3, ...) {
    if (is.vector(x)) {
        s_k <- 1
    } else if (is.matrix(x)) {
        s_k <- ncol(x)
    } else {
        stop("input x type not support")
    }
    # repeat Y ntaus times
    ystar <- rep(y, ntaus)

    # data
    v_taus <- seq(0, 1, length.out = ntaus)
    v_wog <- v_taus[cut(seq_along(ystar), breaks = ntaus, labels = FALSE)]
    xnam <- c("tau", paste0("x", seq_len(s_k)))
    newx <- cbind(v_wog, rep(x, ntaus))
    dat <- data.frame(ystar, newx)
    colnames(dat) <- c("y", xnam)

    # initialization
    fit <- mgcv::gam(y ~ te(tau, x1, k = dims, m = ords),
        data = dat, sp = c(sp), ...
    )
    v_coef <- coef(fit)

    # get info
    v_pred <- predict(fit, dat)

    # Schlossmacher's method
    for (iter in seq(maxit)) {
        # weights
        v_idx <- ystar <= v_pred
        v_weight <- v_wog
        v_weight[v_idx] <- 1 - v_weight[v_idx]
        v_weight <- v_weight / mean(v_weight)
        # fit the model
        fit <- mgcv::gam(y ~ te(tau, x1, k = dims, m = ords),
            data = dat, sp = c(sp), weights = c(v_weight),
            start = v_coef, ...
        )

        # terminate
        s_diff <- norm_2(v_coef - coef(fit)) / norm_2(v_coef)
        v_coef <- coef(fit)
        # plot the trace
        if (trace) {
            fit$x <- x
            fit$y <- y
            fit$xnam <- xnam
            sub <- paste("Iter:", iter, "diff:", round(s_diff, 3))
            main <- paste("Smoothing:", fit$sp, "dim:", dims)
            cq_regplot(fit, sub = sub, main = main)
        }
        if (s_diff <= tol) break
        # get info
        v_pred <- fit$fitted.values
    }

    fit$x <- x
    fit$y <- y
    fit$xnam <- xnam
    if (analysis) {
        dev.new()
        par(mfrow = c(2, 2), mar = c(4, 4, 2, 2))
        plot(fit, se = TRUE)
        plot(fit, pers = TRUE, theta = 30, phi = 40)
        plot(ystar, fit$fitted.values,
            xlab = "Real Data",
            ylab = "Fitted data", pch = ".", cex = 3
        )
        cq_regplot(fit, sub = sub, main = main)
    }
    fit$ntaus <- ntaus
    fit$dat <- dat
    fit$wog <- v_wog
    fit$idx <- v_idx
    return(fit)
}


# Imitating shot noise process according to:
# x(t) = sum(k=1:inf; g(t - sum(i=1:k; xi_i))) + sum(k=1:inf; g(t + sum(i=1:k; eta_i))),
# where g() - measured & absolutely integrated function,
# xi_i, eta_i - i.i.d.r.v. with Exp(1) distribution

g <- function(t)
{
  # g() - measured & absolutely integrated function to make x(t)
  g_scalar <- function(t)
  {
    if(t >= 0 && t <= 0.5)
      return(1)
    else
      return(0)
  }
  return(sapply(X = t, FUN = g_scalar))
}

ShotNoise <- function(t, num, inLambda = 1)
{
  # returns value of x(t)

  # auxiliary random variable to build process: xi or eta
  # 2 different calls of aux_rvar provides independency
  aux_rvar <- function(n = num, lambda = inLambda)
  {
    return(rexp(n, rate = lambda))
  }

  # X = X1 + X2
  X1 <- sum(g(t - cumsum(aux_rvar())))
  X2 <- sum(g(t + cumsum(aux_rvar())))
  X <- X1 + X2
  return(X)
}

EvaluateTail <- function(s, imitNum, over)
{
  # calculating P{max[X(t)]>=s} with imitation
  p <- 0
  for(i in 1:imitNum)
  {
    Sample <- sapply(over, ShotNoise, num = 100)
    M <- max(Sample)
    if(M >= s)
      p <- p + 1/imitNum
  }
  return(p)
}

library(ggplot2)
N <- 1000

Timeline = seq(from = 0, to = 10, by = 0.1)
ShotNoiseValues <- sapply(Timeline, ShotNoise, num = N)
qplot(x = Timeline,
      y = ShotNoiseValues,
      geom = "path",
      main = "Shot Noise Process",
      xlab = "t",
      ylab = "x(t)")
print("Calculated value for P{max[X(t)]>=3}:")
print(EvaluateTail(3, imitNum = N, over = Timeline))


# /**
# * Calculate p-value of hypergeometric test
# * $k : overlop number
# * $m : set 1 size
# * $n : set 2 size
# * $N : background size
# *               C(m,k) * C(N-m, n-k)
# * log(P) = log[----------------------]
# *                   C(N, n)
# *               m!/(k!(m-k)!) * (N-m)!/(n-k)!(N-m-n+k)!)
# *        = log[------------------------------------------]
# *                          N!/(n!(N-n)!)
# *        =   logfact(m) + logfact(N-m) + logfact(n) + logfact(N-n)
# *          - logfact(k) - logfact(m-k) - logfact(n-k) - logfact(N-m-n+k) - logfact(N)
# */
{{rimport}}('__init__.r')
library(methods)

infile  = {{i.infile | R}}
outfile = {{o.outfile | R}}
intype  = {{args.intype | R}}
N       = {{args.N | R}}
inopts  = update.list(list(rnames=T, cnames=T), {{args.inopts | R}})

ret    = matrix(nrow = 0, ncol = 5)
colnames(ret) = c('k', 'm', 'n', 'N', 'pval')

if (intype == 'raw') {
	rn     = if (inopts$rnames) 1 else NULL
	data   = read.table(infile, row.names = rn, header = inopts$cnames, sep = "\t", check.names = F)
	cnames = colnames(data)
	ncols  = ncol(data)
	if (is.null(N))
		N = nrow(data)
	if (ncols < 2)
		stop ('Need at least 2 columns.')
	if (!inopts$cnames) {
		cnames = paste0("COL", 1:ncols)
		colnames(data) = cnames
	}
	for (i in 1:(ncols-1)) {
		for (j in (i+1):ncols) {
			row       = list(k = NA, m = NA, n = NA, N = N, pval = NA)
			row$m     = sum(data[, i], na.rm = T)
			row$n     = sum(data[, j], na.rm = T)
			row$k     = nrow(data[which(data[, i] + data[, j] == 2), ])
			row$pval  = phyper(row$k, row$m, row$N-row$m, row$n, lower.tail = F)
			row.names = paste(cnames[i], 'vs', cnames[j], sep = '.')
			row       = as.data.frame(row)

			rownames(row) = row.names

			ret = rbind(ret, row)
		}
	}
} else {
	rn     = if (inopts$rnames) 1 else NULL
	data   = read.table(infile, row.names = rn, header = inopts$cnames, sep = "\t", check.names = F)
	cnames = colnames(data)
	ncols  = ncol(data)
	if (!inopts$cnames) {
		cnames = c('k', 'm', 'n', 'N')[1:ncols]
		colnames(data) = cnames
	}
	if (!'N' %in% cnames && is.null(N)) {
		stop('N is not specified neither in infile nor args.N.')
	}
	if (!'k' %in% cnames || !'m' %in% cnames || !'n' %in% cnames) {
		stop('Column k, m or n is missing.')
	}
	rnames = rownames(data)
	if (!inopts$rnames) {
		rnames = paste0('ROW', 1:nrow(data))
		rownames(data) = rnames
	}
	for (rname in rnames) {
		if ('N' %in% cnames) N = data[rname, 'N']
		row      = list(k = NA, m = NA, n = NA, N = N, pval = NA)
		row$m    = data[rname, 'm']
		row$n    = data[rname, 'n']
		row$k    = data[rname, 'k']
		row$pval = phyper(row$k, row$m, row$N-row$m, row$n, lower.tail = F)
		row      = as.data.frame(row)

		rownames(row) = rname
		ret = rbind(ret, row)
	}
}

write.table(
	pretty.numbers(ret, formats = list(pval = '%.2E')),
	outfile, quote = F, row.names = T, col.names = T, sep = "\t"
)


population<-c(2, 3, 4, 5, 6, 7, 8, 9, 10, 11)
#  There are 45 possible samples of 2 items selected from the 10 items.
combn(population, 2)
samps<-combn(population, 2)
xbars <- colMeans(samps)
table(xbars)
prop.table(table(xbars))


labMarketOD <- function(N,sal_res,OD){
  if(OD == "o"){
    func = 0.5*N
    func[func<sal_res] = sal_res
  } else{
    func = 57-0.5*N
  }
  return(func)
}

laborMarketPlot <- function(input,output,values){
  emp_level = seq(0,100,length.out = 100)
  to_plot = data.frame(emp_level = emp_level)

  eqNo = (input$W)/(0.5*values$p)
  eqNstar = labMarketOD(values$eq$Nstar,input$sal_res,"o")

  fig = plot_ly(to_plot, x = ~emp_level)
  fig = fig %>% add_trace(y = labMarketOD(emp_level,input$sal_res,"o"), type = "scatter", mode = "lines", name = "$$N^s(N)$$", line = list(color = "blue"),
                          hovertemplate = paste("Ns=%{x:.0f}","
W/p=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_trace(y = labMarketOD(emp_level,input$sal_res,"d"), type = "scatter", mode = "lines", name = "$$N^d(N)$$", line = list(color = "red"),
                          hovertemplate = paste("Nd=%{x:.0f}","
W/p=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(0,input$W/values$p,values$eq$subN,input$W/values$p, line = list(color = 'blue', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("N=%{x:.0f}","
W/p=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$subN,input$W/values$p,values$eq$N,input$W/values$p, line = list(color = 'green', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("N=%{x:.0f}","
W/p=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$N,input$W/values$p,eqNo,input$W/values$p, line = list(color = 'grey', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("N=%{x:.0f}","
W/p=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$subN,0,values$eq$subN,input$W/values$p, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("N=%{x:.0f}","
W/p=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_trace(x = values$eq$subN, y = input$W/values$p, mode = "markers", marker = list(color = "blue"), showlegend = F,
                          hovertemplate = paste("N=%{x:.0f}","
W/p=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$Nstar,0,values$eq$Nstar,eqNstar, line = list(color = 'rgb(200,0,0)', width = 1, dash = 'dash'), showlegend = F,
                             hovertemplate = paste("N*=%{x:.0f}","
(W/p)*=%{y:.0f}","<extra></extra>"))

  if(abs(values$eq$Nstar - values$eq$N) >= 5 & abs(values$eq$subN - values$eq$N) >= 5){
    x_label = c(values$eq$Nstar,values$eq$N,values$eq$subN)
    y_label = c(eqNstar,input$W/values$p,input$W/values$p)
    text_label = c(paste0("N*=",round(values$eq$Nstar),",(W/p)*=",round(eqNstar,1)),paste0("N=",round(values$eq$N)),paste0("N=",round(values$eq$subN)))
  } else if(abs(values$eq$Nstar - values$eq$N) >= 5 & abs(values$eq$subN - values$eq$N) <= 5){
    x_label = c(values$eq$Nstar,values$eq$N)
    y_label = c(eqNstar,input$W/values$p)
    text_label = c(paste0("N*=",round(values$eq$Nstar),",(W/p)*=",round(eqNstar,1)),paste0("N=",round(values$eq$N)))
  } else if(abs(values$eq$Nstar - values$eq$N) <= 5 & abs(values$eq$subN - values$eq$N) >= 5){
    x_label = c(values$eq$Nstar,values$eq$subN)
    y_label = c(eqNstar,input$W/values$p)
    text_label = c(paste0("N*=",round(values$eq$Nstar),",(W/p)*=",round(eqNstar,1)),paste0("N=",round(values$eq$subN)))
  } else{
    x_label = c(values$eq$Nstar)
    y_label = c(eqNstar)
    text_label = paste0("N*=",round(values$eq$Nstar),",(W/p)*=",round(eqNstar,1))
  }
  eq_label = list(
    x = x_label,
    y = y_label,
    text = text_label
  )
  fig = fig %>% layout(annotations = eq_label)

  f <- list(
    family = "Courier New, monospace",
    size = 18,
    color = "#7f7f7f"
  )
  empLevel <- list(
    title = "Niveau d'emploi, N",
    titlefont = f
  )
  salReels <- list(
    title = "Salaires réels, W/p",
    titlefont = f
  )
  fig = fig %>% layout(xaxis = empLevel, yaxis = salReels)
}

margCost = function(N,w){
  return(w/(-N^0.6+13)+5)
}

firmEqPlot <- function(input,output,values){
  N = seq(0,70,length.out = 1000)
  to_plot = data.frame(emp_level = N)

  eqRev = margCost(values$eq$N,input$W/values$p)#*values$p
  subEqRev = margCost(values$eq$subN,input$W/values$p)
  fig = plot_ly(to_plot, x = ~emp_level)
  fig = fig %>% add_trace(y = margCost(N,input$W/values$p), type = "scatter", mode = "lines", name = "$$N^s(N)$$", line = list(color = "red"),
                          hovertemplate = paste("N=%{x:.0f}","
R=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(0,eqRev,98,eqRev, line = list(color = 'blue', width = 1), showlegend = FALSE,
                             hovertemplate = paste("N=%{x:.0f}","
R=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$subN,0,values$eq$subN,subEqRev, line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("Nd=%{x:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$subN, subEqRev, values$eq$subN, eqRev,  line = list(color = "green", width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("Nd=%{x:.0f}","
R=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$subN, subEqRev, values$eq$N, subEqRev,  line = list(color = "green", width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("Nd=%{x:.0f}","
R=%{y:.0f}","<extra></extra>"))
  fig = fig %>% add_segments(values$eq$N, 0, values$eq$N, eqRev,  line = list(color = 'rgb(200, 0, 0)', width = 1, dash = 'dash'), showlegend = FALSE,
                             hovertemplate = paste("Nd=%{x:.0f}","
R=%{y:.0f}","<extra></extra>"))

  if(abs(values$eq$subN - values$eq$N) > 5){
    x_label = c(values$eq$N,values$eq$subN)
    y_label = c(eqRev,subEqRev)
    text_label = c(paste0("N=",round(values$eq$N)),paste0("N=",round(values$eq$subN)))
  } else{
    x_label = c(values$eq$N)
    y_label = c(eqRev)
    text_label = paste0("N=",round(values$eq$N))
  }
  eq_label = list(
    x = x_label,
    y = y_label,
    text = text_label
  )
  fig = fig %>% layout(annotations = eq_label)

  f <- list(
    family = "Courier New, monospace",
    size = 18,
    color = "#7f7f7f"
  )
  empLevel <- list(
    title = "Niveau d'emploi, N",
    titlefont = f,
    range = c(0,70)
  )
  revCosts <- list(
    title = "Revenus et Couts",
    titlefont = f,
    range = c(0,40)
  )
  fig = fig %>% layout(xaxis = empLevel, yaxis = revCosts)

}


#volume of a donut

r <- 3 #minor radius of the donut

R <- 6 #major radius of the donut

#circumference of the donut

circum_inner <- 2*pi*R

#cylindrical area of the donut
area <- pi*(r^2)

#volume = area * circumference

volume <- area * circum_inner

print(volume)


qroots <- function(a, b, c) {
  r <- sqrt(b * b - 4 * a * c + 0i)
  if (abs(b - r) > abs(b + r)) {
    z <- (-b + r) / (2 * a)
  } else {
    z <- (-b - r) / (2 * a)
  }
  c(z, c / (z * a))
}

qroots(1, 0, 2i)
[1] -1+1i  1-1i

qroots(1, -1e9, 1)
[1] 1e+09+0i 1e-09+0i


#!/usr/bin/Rscript
# Copyright © 2016 Martin Ueding <dev@martin-ueding.de>
# Licensed under the MIT license.

bin_count = 50
samples_count = 100000

pdf = function(x) {
    sqrt(1/x - log(1 - x))
}

gm = function(x) {
    4 / (pi * sqrt(x * (1 - x)))
}

# Plot the original function.
x_orig = seq(0.01, 0.99, length.out=200)
y_orig = pdf(x_orig)
plot(x_orig, y_orig, type='l', main='Original PDF', xlab='x', ylab='y',
     col='red')

# Also plot the majorizing function.
y = gm(x_orig)
lines(x_orig, y)

inverse_cdf = function(u) {
    sin(pi * u / 2)^2
}

u = runif(samples_count)
x = inverse_cdf(u)

u2 = runif(samples_count)
idx = u2 < pdf(x) / gm(x)
accepted = x[idx]

hist(accepted, breaks=bin_count, freq=FALSE)

# The pdf above needs to be normalized, on the problem/solution set the
# normalization is given as this particular magic number.
lines(x_orig, y_orig / 2.32812, col='red')


sieve <- function(n)
{
   n <- as.integer(n)
   if(n > 1e6) stop("n too large")  # restricting for larger values of n
   primes <- rep(TRUE, n) # initially all false
   primes[1] <- FALSE # trivial case
   last.prime <- 2L
   for(i in last.prime:floor(sqrt(n)))  # looping through the array
   {
      primes[seq.int(2L*last.prime, n, last.prime)] <- FALSE
      last.prime <- last.prime + min(which(primes[(last.prime+1):n]))
   }
   which(primes)
}

 sieve(1000000) # calling the function


.logit <- function(x) { log(x / (1 - x)) }
.dlogit <- function(x) { 1 / (x - x * x) }
.logistic <- function(x) { 1 / (1 + exp(-x)) }
.logit_scale <- function(x, a, b) { log((a - x) / (x - b)) }
.dlogit_scale <- function(x, a, b) {(b - a) / ((a - x) * (x - b)) }
.logistic_scale <- function(x, a, b) { ex <- exp(x); (a + b * ex) / (ex + 1) }

#' Transform to an unbounded domain
#'
#' description
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @export
mvd.transform_to_unbounded <- function(x, bounds) {
    transformed <- matrix(NA, nrow = nrow(x), ncol = ncol(x))
    for (i in 1:ncol(x)) {
        if (bounds[i, 1] >= bounds[i, 2]) {
            stop("Upper bound must be strictly higher than lower bound")
        }

        if (bounds[i, 1] == 0 && bounds[i, 2] == 1) {
            # [0,1] -> logit
            transformed[, i] <- .logit(x[, i])
        } else if (bounds[i, 1] == 0 && bounds[i, 2] == Inf) {
            # [0,inf] -> log
            transformed[, i] <- log(x[, i])
        } else if (bounds[i, 1] == -Inf && bounds[i, 2] == 0) {
            # [0,inf] -> log
            transformed[, i] <- log(-x[, i])
        } else if (bounds[i, 1] == -Inf && bounds[i, 2] == Inf) {
            # [-inf,inf] -> no transform
            transformed[, i] <- x[, i]
        } else {
            # [a,b] -> scaled logit
            transformed[, i] <- .logit_scale(x[, i], bounds[i, 1], bounds[i, 2])
        }
    }
    return(transformed)
}

#' Reverse transform from an unbounded domain
#'
#' description
#' @param transformed_x Matrix or vector of transformed samples. For matrices, rows are samples and columns are variables.
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @export
mvd.transform_from_unbounded <- function(transformed_x, bounds) {
    x <- matrix(NA, nrow = nrow(x), ncol = ncol(x))
    for (i in 1:ncol(x)) {
        if (bounds[i, 1] == 0 && bounds[i, 2] == 1) {
            # [0,1] -> logit -> inverse = logistic
            x[, i] <- .logistic(transformed_x[, i])
        } else if (bounds[i, 1] == 0 && bounds[i, 2] == Inf) {
            # [0,inf] -> log -> inverse = exp
            x[, i] <- exp(transformed_x[, i])
        } else if (bounds[i, 1] == -Inf && bounds[i, 2] == 0) {
            # [0,inf] -> log -> inverse = exp
            x[, i] <- -exp(transformed_x[, i])
        } else if (bounds[i, 1] == -Inf && bounds[i, 2] == Inf) {
            # [-inf,inf] -> no transform
            x[, i] <- transformed_x[, i]
        } else {
            # [a,b] -> scaled logit -> inverse = scaled logistic
            x[, i] <- .logistic_scale(transformed_x[, i], bounds[i, 1], bounds[i, 2])
        }
    }
    return(x)
}

#' Probability density correction for variable transformation
#' @param x Matrix or vector of samples. For matrices, rows are samples and columns are variables.
#' @param bounds Dx2 matrix specifying the lower and upper bound for each variable.
#' @param p Probability densities to correct
#' @param log Specifies whether p is in log scale
#' @export
mvd.correct_p_for_transformation <- function(x, bounds, p, log = T) {
    if (log) {
        for (i in 1:ncol(x)) {
            if (bounds[i, 1] == 0 && bounds[i, 2] == 1) {
                # [0,1] -> logit -> derivative = dlogit
                p <- p + log(.dlogit(x[, i]))
            } else if (bounds[i, 1] == 0 && bounds[i, 2] == Inf) {
                # [0,inf] -> log -> derivative = 1/log
                p <- p - log(x[, i])
            } else if (bounds[i, 1] == -Inf && bounds[i, 2] == 0) {
                # [0,inf] -> log -> derivative = 1/log
                p <- p - log(x[, i])
            } else if (bounds[i, 1] == -Inf && bounds[i, 2] == Inf) {
                # [-inf,inf] -> no transform
            } else {
                # [a,b] -> scaled logit -> derivative = dlogit_scale
                p <- p + log(.dlogit_scale(x[, i], bounds[i, 1], bounds[i, 2]))
            }
        }
    } else {
        for (i in 1:ncol(x)) {
            if (bounds[i, 1] == 0 && bounds[i, 2] == 1) {
                # [0,1] -> logit -> derivative = dlogit
                p <- p * .dlogit(x[, i])
            } else if (bounds[i, 1] == 0 && bounds[i, 2] == Inf) {
                # [0,inf] ->log(x) -> 1/x
                p <- p / x[, i]
            } else if (bounds[i, 1] == -Inf && bounds[i, 2] == 0) {
                # [0,inf] ->log(x) -> 1/x
                p <- p / x[, i]
            } else if (bounds[i, 1] == -Inf && bounds[i, 2] == Inf) {
                # [-inf,inf] -> no transform
            } else {
                # [a,b] -> scaled logit -> derivative = dlogit_scale
                p <- p * .dlogit_scale(x[, i], bounds[i, 1], bounds[i, 2])
            }
        }
    }
    return(p)
}

.mvd.transform_name <- function(bounds, i) {
    if (bounds[i, 1] == 0 && bounds[i, 2] == 1) {
        return("logit")
    } else if (bounds[i, 1] == 0 && bounds[i, 2] == Inf) {
        return("log")
    } else if (bounds[i, 1] == -Inf && bounds[i, 2] == 0) {
        return("negative log")
    } else if (bounds[i, 1] == -Inf && bounds[i, 2] == Inf) {
        return("no transform")
    } else {
        return("scaled logit")
    }
}


#' MLE for the trunckated normal distribution
#'
#' Creating a Function that Returns the Log Likelihood, Gradient and Hessian Functions
#'
#' @param data numeric vector
#' @param t truncation limits
#' @param ... additional options
#'
#' @export
#'

mklhood <- function(data, t, ...) {

    data <- na.omit(data)
    n <- length(data)
    t <- sort(t)

    psi<-function(y, mu, sigma){
        exp(-(y-mu)^2/(2*sigma^2))/(sigma*sqrt(2*pi))
    }

    psi.mu<-function(y,mu,sigma){
        exp(-(y-mu)^2/(2*sigma^2)) * ((y-mu)/(sigma^3*sqrt(2*pi)))
    }

    psi.sigma<-function(y,mu,sigma){
        exp(-(y-mu)^2/(2*sigma^2)) *
            (((y-mu)^2)/(sigma^4*sqrt(2*pi)) - 1/(sigma^2*sqrt(2*pi)))
    }

    psi2.mu<-function(y,mu,sigma){
        exp(-(y - mu)^2/(2*sigma^2)) *
            (((y - mu)^2)/(sigma^5*sqrt(2*pi))-1/(sigma^3*sqrt(2*pi)))
    }

    psi2.sigma<-function(y,mu,sigma){
        exp(-(y-mu)^2/(2*sigma^2)) *
            ((2)/(sigma^3*sqrt(2*pi)) - (5*(y-mu))/(sigma^5*sqrt(2*pi)) +
             ((y-mu)^4)/(sigma^7*sqrt(2*pi)))
    }

    psi12.musig<-function(y,mu,sigma){
        exp(-(y-mu)^2/(2*sigma^2)) *
            (((y-mu)^3)/(sigma^6*sqrt(2*pi)) - (3*(y-mu))/(sigma^4*sqrt(2*pi)))
    }

    ll.tnorm2<-function(p){
        out <- (-n*log(pnorm(t[2],p[1],p[2])-pnorm(t[1],p[1],p[2]))) -
            (n*log(sqrt(2*pi*p[2]^2))) - (sum((data-p[1])^2)/(2*p[2]^2))
        -1*out
    }

    grad.tnorm<-function(p){
        g1 <- (-n*(integrate(psi.mu,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value) /
               (pnorm(max(t),p[1],p[2])-pnorm(min(t),p[1],p[2]))) - ((n*p[1]-sum(data))/p[2]^2)
        g2 <- (-n*(integrate(psi.sigma,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value) /
               (pnorm(max(t),p[1],p[2])-pnorm(min(t),p[1],p[2]))) - ((n)/(p[2])) + ((sum((data-p[1])^2))/(p[2]^3))
        out <- c(g1,g2)
        return(out)
    }

    hessian.tnorm<-function(p){

        h1<- -n*(integrate(psi,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value *
                                                                                integrate(psi2.mu,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value -
                                                                                integrate(psi.mu,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value^2) /
            (integrate(psi,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value^2) -
            n/(p[2]^2)

        h3<- -n*(integrate(psi,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value *
                                                                                integrate(psi12.musig,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value -
                                                                                integrate(psi.mu,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value *
                                                                                integrate(psi.sigma,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value) /
            (integrate(psi,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value^2) +
            (2*(n*p[1]-sum(data)))/(p[2]^3)

        h2<- -n*(integrate(psi,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value *
                                                                                integrate(psi2.sigma,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value -
                                                                                integrate(psi.sigma,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value^2) /
            (integrate(psi,t[1],t[2],mu=p[1],sigma=p[2], stop.on.error = FALSE)$value^2) +
            (n)/(p[2]^2)-(3*sum((data-p[1])^2))/(p[2]^4)

        H<-matrix(0,nrow=2,ncol=2)
        H[1,1]<-h1
        H[2,2]<-h2
        H[1,2]<-H[2,1]<-h3
        return(H)
    }

    return(list(ll.tnorm2 = ll.tnorm2, grad.tnorm = grad.tnorm, hessian.tnorm = hessian.tnorm))
}

#' Newton Raphson Function
#'
#' This takes in the Objects Returned from mklhood Function above
#'
#' @param lhood lhood
#' @param p p
#' @param tol tolerance
#' @param maxit max iterations
#'
#' @export
#'
NewtonRaphsonLike <- function(lhood, p, tol = 1e-07, maxit = 100) {

    cscore <- lhood$grad.tnorm(p)
    if(sum(abs(cscore)) < tol)
        return(list(estimate = p, value = lhood$ll.tnorm2(p), iter = 0))
    cur <- p
    for(i in 1:maxit) {
        inverseHess <- solve(lhood$hessian.tnorm(cur))
        cscore <- lhood$grad.tnorm(cur)
        new <- cur - cscore %*% inverseHess
        if (new[2] <= 0) stop("Sigma < 0")
        cscore <- lhood$grad.tnorm(new)

        if(((abs(lhood$ll.tnorm2(cur)- lhood$ll.tnorm2(new))/(lhood$ll.tnorm2(cur))) < tol))
            return(list(estimate = new, value= lhood$ll.tnorm2(new), iter = i))
        cur <- new
    }

    return(list(estimate = new, value= lhood$ll.tnorm2(new), iter = i))
}

#' Based on the MLE Functions (mklhood) and NewtonRaphson Function
#'
#' (NewtonRaphsonLike), This function estimates the MEAN and SD from the Truncated using Newton Raphson.
#'
#' @param missingdata matrix
#' @param perc perc
#' @param iter iterations in NR algorithm
#'
#' @export
#'

EstimatesComputation <- function(missingdata, perc, iter=50) {

    ## 2 column matrix where column 1 = means, column 2 = SD
    ParamEstim <- matrix(NA, nrow = nrow(missingdata), ncol = 2)
    nsamp <- ncol(missingdata)

    ## sample means / SDs
    ParamEstim[,1] <- rowMeans(missingdata, na.rm = TRUE)
    ParamEstim[,2] <- apply(missingdata, 1, function(x) sd(x, na.rm = TRUE))

    ## Case 1: missing % > perc => use sample mean / SD
    na.sum <- apply(missingdata, 1, function(x) sum(is.na(x)))
    idx1 <- which(na.sum/nsamp >= perc)

    ## Case 2: sample mean > 3 SD away from LOD => use sample mean / SD
    lod <- min(missingdata, na.rm=TRUE) ## why use the min of whole data set??????
    idx2 <- which(ParamEstim[,1] > 3*ParamEstim[,2] + lod)

    ## Case 3: for all others, use NR method to obtain truncated mean / SD estimate
    idx.nr <- setdiff(1:nrow(missingdata), c(idx1, idx2))
    ## t = limits of integration (LOD and upper)
    upplim <- max(missingdata, na.rm=TRUE) + 2*max(ParamEstim[,2])
    for (i in idx.nr) {
        Likelihood <- mklhood(missingdata[i,], t=c(lod, upplim))
        res <- tryCatch(NewtonRaphsonLike(Likelihood, p = ParamEstim[i,]),
                        error = function(e) 1000)

        if (length(res) == 1) {
            next
        } else if (res$iter >= iter) {
            next
        } else {
            ParamEstim[i,] <- as.numeric(res$estimate)
        }
    }
    return(ParamEstim)
}

#' This Function imputes the data BASED on KNN-EUCLIDEAN
#'
#' @param data data set to be imputed
#' @param k number of neighbors for imputing values
#' @param rm.na remove NA
#' @param rm.nan remove NaN
#' @param rm.inf remove Inf
#'
#' @export
#'
KNNEuc <- function (data, k, rm.na = TRUE, rm.nan = TRUE, rm.inf = TRUE) {

    nr <- dim(data)[1]

    imp.knn <- data
    imp.knn[is.finite(data) == FALSE] <- NA
    t.data<-t(data)

    mv.ind <- which(is.na(imp.knn), arr.ind = TRUE)
    arrays <- unique(mv.ind[, 2])
    array.ind <- match(arrays, mv.ind[, 2])
    nfeatures <- 1:nr

    for (i in 1:length(arrays)) {
        set <- array.ind[i]:min((array.ind[(i + 1)] - 1), dim(mv.ind)[1], na.rm = TRUE)
        cand.features <- nfeatures[-unique(mv.ind[set, 1])]
        cand.vectors <- t.data[,cand.features]
        exp.num <- arrays[i]

        for (j in set) {
            feature.num <- mv.ind[j, 1]
            tar.vector <- data[feature.num,]

            dist <- sqrt(colMeans((tar.vector-cand.vectors)^2, na.rm = TRUE))
            dist[is.nan(dist) | is.na(dist)] <- Inf
            dist[dist==0] <- ifelse(is.finite(min(dist[dist>0])), min(dist[dist>0])/2, 1)

            if (sum(is.finite(dist)) < k) {
                stop(message = "Fewer than K finite distances found")
            }
            k.features.ind <- order(dist)[1:k]
            k.features <- cand.features[k.features.ind]
            wghts <- 1/dist[k.features.ind]/sum(1/dist[k.features.ind])
            imp.knn[feature.num, exp.num] <- wghts %*% data[k.features, exp.num]
        }
    }

    if (!rm.na) {
        imp.knn[is.na(data) == TRUE & is.nan(data) == FALSE] <- NA
    }
    if (!rm.inf) {
        index <- is.finite(data) == FALSE & is.na(data) == FALSE &
            is.nan(data) == FALSE
        imp.knn[index] <- data[index]
    }
    if (!rm.nan) {
        imp.knn[is.nan(data) == TRUE] <- NaN
    }
    return(imp.knn)
}

#' imputeKNN
#'
#' This Function imputes the data based on KNN-CORRELATION or
#' KNN-TRUNCATION. The Parameter Estimates based on the Truncated
#' Normal from EstimateComputation function is run on this function
#'
#' @param data data
#' @param k k
#' @param distance distance
#' @param rm.na remove NA
#' @param rm.nan remove NaN
#' @param rm.inf remove Inf
#' @param perc percentage
#' @param ... additional options
#'
#' @export
#'

imputeKNN <- function (data, k , distance = "correlation",
                       rm.na = TRUE, rm.nan = TRUE, rm.inf = TRUE, perc=1,...) {

    if (!(is.matrix(data))) {
        stop(message = paste(deparse(substitute(data)),
                             " is not a matrix.", sep = ""))
    }

    distance <- match.arg(distance, c("correlation","truncation"))

    nr <- dim(data)[1]
    if (k < 1 | k > nr) {
        stop(message = "k should be between 1 and the number of rows")
    }

    if (distance=="correlation"){
        genemeans<-rowMeans(data,na.rm=TRUE)
        genesd<-apply(data, 1, function(x) sd(x, na.rm = TRUE))
        data<-(data-genemeans)/genesd
    }

    if (distance=="truncation"){

	ParamMat <- EstimatesComputation(data, perc = perc)

    	genemeans<-ParamMat[,1]
        genesd<-ParamMat[,2]
        data<-(data-genemeans)/genesd
    }

    imp.knn <- data
    imp.knn[is.finite(data) == FALSE] <- NA
    t.data<-t(data)

    mv.ind <- which(is.na(imp.knn), arr.ind = TRUE)
    arrays <- unique(mv.ind[, 2])
    array.ind <- match(arrays, mv.ind[, 2])
    ngenes <- 1:nr

    for (i in 1:length(arrays)) {
        set <- array.ind[i]:min((array.ind[(i + 1)] - 1), dim(mv.ind)[1],
                                na.rm = TRUE)
        cand.genes <- ngenes[-unique(mv.ind[set, 1])]
        cand.vectors <- t.data[,cand.genes]
        exp.num<- arrays[i]
        for (j in set) {

            gene.num <- mv.ind[j, 1]
            tar.vector <- data[gene.num,]

            r <- (cor(cand.vectors,tar.vector, use = "pairwise.complete.obs"))
            dist <- switch(distance,
                           correlation = (1 - abs(r)),
                           truncation = (1 - abs(r)))
            dist[is.nan(dist) | is.na(dist)] <- Inf
            dist[dist==0]<-ifelse(is.finite(min(dist[dist>0])), min(dist[dist>0])/2, 1)
            dist[abs(r) == 1] <- Inf

            if (sum(is.finite(dist)) < k) {
                stop(message = "Fewer than K finite distances found")
            }
            k.genes.ind <- order(dist)[1:k]
            k.genes <- cand.genes[k.genes.ind]

            wghts <- (1/dist[k.genes.ind]/sum(1/dist[k.genes.ind])) * sign(r[k.genes.ind])
            imp.knn[gene.num, exp.num] <- wghts %*% data[k.genes, exp.num]
        }
    }

    if (distance=="correlation") {
        imp.knn <- (imp.knn * genesd) + genemeans
    }

    if(distance=="truncation") {
        imp.knn <- (imp.knn * genesd) + genemeans
    }

    if (!rm.na) {
        imp.knn[is.na(data) == TRUE & is.nan(data) == FALSE] <- NA
    }
    if (!rm.inf) {
        index <- is.finite(data) == FALSE & is.na(data) == FALSE &
            is.nan(data) == FALSE
        imp.knn[index] <- data[index]
    }
    if (!rm.nan) {
        imp.knn[is.nan(data) == TRUE] <- NaN
    }
    return(imp.knn)
}

#' Root Mean Squared Error Function
#'
#' @param imp imputation
#' @param mis missing
#' @param true true data
#' @param norm normal
#'
#' @export
#'
Rmse <- function(imp, mis, true, norm = FALSE) {
    imp <- as.matrix(imp)
    mis <- as.matrix(mis)
    true <- as.matrix(true)
    missIndex <- which(is.na(mis))
    errvec <- imp[missIndex] - true[missIndex]
    rmse <- sqrt(mean(errvec^2))
    if (norm) {
        rmse <- rmse/sd(true[missIndex])
    }
    return(rmse)
}

#' Compute the Errors for the Different Imputation Methods
#'
#' @param trunc truncation
#' @param corr corr
#' @param euc euc
#' @param miss missing
#' @param complete complete
#'
#' @export
#'

ErrorsComputation <- function(trunc, corr, euc, miss, complete) {

    ImputeErrors <- NULL
    missing <- t(miss)
    original <- t(complete)
    KnnTrunc <- Rmse(trunc, missing, original)
    KnnCorr <- Rmse(corr, missing, original)
    KnnEuc <- Rmse(euc, missing, original)
    ImputeErrors <- c(KnnTrunc, KnnCorr, KnnEuc)
    return(ImputeErrors)

}