library(ape)

coalescent_rate <- function(k, pop_size) {
    0.25 * k * (k - 1) / pop_size
}

leaf_node <- function(name, time) {
    list(type = "leaf", name = name, time = time)
}

branch_node <- function(name, children, time) {
    list(type = "branch",
         name = name,
         children = children,
         time = time,
         lengths = c(time - children[[1]]$time,
                     time - children[[2]]$time))
}

binary_parent <- function(child1, child2, time) {
    parent_name <- paste(child1$name, child2$name, sep = "-")
    branch_node(parent_name, list(child1, child2), time)
}

current_time <- 0
sampled_population <- list(leaf_node("beth", current_time),
                           leaf_node("gerry", current_time),
                           leaf_node("morty", current_time),
                           leaf_node("summer", current_time))
population_size <- 100

k <- +Inf

while (k > 2) {
    k <- length(sampled_population)
    coalescent_time <- rexp(1, coalescent_rate(k, population_size))
    current_time <- current_time + coalescent_time
    ixs <- sample.int(k, size = 2)
    parent_node <- binary_parent(sampled_population[[ixs[1]]], sampled_population[[ixs[2]]], current_time)
    if (k > 2) {
        sampled_population <- c(list(parent_node), sampled_population[-ixs])
    } else {
        sampled_population <- parent_node
    }
}

newick_helper <- function(node) {
    if (node$type == "leaf") {
        node$name
    } else if (node$type == "branch") {
        sprintf("(%s:%f,%s:%f)%s",
                newick_helper(node$children[[1]]),
                node$lengths[1],
                newick_helper(node$children[[2]]),
                node$lengths[2],
                node$name)
    }
}

newick <- function(node) {
    sprintf("%s;", newick_helper(node))
}

demo_tree <- read.tree(text = newick(sampled_population))

plot(demo_tree)


### Functions for data process
#' Generate initialization from specific space
#'
#' @param p p*p orthodox matrix
#' @param d p*d orthodox matrix
#' @param runs the number of orthodox matrix
#' @param orth.method orthodox method
#'
#' @return w.list
#' @export
#'
#' @examples gen.inits(2,3,3,'svd')
gen.inits <- function(p,d,runs,orth.method=c('svd','givens')) {
  orth.method=match.arg(orth.method) # the first value in orth.metod #
  W.list = list()
  for(i in 1:runs) {
    if(orth.method=='givens') {
      W.list[[i]] <- as.matrix(theta2W(runif(n=choose(p,2),min=0,max=2*pi)))[,1:d]  # convert vector into orthodox matirx and get p*d #
    } else {
      temp = matrix(rnorm(p*d),p,d)
      W.list[[i]] <- svd(temp)$u     # svd left matrix p*d #
    }
  }
  W.list
}

#' Convert angle vector into  orthodox matrix
#'
#' @param theta vector of angles theta
#'
#' @return an orthodox matrix
#' @export
#'
#'
theta2W = function(theta)
{
  #<author hidden>
  # For a vector of angles theta, returns W, a d x d Givens rotation matrix:
  # W = Q.1,d %*% ... %*% Q.d-1,d %*% Q.1,d-1 %*% ... %*% Q.1,3 %*% Q.2,3 %*% Q.1,2
  ##  if(theta < 0  || pi < theta){stop("theta must be in the interval [0,pi]")}
  d = (sqrt(8*length(theta)+1)+1)/2
  if(d - floor(d) != 0){stop("theta must have length: d(d-1)/2")}
  W = diag(d)
  index = 1
  for(j in 1:(d-1)){
    for(i in (j+1):d){
      Q.ij = givens.rotation(theta[index], d, c(i,j))
      W = Q.ij %*% W
      index = index + 1
    }
  }
  W
}

#-----------------------
#' Orthogonalization of matrix
#'
#' @param W arbitrary matrix
#'
#' @return orthogonalized matrix
#' @export
#'
orthogonalize = function (W) {
  ##For arbitrary W, this is equivalent to (WW^T)^{-1/2} W
  temp <- svd(W)
  tcrossprod(temp$u,temp$v)
}

#' Whitening Function
#'
#' @param X dataset
#' @param n.comp the number of components
#' @param center.row whether center the row of data
#'
#' @return a whitener matrix
#' @export
#'
#' @import MASS
whitener <- function(X,n.comp=ncol(X),center.row=FALSE) {

  #X must be n x d
  if(ncol(X)>nrow(X)) warning('X is whitened with respect to columns')
  #Corresponds to model of the form X.center = S A, where S are orthogonal with covariance = identity.
  x.center=scale(X,center=TRUE,scale=FALSE)
  if(center.row==TRUE) x.center = x.center - rowMeans(x.center)
  n.rep=dim(x.center)[1]
  svd.x=svd(x.center,nu=n.comp,nv=n.comp)

  #RETURNS PARAMETERIZATION AS IN fastICA (i.e., X is n x d)
  #NOTE: For whitened X, re-whitening leads to different X
  #The output for square A is equivalent to solve(K)
  return(list(whitener=t(ginv(svd.x$v%*%diag(svd.x$d[1:n.comp])/sqrt(n.rep-1))),Z=sqrt(n.rep-1)*svd.x$u,mean=apply(X,2,mean)))
}

###############################################################
# Auxillary functions taken from other people
##############################################################

# Original function by Yunfeng Zhang - calculate the power of a matrix
#' Calculate the power of a square matrix
#'
#' returns a matrix composed of eigenvector x diag(eigenvalue ^ power) x eigenvector'
#' @param S a square matrix
#' @param power the times of power
#'
#' @return a matrix after power calculation that eigenvector x diag(eigenvalue ^ power) x eigenvector'
#' @export
#'
#' @examples a <- matrix(1:9,3,3)
#' a %^% 2
#'
"%^%" <- function(S, power){
  out = eigen(S)
  nonzero = which(out$values > 1e-8)
  out$vectors[,nonzero] %*% (out$values[nonzero]^power * t(out$vectors[,nonzero]))  # which equals to out$vectors[,nonzero] %*% (diag(out$values[nonzero]^power) %*% t(out$vectors[,nonzero]))
}

#######################################################
# Objective functions - to monitor the convergence
####################################################
# Function that calculates JB
#' JB score calculate
#'
#' @param U U matrix for matched columns rj x n
#' @param X whitened data matrix n x px, data = whitenerXA \%*\% dXcentered
#' @param alpha default = 0.8
#'
#' @return the sum of JB score for each component, the row of Sj.
#' @export
#'
calculateJB <- function(U, X, alpha = 0.8){
  # Calculate u^{top}X for each u_l and Xj, this is UX
  UX = U %*% X # Sx matrix with rx x p, Sx = Ux * Lx * Xc, in which X = Lx * Xc.
  p = ncol(X)
  # Calculate all individual components
  gamma = rowMeans(UX^3) # length r
  kappa = rowMeans(UX^4 - 3) # length r

  # TU must be r by n
  JB = sum(alpha*gamma^2 + (1-alpha)*kappa^2)

  return(JB)
}

# Separate function for chordal distance of two vectors
chordal <- function(x, y){
  sum((tcrossprod(x)/sum(x^2) - tcrossprod(y)/sum(y^2))^2)
}

############
# BRisk: returns 4/5 of Jin's function
calculateJBofS <- function(S, alpha = 0.8){
  p = ncol(S)
  if (p < nrow(S)) warning("S should be r x p")
  # Calculate all individual components
  gamma = rowMeans(S^3) # length r
  kappa = rowMeans(S^4 - 3) # length r

  JB = sum(alpha*gamma^2 + (1-alpha)*kappa^2)

  return(JB)
}

#' Sign change for S matrix to image
#'
#' @param S t(S) px x r.
#' @param M another matrix.
#'
#' @return newS the original S * signskew, which is mean(S.column^3)
#' @export
#'
signchange = function(S,M=NULL) {
  # S: 59,412 x r_J
  signskew = sign(apply(S,2,function(x) mean(x^3)))
  newS = signskew*S          # t(signskew*t(S))
  if(!is.null(M)) newM = t(signskew*t(M))
  ifelse(is.null(M),return(newS),return(list(S=newS,M=newM)))
}

###############
# logistic <- function(xData, scale=sqrt(3)/pi, df=0) {
#   #maximizes likelihood given s then calculates gradient w.r.t. w.hat
#   #df is not used
#   xData = as.vector(xData)
#   list(Gs = -xData/scale - log(scale) - 2*log(1+exp(-xData/scale)), gs = -1/scale + 2*exp(-xData/scale)/(scale*(1+exp(-xData/scale))), gps = (2*exp(-2*xData/scale) - 2*exp(-xData/scale)*(1+exp(-xData/scale))) / (scale^2*(1+exp(-xData/scale))^2))
# }

logistic <- function(xData, scale=sqrt(3)/pi, df=0) {
  #maximizes likelihood given s then calculates gradient w.r.t. w.hat
  #df is not used
  xData = as.vector(xData)
  list(Gs = -xData/scale - log(scale) - 2*log(1+exp(-xData/scale)), gs = -1/scale + 2*exp(-xData/scale)/(scale*(1+exp(-xData/scale))), gps = - 2*exp(-xData/scale) / (scale^2*(1+exp(-xData/scale))^2))
}

jb.stat <- function(x, df=0) {
  n <- length(x)
  s <- sum(x^3)
  k <- sum(x^4)
  Gs <- x^3 * s / n^2 + (x^4 * k / n^2 + 9 / n - 6 * x^4 / n) / 4
  gs <- 6 * x^2 * s / n^2 + (8 * x^3 * (k / n - 3) / n) / 4
  gps <- 6 * (3 * x^4 + 2 * x * s) / n^2 + (24 * x^2 * (k / n - 3) / n + 32 * x^6 / n^2) / 4
  list(Gs = Gs, gs = gs, gps = gps)
}

tiltedgaussian = function (xData, df = 8, B = 100, ...) {
  #This function is based on ProDenICA::GPois by Trevor Hastie
  #NOTE: Assumes data are zero mean.

  n <- length(xData)
  sd.x = sd(xData)
  rx <- c(min(xData)-0.1*sd.x, max(xData)+0.1*sd.x)
  xg <- seq(from = rx[1], to = rx[2], length = B)
  gaps <- diff(rx)/(B - 1)
  xcuts <- c(rx[1] - gaps/2, xg[-B] + gaps/2, rx[2] + gaps/2)
  #NOTE: I use the response variable that corresponds to the LCA paper.
  #This differs from the GPois algorithm in ProDenICA
  ys <- as.vector(table(cut(xData, xcuts)))/(gaps*n)
  pois.fit <- suppressWarnings(gam(ys ~ s(xg, df)+offset(dnorm(xg,log=TRUE)), family = poisson, ...))
  Gs <- predict(pois.fit) #log tilt function predicted at grid locations (note: predict on gam object can not be used to obtain derivatives)
  # the gam object with the predict function can not be used directly to obtain the derivatives
  # of the smoothing spline.
  # Here, we refit another iteration of the IRWLS algorithm used in gam:
  # Note: working residuals = (y - mu0)/mu0
  # weights = mu0
  # fitted(pois.fit) = mu0
  # predict(pois.fit) = eta0 = log(mu0)
  sGs = Gs #+ log(sum(dnorm(xg))/sum(fitted(pois.fit)))
  z0 <- sGs + residuals(pois.fit, type='working')
  pois.refit <- smooth.spline(x=xg, y=z0, w=fitted(pois.fit),df=df) #obtain the log tilt function in an object that can be used to obtain derivatives
  Gs <- predict(pois.refit, xData, deriv = 0)$y
  gs <- predict(pois.refit, xData, deriv = 1)$y
  gps <- predict(pois.refit, xData, deriv = 2)$y
  fGs <- function(x) predict(pois.refit,x,deriv=0)$y
  fgs <- function(x) predict(pois.refit,x,deriv=1)$y
  fgps <- function(x) predict(pois.refit,x,deriv=2)$y
  list(Gs = Gs, gs = gs, gps = gps, fGs = fGs, fgs=fgs, fgps=fgps)
}
#---------------------------------------------


#install package FuzzyR if not already installed
if(!require(FuzzyR)){
  install.packages("FuzzyR")
  library(FuzzyR)
}
#criar objeto first
fis= newfis("study")

#adicionar as variaveis de entrada e saida
fis= addvar(fis, 'input', 'conhecimento previo', c(0,25))
fis= addvar(fis, 'input', 'dificuldade', c(0,25))
fis= addvar(fis, 'input', 'dificuldade para colar', c(0,25))
fis= addvar(fis, 'output', 'horas de antecedencia para estudar', c(0,25))

#adicionar as funcoes de pertinencia
fis= addmf(fis, 'input', 1, 'zerado', 'gaussmf', c(3,3))
fis= addmf(fis, 'input', 1, 'mais ou menos', 'gaussmf', c(3,13))
fis= addmf(fis, 'input', 1, 'expert', 'gaussmf', c(3,19))

fis= addmf(fis, 'input', 2, 'facil', 'trapmf', c(0,0,4,7))
fis= addmf(fis, 'input', 2, 'mais ou menos', 'trapmf', c(5, 7, 11, 15))
fis= addmf(fis, 'input', 2, 'dificil', 'trapmf', c(10,16,21,25))

fis= addmf(fis, 'input', 3, 'facil', 'trimf', c(0, 6, 9))
fis= addmf(fis, 'input', 3, 'mais ou menos', 'trimf', c(8, 13, 18))
fis= addmf(fis, 'input', 3, 'dificil', 'trimf', c(17, 20, 25))

fis= addmf(fis, 'output', 1, 'durante a prova', 'trapmf', c(0, 0, 6, 12))
fis= addmf(fis, 'output', 1, 'noite anterior', 'gaussmf', c(3, 12))
fis= addmf(fis, 'output', 1, 'cedo', 'trimf', c(15, 20, 25))

#columns:
# 1st -> first input variable
# 2nd -> second input variable
# 3rd -> thrid input variable
# 4th -> output variable
# 5th -> weigth of the rule
# 6th -> 1 for AND, 2 for OR

rules= rbind(c(3, 1, 0, 1, 1, 1),
             c(3, 2, 0, 2, 1, 1),
             c(3, 3, 0, 2, 1, 1),
             c(0, 1, 1, 1, 1, 1),
             c(0, 2, 1, 1, 1, 1),
             c(0, 3, 1, 2, 1, 1),
             c(1, 3, 0, 3, 1, 1),
             c(2, 3, 0, 3, 1, 1),
             c(0, 1, 3, 2, 1, 1),
             c(0, 3, 2, 3, 1, 1),
             c(0, 2, 2, 3, 1, 1),
             c(0, 1, 2, 2, 1, 1),
             c(0, 3, 1, 2, 1, 1),
             c(0, 2, 1, 2, 1, 1))

#adicionar regras ao objeto
fis= addrule(fis, rules)
showrule(fis)

#plot das funcoes de pertinencia
png('mf1.png')
plotmf(fis, 'input', 1)
dev.off()

png('mf2.png')
plotmf(fis, 'input', 2)
dev.off()

png('mf3.png')
plotmf(fis, 'input', 3)
dev.off()

png('out1.png')
plotmf(fis, 'output', 1)
dev.off()

#Interface grafica da biblioteca
showGUI(fis)


one_of_n <- function(n)
{
  choice <- 1L

  for (i in 2:n)
  {
    if (i*runif(1) < 1)
      choice <- i
  }

  return(choice)
}

table(sapply(1:1000000, function(i) one_of_n(10)))


library(MASS)

donne <- 8
uomini <- 10

donne_elette <- 2
uomini_eletti <- 2

domanda_2 <- 3
domanda_3 <- 3
domanda_4_uomini <- 1
domanda_4_donne <- 1

print(fractions(choose(donne,donne_elette)*choose(uomini, uomini_eletti)))
print(fractions(choose(donne,donne_elette)*(choose(uomini-domanda_2,uomini_eletti)
               +domanda_2*choose(uomini-domanda_2,uomini_eletti-1))))
print(fractions(choose(uomini,uomini_eletti)*(choose(donne-domanda_3,donne_elette)
               +domanda_3*choose(donne-domanda_3,donne_elette-1))))
print(fractions(choose(uomini-domanda_4_uomini,uomini_eletti)*choose(donne-domanda_4_donne,donne_elette)
               +choose(uomini-domanda_4_uomini,uomini_eletti)*choose(donne-domanda_4_donne,donne_elette-domanda_4_donne)
               +choose(uomini-domanda_4_uomini,uomini_eletti-domanda_4_uomini)*choose(donne-domanda_4_donne,donne_elette)))


library(epimdr)
library(deSolve)

data(paili)
data(palymes)
data(pagiard)
data(pameasle)

ppp <- function(wk, x){
    require(plotrix)
    x = x[wk<53]
    wk = wk[wk<53]
    ses = sapply(split(x, wk), mean, na.rm = TRUE)
    sesdv = sapply(split(x, wk), sd, na.rm = TRUE)/sqrt(length(split(x, wk)))
    plotCI(x = c(1:52), y = ses, ui = ses+sesdv, li = ses-sesdv, xlab = "Week", ylab = "Incidence")
}

par(mfrow = c(2, 2))  #A four panel plot
ppp(paili[, "WEEK"], paili[, "PENNSYLVANIA"])
title("ILI mortality (1972-98)")
ppp(palymes[, "WEEK"], palymes[, "PENNSYLVANIA"])
title("Lymes (2006-14)")
ppp(pagiard[, "WEEK"], pagiard[, "PENNSYLVANIA"])
title("Giardia (2006-14)")
ppp(pameasle[, "WEEK"], pameasle[, "PENNSYLVANIA"])
title("Measles (1928-69)")

seirmod = function(t, y, parms) {
    S = y[1]
    E = y[2]
    I = y[3]
    R = y[4]

    mu = parms["mu"]
    N = parms["N"]
    beta = parms["beta"]
    sigma = parms["sigma"]
    gamma = parms["gamma"]

    dS = mu * (N - S) - beta * S * I/N
    dE = beta * S * I/N - (mu + sigma) * E
    dI = sigma * E - (mu + gamma) * I
    dR = gamma * I - mu * R
    res = c(dS, dE, dI, dR)
    list(res)
}

times  = seq(0, 10, by=1/120)
paras  = c(mu = 1/50, N = 1, beta =  1000,
     sigma = 365/8, gamma = 365/5)
start = c(S = 0.06, E = 0, I = 0.001, R = 0.939)

R0 = expression(sigma/(sigma + mu) * beta/(gamma + mu))
with(as.list(paras), eval(R0))

out = as.data.frame(ode(start, times, seirmod, paras))
par(mfrow = c(1,2))  #Two plots side by side
plot(times, out$I, ylab = "Prevalence",
     xlab = "Time", type = "l")
plot(out$S, out$I, ylab = "Prevalence",
     xlab = "Susceptible", type = "l")

seirmod2 = function(t, y, parms){
  S = y[1]
  E = y[2]
  I = y[3]
  R = y[4]
  with(as.list(parms),{
     dS = mu * (N  - S)  - beta0 * (1+beta1 *
        cos(2 * pi * t)) * S * I / N
     dE = beta0 * (1 + beta1 * cos(2*pi * t)) *
        S * I / N - (mu + sigma) * E
     dI = sigma * E - (mu + gamma) * I
     dR = gamma * I - mu * R
     res = c(dS, dE, dI, dR)
     list(res)
   })
}

times  = seq(0, 100, by=1/120)
paras  = c(mu = 1/50, N = 1, beta0 = 1000, beta1 = 0.2,
     sigma = 365/8, gamma = 365/5)
start = c(S = 0.06, E = 0, I = 0.001, R = 0.939)
out = as.data.frame(ode(start, times, seirmod2, paras))
par(mfrow = c(1,2)) #Side-by-side plot
plot(times, out$I, ylab="Infected", xlab="Time",
     xlim = c(90, 100), ylim = c(0,
     max(out$I[11001:12000])), type = "l")
plot(out$S[11001:12000], out$I[11001:12000],
     ylab = "Infected", xlab = "Susceptible", type = "l")

mu = paras["mu"]
N = paras["N"]
beta0 = paras["beta0"]
beta1 = paras["beta1"]
sigma = paras["sigma"]
gamma = paras["gamma"]
R0 = sigma/(sigma + mu) * beta0/(gamma + mu)
# Equilibria
Sstar = 1/R0
Istar = mu * (1 - 1/R0) * R0/beta0
Estar = (mu + gamma) * Istar/sigma
eq = list(S = Sstar, E = Estar, I = Istar)

dS = expression(mu * (N  - S)  - beta0 * S * I / N)
dE = expression(beta0 * S * I / N - (mu + sigma) * E)
dI = expression(sigma*E - (mu + gamma) * I)
#Elements of Jacobian
j11 = D(dS, "S");  j12 = D(dS, "E");  j13 = D(dS, "I")
j21 = D(dE, "S");  j22 = D(dE, "E");  j23 = D(dE, "I")
j31 = D(dI, "S");  j32 = D(dI, "E"); j33 = D(dI, "I")
#Jacobian
J = with(eq,
matrix(c(eval(j11),eval(j12),eval(j13),
   eval(j21),eval(j22), eval(j23),
   eval(j31),eval(j32), eval(j33)),
    nrow=3, byrow=TRUE))

round(eigen(J)$values, 3)
2 * pi/(Im(eigen(J)$values[2]))

times = seq(0, 100, by = 1/120)
start = c(S = 0.06, E = 0, I = 0.001, R = 0.939)
beta1 = seq(0,0.25, length=101)
#Matrix to store infecteds
Imat = matrix(NA, ncol = 12001, nrow = 101)
#Loop over beta1's
for(i in 1:101){
     paras  = c(mu = 1/50, N = 1, beta0 = 1000,
        beta1 = beta1[i], sigma = 365/8, gamma = 365/5)
     out = as.data.frame(ode(start, times,
        seirmod2, paras))
     Imat[i,] = out$I
}

sel = seq(7001, 12000, by = 120)
plot(NA, xlim = range(beta1), ylim = c(1E-7,
     max(Imat[,sel])), log = "y", xlab = "beta1",
     ylab = "prevalence")
for(i in 1:101){
       points(rep(beta1[i], length(sel)),
          Imat[i, sel], pch=20)
}

times = seq(0, 100000, by = 1/120)
start = c(S = 0.06, E = 0, I = 0.001, R = 0.939)
paras  = c(mu = 1/50, N = 1, beta0 = 1800, beta1=0.28,
     sigma = 35.84, gamma = 100)
out = as.data.frame(ode(start, times,seirmod2, paras))
sel = seq(7001, 12000000, by = 120)
par(mfrow = c(1,2))
plot(out$time[7001:13001], out$I[7001:13001],
     type = "l", xlab = "Year", ylab = "Prevalence")
plot(out$S[sel], out$I[sel], type = "p", xlab = "S",
     ylab = "I", log = "y", pch = 20, cex = 0.25)

times = seq(0, 100, by = 1/120)
start = c(S = 0.06, E = 0, I = 0.001, R = 0.939)
mu = seq(from = 0.005, to = 0.02, length = 101)
ImatF = ImatB = matrix(NA, ncol = 12001, nrow = 101)
for(i in 1:101){
     paras  = c(mu = mu[i], N = 1, beta0 = 2500,
          beta1=0.12, sigma = 365/8, gamma = 365/5)
      out = as.data.frame(ode(start, times, seirmod2,
           paras))
      ImatF[i,] = out$I
      start = c(S = out$S[12001], E = out$E[12001],
           I = out$I[12001], R = out$R[12001])
}
start = c(S = 0.06, E = 0, I = 0.001, R = 0.939)
for(i in 101:1){
     paras  = c(mu = mu[i], N = 1, beta0 = 2500,
          beta1 = 0.12, sigma = 365/8, gamma = 365/5)
     out = as.data.frame(ode(start, times, seirmod2,
          paras))
     ImatB[i,] = out$I
     start = c(S = out$S[12001], E = out$E[12001],
          I = out$I[12001], R = out$R[12001])
}
sel = seq(7001, 12000, by = 120)
par(mfrow = c(1,1))
     plot(NA, xlim = range(mu),  ylim = range(ImatF[,sel]),
          log = "y", xlab = "mu", ylab = "prevalence")
for(i in 1:101){
     points(rep(mu[i], dim(ImatF)[2]), ImatF[i, ],
          pch = 20, cex = 0.25)
     points(rep(mu[i], dim(ImatB)[2]), ImatB[i, ],
          pch = 20, cex = 0.25, col = 2)
 }


# 4. faza: Analiza podatkov

tabelazaanalizo <- tabela2 %>%
  filter(regija=="SLOVENIJA")
samopike <- ggplot(tabelazaanalizo, aes(x=leto, y=vrednost)) + geom_point()
model <- lm(vrednost ~ leto, data=tabelazaanalizo)
napoved <- ggplot(tabelazaanalizo, aes(x=leto, y=vrednost)) + geom_point() +
          geom_smooth(method=lm, formula=y~x) +
          ylab("Dobavljena voda na prebivalca v m^3")

prihodnjaleta <- data.frame(leto=c(2020:2025))
predict(model, prihodnjaleta)
napoved1 <- prihodnjaleta %>% mutate(vrednost=predict(model, prihodnjaleta))
napoved1$vrednost <- round(napoved1$vrednost, digit=1)
napoved2 <- rbind(tabelazaanalizo[,-1], napoved1)

izrisnapovedi <- ggplot(napoved2, aes(x=leto, y=vrednost)) +
  geom_point(shape=1) +
  geom_smooth(method=lm, formula=y~x) +
  geom_point(data=napoved1, aes(x=leto, y=vrednost), color="red", size=2) +
  xlab("Leto") +
  ylab("Dobavljena voda v m^3 na prebivalca")


# Compute likelihood of trees according to generative model and parameters
# author: Alberto Lumbreras
###########################################################################

library(dplyr)
library(data.table)
library(igraph)
# Compute degrees only once for all trees (3-dimensional array: node, time, tree)
#all.degrees <- list()
#for (i in 1:length(trees)){
#  parents <- get.edgelist(trees[[i]])[,2]
#  size <- length(parents)+1
#  all.degrees[[i]] <- t(sapply(2:size, function(t) tabulate(parents[1:t], nbins=size)))
#}

likelihood.Gomez2013 <- function(trees, alpha=1, beta = 1, tau = 0.75){
  # Compute the likelihood of the whole set of trees
  # Arguments:
  #   trees: observed list of trees
  #   alpha.root, alpha.c, beta.root: parameters of the model
  like <- 0
  for (i in 1:length(trees)){
    g <- trees[[i]]
    parents <- get.edgelist(g)[,2] # parents vector

    # skip root and first post
    for(t in 2:length(parents)){
      b <- rep(0,t)
      b[1] <- beta
      lags <- t:1
      popularities <- 1 + tabulate(parents[1:(t-1)], nbins=t)
      popularities[1] <- popularities[1] - 1 # root has no parent
      probs <- alpha*popularities + b + tau^lags
      probs <- probs/sum(probs)
      like <- like + log(probs[parents[t]])
    }
  }
  like
}

# Likelihood computation using the dataframe
likelihood.post <- function(row, alpha, beta, tau){
  log(alpha * row['popularity'] + beta*(row['parent']==1) + tau^row['lag']) -
  log(2*alpha*(row['t']-1/2)   + beta + tau*(tau^row['t']-1)/(tau-1))
  # -1/2 because root has at least degree 1 (to follow Gomez 2013)
  # if the root starts with degree 0, then it should be:
  # log(2*alpha*(row['t']-1)   + beta + tau*(tau^row['t']-1)/(tau-1))
}

likelihood.Gomez2013.df <- function(df.trees, alpha = 1, beta = 1, tau = 0.75){
  # Likelihood using dataframe instead of list of trees
  sum(apply(df.trees, 1, likelihood.post, alpha, beta, tau))
}

likelihood.Lumbreras2016.users <- function(df.trees, users, alpha, beta, tau){
  # Compute the likelihood of the user posts given the parameters alpha, beta and tau
  mask <- df.trees$user %in% users
  sum(apply(df.trees[mask,], 1, likelihood.post, alpha, beta, tau))
}

if(FALSE){

  alpha <- 1 # 1
  beta <- 0.68 # 0.68
  tau <- 0.75 # 0.75

  # Classic
  like <- likelihood.Gomez2013(trees, alpha = alpha, beta = beta, tau = tau)
  cat('\n alpha: ', alpha)
  cat('\n beta: ', beta)
  cat('\n tau:', tau)
  cat('\n Total likelihood: ', like)

  # Using preprocessed dataframes
  df.trees_ <- filter(df.trees, t>1)
  like <- likelihood.Gomez2013.df(df.trees_, alpha = alpha, beta = beta, tau = tau)
  cat('\n alpha: ', alpha)
  cat('\n beta: ', beta)
  cat('\n tau:', tau)
  cat('\n Total likelihood: ', like)

  # Using preprocessed dataframes + cluster by cluster
  alphas <- c(1,2)
  betas <- c(0.68,0.75)
  taus <- c(0.75, 0.75)
  users <- unique(df.trees$user)
  z <- c(1,1)

  # this is parallelizable
  like <- 0
  z.nonempty <- unique(z)
  for (i in 1:length(z.nonempty)){
    like <- like + likelihood.Lumbreras2016.users(df.trees_,
                                                  which(z==z.nonempty[i]),
                                                  alphas[z.nonempty[i]],
                                                  betas[z.nonempty[i]],
                                                  taus[z.nonempty[i]])
  }
  cat('\n Total likelihood: ', like)

  library(rbenchmark)
  benchmark(likelihood.Gomez2013(trees, alpha = alpha, beta = beta, tau = tau),
            likelihood.Gomez2013.df(df.trees_, alpha = alpha, beta = beta, tau = tau),
            likelihood.Lumbreras2016.users(df.trees_,
                                           which(z==z.nonempty[1]),
                                           alphas[z.nonempty[1]],
                                           betas[z.nonempty[1]],
                                           taus[z.nonempty[1]]))

}


rotate <- function(x,xAxisTo=0,Center=c(0,0),Angle=xAxisTo-90,nms=c("x","y")){
	ang <- -Angle/180
	ctr <- Center
	UseMethod("rotate",x)
}
rotate.default <- function(x,xAxisTo=0,Center=c(0,0),Angle=xAxisTo-90,nms=c("x","y")){
	if(!is.numeric(nms)){
		nms <- match(nms,names(x),nomatch=0)
		nms[!nms] <- (c(1,2) %w/o% nms)[seq_len(sum(nms==0))]
	}
	x[[nms[1]]] <- x[[nms[1]]] - ctr[1]
	x[[nms[2]]] <- x[[nms[2]]] - ctr[2]
	out <- x
	out[[nms[1]]] <- x[[nms[1]]] * cospi(ang) - x[[nms[2]]] * sinpi(ang)  + ctr[1]
	out[[nms[2]]] <- x[[nms[1]]] * sinpi(ang) + x[[nms[2]]] * cospi(ang)  + ctr[2]
	return(out)
}
rotate.matrix <- function(x,xAxisTo=0,Center=c(0,0),Angle=xAxisTo-90,nms=c("x","y")){
	if(!is.numeric(nms)){
		nms <- match(nms,colnames(x),nomatch=0)
		nms[!nms] <- (c(1,2) %w/o% nms)[seq_len(sum(nms==0))]
	}
	x[,nms[1]] <- x[,nms[1]] - ctr[1]
	x[,nms[2]] <- x[,nms[2]] - ctr[2]
	out <- x
	out[,nms[1]] <- x[,nms[1]] * cospi(ang) - x[,nms[2]] * sinpi(ang)  + ctr[1]
	out[,nms[2]] <- x[,nms[1]] * sinpi(ang) + x[,nms[2]] * cospi(ang)  + ctr[2]
	return(out)
}
rotate.data.table <- function(x,xAxisTo=0,Center=c(0,0),Angle=xAxisTo-90,nms=c("x","y")){
	if(is.numeric(nms)){
		nms <- names(x)[nms]
	}
	xnms <- x[,.(
		nms1 = get(nms[1]) - ctr[1]
		,nms2 = get(nms[2]) - ctr[2]
		)]
	x[,nms[1] := xnms[,nms1] * cospi(ang) - xnms[,nms2] * sinpi(ang)  + ctr[1],with=FALSE]
	x[,nms[2] := xnms[,nms1] * sinpi(ang) + xnms[,nms2] * cospi(ang)  + ctr[2],with=FALSE]
	invisible(x)
}


#' @title
#' Select ranks with information criterion
#'
#' @description
#' This function selects the optimal ranks \code{(r, rx, ry)} using a user-specified
#' information criterion. The degrees of freedom is estimated by the number of
#' free parameters in the model. The blockwise coordinate descent algorithm is used to fit
#' the model with any combinations of \code{(r, rx, ry)}.
#'
#' @usage
#' NRRR.ic(Y, X, Ag0 = NULL, Bg0 = NULL,
#'         jx, jy, p, d, n, maxiter = 300, conv = 1e-4,
#'         method = c('RRR','RRS')[1],
#'         lambda = 0, ic = c("BIC","BICP","AIC","GCV")[1],
#'         dimred = c(TRUE,TRUE,TRUE), rankfix = NULL,
#'         xrankfix = NULL, yrankfix = NULL,
#'         lang = c('R', 'Rcpp')[1])
#'
#' @param Y response matrix of dimension n-by-jy*d.
#' @param X design matrix of dimension n-by-jx*p.
#' @param Ag0 an initial estimator of matrix U. If \code{Ag0 = NULL} then generate it
#'            by \code{\link{NRRR.ini}}. Default is NULL. If \code{lang = 'Rcpp'},
#'            then \code{Ag0} is automatically generated by \code{\link{NRRR.ini}}.
#' @param Bg0 an initial estimator of matrix V, if \code{Bg0 = NULL} then generate it
#'            by \code{\link{NRRR.ini}}. Default is NULL. If \code{lang = 'Rcpp'},
#'            then \code{Bg0} is automatically generated by \code{\link{NRRR.ini}}.
#' @param jx number of basis functions to expand the functional predictor.
#' @param jy number of basis functions to expand the functional response.
#' @param p number of predictors.
#' @param d number of responses.
#' @param n sample size.
#' @param maxiter the maximum iteration number of the
#'                blockwise coordinate descent algorithm. Default is 300.
#' @param conv the tolerance level used to control the convergence of the
#'             blockwise coordinate descent algorithm. Default is 1e-4.
# @param quietly a logical value with two options. FALSE (default): show the
#                rank selection process; TRUE: do not show the process. If
#                \code{lang = 'Rcpp'}, then \code{quietly} is automatically
#                set to TRUE.
#' @param method 'RRR' (default): no additional ridge penalty; 'RRS': add an
#'               additional ridge penalty.
#' @param lambda the tuning parameter to control the amount of ridge
#'               penalization. It is only used when \code{method = 'RRS'}.
#'               Default is 0.
#' @param ic the user-specified information criterion. Four options are available,
#'           i.e., BIC, BICP, AIC, GCV.
#' @param dimred a vector of logical values to decide whether to use the selected information criterion
#'               do rank selection on certain dimensions. TRUE means the rank is selected
#'               by the selected information criterion. If \code{dimred[1] = FALSE}, r is
#'               provided by \code{rankfix} or \eqn{min(jy*d, rank(X))};
#'               If \code{dimred[2] = FALSE}, rx equals to \code{xrankfix} or p; If \code{dimred[3] = FALSE},
#'               ry equals to \code{yrankfix} or d. Default is \code{c(TRUE, TRUE, TRUE)}.
#' @param rankfix a user-provided value of r when \code{dimred[1] = FALSE}. Default is NULL
#'                which leads to \eqn{r = min(jy*d, rank(X))}.
#' @param xrankfix a user-provided value of rx when \code{dimred[2] = FALSE}. Default is NULL
#'                 which leads to \code{rx = p}.
#' @param yrankfix a user-provided value of ry when \code{dimred[3] = FALSE}. Default is NULL
#'                 which leads to \code{ry = d}.
#' @param lang 'R' (default): the R version function is used; 'Rcpp': the Rcpp
#'             version function is used.
#' @return The function returns a list:
#'   \item{Ag}{the estimated U.}
#'   \item{Bg}{the estimated V.}
#'   \item{Al}{the estimated A.}
#'   \item{Bl}{the estimated B.}
#'   \item{C}{the estimated coefficient matrix C.}
#'   \item{df}{the estimated degrees of freedom of the NRRR model.}
#'   \item{sse}{the sum of squared errors of the selected model.}
#'   \item{ic}{a vector containing values of BIC, BICP, AIC, GCV of the selected model.}
#'   \item{rank}{the estimated r.}
#'   \item{rx}{the estimated rx.}
#'   \item{ry}{the estimated ry.}
#'
#'
#' @details
#' Denote \eqn{\hat C(r, rx, ry)} as the estimator of the coefficient matrix
#' with the rank values fixed at some \eqn{(r, rx, ry)} and write the sum of
#' squared errors as \eqn{SSE(r, rx, ry)=||Y - X\hat C(r, rx, ry)||_F^2}. We
#' define
#' \deqn{BIC(r, rx, ry) = n*d*jy*log(SSE(r, rx, ry)/(n*d*jy)) + log(n*d*jy)*df(r, rx, ry),}
#' where \eqn{df(r, rx, ry)} is the effective degrees of freedom and is estimated
#' by the number of free parameters
#' \deqn{\hat df(r, rx, ry) = rx*(rank(X)/jx - rx) + ry*(d - ry) + (jy*ry + jx*rx - r)*r.}
#' We can define other information criteria in a similar way. With the defined BIC,
#' a three-dimensional grid search procedure of the rank
#' values is performed, and the best model is chosen as the one with the
#' smallest BIC value. Instead of a nested rank selection method, we apply a
#' one-at-a-time selection approach. We first set \eqn{rx = p, ry = d}, and
#' select the best local rank \eqn{\hat r} among the models with
#' \eqn{1 \le r \le min(rank(X), jy*d)}. We then fix the local rank at
#' \eqn{\hat r} and repeat a similar procedure to determine \eqn{\hat rx}
#' and \eqn{\hat ry}, one at a time. Finally, with fixed \eqn{\hat rx} and \eqn{\hat ry},
#' we refine the estimation of r.
#'
#'
#' @references Liu, X., Ma, S., & Chen, K. (2020).
#' Multivariate Functional Regression via Nested Reduced-Rank Regularization.
#' arXiv: Methodology.
# @importFrom rrpack cv.rrr
#' @export
#' @examples
#' library(NRRR)
#' set.seed(3)
#' # Simulation setting 2 in NRRR paper
#' simDat <- NRRR.sim(n = 100, ns = 100, nt = 100, r = 3, rx = 3, ry = 3,
#'                    jx = 8, jy = 8, p = 20, d = 20, s2n = 1, rho_X = 0.5,
#'                    rho_E = 0, Sigma = "CorrAR")
#' # using R function
#' fit_R <- with(simDat, NRRR.ic(Yest, Xest, Ag0 = NULL, Bg0 = NULL,
#'               jx = 8, jy = 8, p = 20, d = 20, n = 100,
#'               maxiter = 300, conv = 1e-4, method = c("RRR", "RRS")[1],
#'               lambda = 0, ic = c("BIC", "BICP", "AIC", "GCV")[1],
#'               dimred = c(TRUE, TRUE, TRUE), rankfix = NULL,
#'               xrankfix = NULL, yrankfix = NULL,
#'               lang=c('R','Rcpp')[1]))
#' # using Rcpp function
#' fit_Rcpp <- with(simDat, NRRR.ic(Yest, Xest, Ag0 = NULL, Bg0 = NULL,
#'                  jx = 8, jy = 8, p = 20, d = 20, n = 100,
#'                  maxiter = 300, conv = 1e-4, method = c("RRR", "RRS")[1],
#'                  lambda = 0, ic = c("BIC", "BICP", "AIC", "GCV")[1],
#'                  dimred = c(TRUE, TRUE, TRUE), rankfix = NULL,
#'                  xrankfix = NULL, yrankfix = NULL,
#'                  lang=c('R','Rcpp')[2]))
NRRR.ic <- function(Y,X,Ag0=NULL,Bg0=NULL,
                    jx,jy,p,d,n,maxiter=300,conv=1e-4,
                    method=c('RRR','RRS')[1],
                    lambda=0,ic=c("BIC","BICP","AIC","GCV")[1],
                    dimred = c(TRUE,TRUE,TRUE),rankfix=NULL,
                    xrankfix=NULL, yrankfix=NULL,
                    lang=c('R','Rcpp')[1]
){
  #require(rrpack)
  if (method == "RRS" & lambda == 0) stop("A positive tuning parameter should be provided when 'RRS' is used.")
  if (!(ic %in% c("BIC","BICP","AIC","GCV"))) stop("A valid information criterion name should be provided.")
  if (!(lang %in% c('R','Rcpp'))) stop("Please choose from 'R' and 'Rcpp'")

  # compute rank(X)
  xr <- sum(svd(X)$d>1e-2)

  # initialize r
  if(dimred[1]){
    fitRRR <- cv.rrr(Y,X,nfold=10)
    rest <- fitRRR$rank
    # If zero fit
    if(rest==0){
      fitRRR <- RRR(Y,X,nrank=1)
      rest <- fitRRR$rank
    }
    # if(!quietly) {
    #   cat("Initial r   = ",rest, "\n",sep="")
    # }
  }else{
    rest <- ifelse(is.null(rankfix),min(ncol(Y),ncol(X),xr),rankfix)
  }
  rfit <- rest

  if (lang == "R"){
    # Select rx
    if(dimred[2]){
      rxfitseq <- 1:p
      ryfitseq <- rep(d,length(rxfitseq))

      icseq <- vector()
      for(i in 1:length(rxfitseq)){
        rxfit <- rxfitseq[i]
        ryfit <- ryfitseq[i]
        fit1 <- NRRR.est(Y,X,NULL,NULL,rini=rfit,rfit,rxfit,ryfit,jx,jy,p,
                         d,n,maxiter=maxiter,conv=conv,#quietly=TRUE,
                         method=method,lambda=lambda)
        icseq[i] <- switch(ic,'BIC'=fit1$ic[1],'BICP'=fit1$ic[2],
                           'AIC'=fit1$ic[3],'GCV'=fit1$ic[4])
      }
      rxest <- rxfitseq[which.min(icseq)]
    }else{
      #rxest <- p
      rxest <- ifelse(is.null(xrankfix),p,xrankfix)
    }
    rxfit <- rxest
    # if(!quietly) {
    #   cat("Selected rx = ",rxest, "\n",sep="")
    # }

    # Select ry
    if(dimred[3]){
      ryfitseq <- 1:d
      rxfitseq <- rep(rxest,length(ryfitseq))

      icseq <- vector()
      for(i in 1:length(rxfitseq)){
        rxfit <- rxfitseq[i]
        ryfit <- ryfitseq[i]
        fit1 <- NRRR.est(Y,X,NULL,NULL,rini=rfit,rfit,rxfit,ryfit,jx,jy,
                         p,d,n,maxiter=maxiter,conv=conv,#quietly=TRUE,
                         method=method,lambda=lambda)
        icseq[i] <- switch(ic,'BIC'=fit1$ic[1],'BICP'=fit1$ic[2],
                           'AIC'=fit1$ic[3],'GCV'=fit1$ic[4])
      }
      ryest <- ryfitseq[which.min(icseq)]
    }else{
      #ryest <- d
      ryest <- ifelse(is.null(yrankfix),d,yrankfix)
    }
    ryfit <- ryest
    # if(!quietly) {
    #   cat("Selected ry = ",ryest, "\n",sep="")
    # }

    # refine rank selection
    if(dimred[1]){
      rxfit <- rxest
      ryfit <- ryest
      icseq <- vector()
      # range of the possible rank
      rfitseq <- max(1,rest-5):min(rest+5,min(n,p*jx,d*jy))

      rfit <- rfitseq[1]
      fit <- NRRR.est(Y,X,NULL,NULL,rini=rfit,rfit,rxfit,ryfit,jx,jy,
                      p,d,n,maxiter=maxiter,conv=conv,#quietly=TRUE,
                      method=method,lambda=lambda)
      icseq[1] <- switch(ic,'BIC'=fit$ic[1],'BICP'=fit$ic[2],
                         'AIC'=fit$ic[3],'GCV'=fit$ic[4])
      icmin <- icseq[1]
      for(i in 2:length(rfitseq)){
        rfit <- rfitseq[i]
        fit1 <- NRRR.est(Y,X,NULL,NULL,rini=rfit,rfit,rxfit,ryfit,jx,jy,
                         p,d,n,maxiter=maxiter,conv=conv,#quietly=TRUE,
                         method=method,lambda=lambda)
        icseq[i] <- switch(ic,'BIC'=fit1$ic[1],'BICP'=fit1$ic[2],
                           'AIC'=fit1$ic[3],'GCV'=fit1$ic[4])
        if(icseq[i]<icmin){
          fit <- fit1
          icmin <- icseq[i]
        }
      }
      rest <- rfitseq[which.min(icseq)]
    }else{
      fit <- NRRR.est(Y,X,NULL,NULL,rini=rest,rest,rxfit,ryfit,jx,jy,
                      p,d,n,maxiter=maxiter,conv=conv,#quietly=TRUE,
                      method=method,lambda=lambda)
    }
    if (fit$iter == maxiter) stop("The algorithm reaches the maximum iteration.")

    return(list(Ag=fit$Ag,Bg=fit$Bg,Al=fit$Al,Bl=fit$Bl,C=fit$C,df=fit$df,
                sse=fit$sse,ic=fit$ic,#obj=fit$obj,
                rank=rest,rx=rxest,ry=ryest))
  } else {
    method <- ifelse(method == 'RRR', 1, 2)

    dimred1 <- ifelse(dimred[1],1,0)
    dimred2 <- ifelse(dimred[2],1,0)
    dimred3 <- ifelse(dimred[3],1,0)

    xrankfix <- ifelse(is.null(xrankfix),0,xrankfix)
    yrankfix <- ifelse(is.null(yrankfix),0,yrankfix)

    if (ic == 'BIC'){
      ic_num <- 0
    } else if (ic == 'BICP'){
      ic_num <- 1
    } else if (ic == 'AIC'){
      ic_num <- 2
    } else {
      ic_num <- 3
    }

    fit <- nrrr_select_my(Y, X, xr, rfit, xrankfix, yrankfix, jx, jy, p, d, n, ic_num, maxiter, conv,
                          method, lambda, dimred1, dimred2, dimred3)
    if( sum(fit$rxErrseq)>0 | sum(fit$ryErrseq)>0 | sum(fit$rErrseq)>0 ) stop('Error occurs or the algorithm reaches the maximum iteration')

    return(list(Ag=fit$Ag,Bg=fit$Bg,Al=fit$Al,Bl=fit$Bl,C=fit$C,df=fit$df,
                sse=fit$sse,ic=fit$ic,#obj=fit$obj,
                rank=fit$rank,rx=fit$rx,ry=fit$ry
                #,rxErrseq=fit$rxErrseq,ryErrseq=fit$ryErrseq,rErrseq=fit$rErrseq
                ))
  }
}


### kClass: Generates k-class estimators (point est, se, p-value, and confint)
###         Must run ivmodel before you run this code
### INPUT: ivmodel, an object from ivmodel() function
###        k, a vector (or scalar) of k values for estimation
###        beta0, a scalar null value for testing and p-values
###        alpha, significance level for confidence intervals
###        heteroSE, use heteroscedastic robust standard errors?
###        clusterID, if cluster-robust standard errors are desired, please provide a vector of
###                   length that's identical to the sample size.
###                   For example, if n = 6 and clusterID = c(1,1,1,2,2,2),
###                   there would be two clusters where the first cluster
###                   is formed by the first three observations and the
###                   second cluster is formed by the last three observations
###                   clusterID can be numeric, character, or factor.
### OUTPUT: a list of point estimate, standard error, test statistic, and p-value
KClass = function(ivmodel,
                  beta0=0,alpha=0.05,k=c(0,1),
                  manyweakSE=FALSE,heteroSE=FALSE,clusterID=NULL) {
  # Error checking
  if(class(ivmodel) != "ivmodel") {
    print("You must supply an ivmodel class. Run ivmodel() and see ivmodel() function for details")
    return(NULL)
  }
  if(missing(k)) {
    print("You must specify a value for k")
    return(NULL)
  }

  # Extract objects from ivmodel
  Y= ivmodel$Y; D = ivmodel$D; Z = ivmodel$Z; ZXQR = ivmodel$ZXQR; p = ivmodel$p
  if(p == 0) W = D
  if(p > 0) W = cbind(D,ivmodel$X)
  degF = ivmodel$n - ivmodel$p - 1 # this looks strange, but it's from Wooldridge and Stock (2002)

  # Compute k-class estimator
  kPointEst = matrix(0,length(k),1+p) # First column is treatment effect, rest are exogeneous covariates estimates.
  kVarPointEst = matrix(0,length(k),1+p)
  kCILower = matrix(0,length(k),1+p)
  kCIUpper = matrix(0,length(k),1+p)

  for(i in 1:length(k)) {
    rankInverse = qrrank(qr(t(W) %*% W - k[i] * t(W) %*% qr.resid(ZXQR,W)))
    if(rankInverse < ncol(W)) stop("k is out-of-range; the matrix inversion in the k-class estimator will fail.")
    inverseMat = solve(t(W) %*% W - k[i] * t(W) %*% qr.resid(ZXQR,W))
    kPointEst[i,] = as.numeric(inverseMat %*% ( t(W) %*% Y - k[i] *t(W) %*% qr.resid(ZXQR,Y)))
    if(1 <= 0) { #k exceeds the maximum possible value
	    kVarPointEst[i,] = NA;
	    kCILower[i,] = c(NA,NA); kCIUpper[i,] = c(NA,NA);
    } else {
        if (manyweakSE && k[i] != 0) { ## From Hansen et al. (2008)
            udelta = as.numeric(Y - W %*% kPointEst[i,])
            sigmahat.sq = sum(udelta^2)/(ivmodel$n-ncol(W))
            alphatilde = sum( qr.fitted(ZXQR,udelta)^2)/sum(udelta^2)
            iotahat = qr.fitted(ZXQR,W)
            Xtilde = W - t(t(udelta)) %*% (t(udelta) %*% W) / sum(udelta^2)
            Vhat = qr.resid(ZXQR,Xtilde)
            Ptt = diag(W %*% solve(t(W) %*% W) %*% t(W))
            kappa = sum(Ptt^2)/ivmodel$L
            tauT = ivmodel$L / ivmodel$n

            H = t(W) %*% qr.fitted(ZXQR,W) - alphatilde * t(W) %*% W
            sigmaB = sigmahat.sq * ( (1-alphatilde)^2 * t(Xtilde) %*% qr.fitted(ZXQR,Xtilde) + alphatilde^2 *  t(Xtilde) %*% qr.resid(ZXQR,Xtilde))
            A_other = matrix(0,1,ncol(sigmaB))
            for(j in 1:ivmodel$n) {
              A_other = A_other + udelta[j]^2 * Vhat[j,,drop=FALSE] / ivmodel$n
            }
            A = matrix(0,nrow(sigmaB),ncol(sigmaB))
            B = matrix(0,nrow(sigmaB),ncol(sigmaB))
            for(j in 1:ivmodel$n) {
              A = A + (Ptt[j] - tauT) * (t(iotahat[j,,drop=FALSE]) %*% A_other)
              B = B + (udelta[j]^2 - sigmahat.sq) * (t(Vhat[j,,drop=FALSE]) %*% Vhat[j,,drop=FALSE])
            }
            B = ivmodel$L * (kappa - tauT) * B / (ivmodel$n*(1-2*tauT + kappa * tauT))
            Sigmahat = sigmaB + A + t(A) + B

            Hinv = solve(H)
            Lambdahat = Hinv  %*% Sigmahat %*% Hinv
            kVarPointEst[i,] = diag(Lambdahat)
            print("hello world")

        } else if (heteroSE || (manyweakSE &&k[i] == 0)) {
          inner = matrix(0,ncol(W),ncol(W))
          for(j in 1:length(Y)) {
            adjustVec = as.numeric(W[j,]) - as.numeric(k[i]*qr.resid(ZXQR,W)[j,])
            inner = inner + (Y[j] - sum(W[j,] * kPointEst[i,]))^2 * (t(t(adjustVec)) %*% t(adjustVec) )
          }
          kVarPointEst[i,] = diag(inverseMat %*% inner %*% inverseMat)
	      } else if(!is.null(clusterID)){
	  	    if(length(clusterID) != ivmodel$n) {
	  		    ### Missing problem here needs to be taken care of ###
	  		    print("Cluster ID vector is not the same length as the sample size")
	  		    return(NULL)
	  	    }
	  	    if(!is.character(clusterID) && !is.factor(clusterID) && !is.numeric(clusterID)) {
	  		    print("Cluster ID must be either a character vector, a factor vector, or a numeric vector")
	  		    return(NULL)
	  	    }
	  	    clusterID = as.factor(clusterID)
	  	    clusterID = as.numeric(clusterID)
	  	    nCluster <- length(unique(clusterID)); uniqueclusterID = unique(clusterID)
	  	    inner = matrix(0,ncol(W),ncol(W))
	  	    for(j in uniqueclusterID) {
	  	      clusterSame = which(clusterID == j)
	  	      innerC = rep(0,ncol(W))
	  	      for(t in clusterSame) {
	  	        innerC = innerC + (Y[t] - sum(W[t,] * kPointEst[i,])) *
	  	                      (as.numeric(W[t,]) - as.numeric(k[i]*qr.resid(ZXQR,W)[t,]))
	  	      }
	  	      inner = inner + t(t(innerC)) %*% t(innerC)
	  	    }
	  	    kVarPointEst[i,] = diag(inverseMat %*% inner %*% inverseMat)
	    }
	    else {
	      kVarPointEst[i,] = 1/degF * sum( (Y - W %*% kPointEst[i,])^2) * diag(inverseMat)
	    }
	  # Note that R's AER package uses the z-scores instead of the t distribution. They are basically the same as n gets large.
	    kCILower[i,] = kPointEst[i,] - qt(1-alpha/2,degF) * sqrt(kVarPointEst[i,])
	    kCIUpper[i,] = kPointEst[i,] + qt(1-alpha/2,degF) * sqrt(kVarPointEst[i,])

    }
  }

  # Compute test statistics
  kTestStat = (kPointEst - beta0)/sqrt(kVarPointEst)

  # Compute p-value
  kPValue = 2*(1 - pt(abs(kTestStat),degF))

  # Package output
  kPointEst_trt = matrix(kPointEst[,1],length(k),1)
  kVarPointEst_trt = matrix(sqrt(kVarPointEst)[,1],length(k),1)
  kCI_trt = matrix(c(kCILower[,1],kCIUpper[,1]),length(k),2)
  kPValue_trt = kPValue[,1,drop=FALSE]
  kTestStat_trt = kTestStat[,1,drop=FALSE]

  rownames(kPointEst_trt) = rownames(kVarPointEst_trt) = rownames(kCI_trt) = rownames(kPValue_trt) = rownames(kTestStat_trt) = k
  colnames(kPValue_trt) = colnames(kTestStat_trt) = beta0
  colnames(kPointEst_trt) = "Estimate"
  colnames(kVarPointEst_trt) = "Std. Error"
  colnames(kCI_trt) = c(paste(as.character(round(alpha/2 * 100,1)),"%"),paste(as.character( round((1-alpha/2) * 100,1)),"%"))

  return(list(k = k,
              point.est = kPointEst_trt,std.err = kVarPointEst_trt,test.stat = kTestStat_trt,p.value = kPValue_trt,ci = kCI_trt,
              point.est.other = kPointEst[,-1,drop=FALSE],std.err.other = sqrt(kVarPointEst[,-1,drop=FALSE]),
              test.stat.other = kTestStat[,-1,drop=FALSE],p.value.other = kPValue[,-1,drop=FALSE],
              ci.other.lower = kCILower[,-1,drop=FALSE],ci.other.upper=kCIUpper[,-1,drop=FALSE]))
}


## Likelihood ##
neg.likelihood.SAR.MLE.sigma<-function(para,env)
{
  Y=get("Y",env)
  W=get("W",env)
  theta=para#[1:(length(para)-1)]
  n=length(Y)
  In=diag(length(Y))
  C_theta=theta[1]*W[[1]];if(length(W)>1) {for(i in 2:length(W)) C_theta=C_theta+theta[i]*W[[i]]}
  tmp=In-C_theta
  sigma=sqrt(t(Y-mean(Y)) %*% t(tmp) %*% tmp %*% (Y-mean(Y))/n)  ## At MLE
  eigen.value=eigen(t(tmp) %*% tmp)$value
  eigen.value[abs(eigen.value)<1e-15]=abs(eigen.value[abs(eigen.value)<1e-15]);
  likeli=-n/2*log(sigma^2)+1/2*sum(log(eigen.value))-n/2
  return(as.numeric(-likeli))
}

# first derivatives #
neg.firstderi.SAR.MLE.sigma<-function(para,env)
{
  Y=get("Y",env)
  W=get("W",env)
  result=NULL;
  theta=para#[1:(length(para)-1)]
  #sigma=para[length(para)]
  n=length(Y)
  In=diag(length(Y))
  C_theta=theta[1]*W[[1]];if(length(W)>1) {for(i in 2:length(W)) C_theta=C_theta+theta[i]*W[[i]]}
  tmp=In-C_theta
  sigma=sqrt(t(Y-mean(Y)) %*% t(tmp) %*% tmp %*% (Y-mean(Y))/n)  ## At MLE
  tmp.inv=solve(tmp)
  for(i in 1:length(W))
    result=rbind(result,-psych::tr(tmp.inv %*% W[[i]])+1/sigma^2*t(Y-mean(Y)) %*% tmp %*% W[[i]] %*% (Y-mean(Y)))
  #result=rbind(result,-n/sigma+1/sigma^3*t(Y-mean(Y))%*% tmp %*% tmp %*% (Y-mean(Y)))
  -result
}

## Second Derivatives ##
neg.secondderi.SAR.MLE.sigma<-function(para,env)
{
  Y=get("Y",env)
  W=get("W",env)
  theta=para
  n=length(Y)
  In=diag(length(Y))
  C_theta=theta[1]*W[[1]];if(length(W)>1) {for(i in 2:length(W)) C_theta=C_theta+theta[i]*W[[i]]}
  tmp=In-C_theta
  sigma=sqrt(t(Y-mean(Y)) %*% t(tmp) %*% tmp %*% (Y-mean(Y))/n)  ## At MLE
  tmp.inv=solve(tmp)
  result=matrix(NA,length(para),length(para));
  for(i in 1:length(theta))
    for(j in i:length(theta))
    {
      result[i,j]=result[j,i]=-psych::tr(tmp.inv %*% W[[j]] %*% tmp.inv %*% W[[i]])-1/sigma^2*t(Y-mean(Y)) %*% W[[j]] %*% W[[i]] %*% (Y-mean(Y))
    }
  -result
}

## MML scores ##
mml.dfgps<-function (dfgps_result, intercept = FALSE, stand.coef = FALSE)
{
  N <- dfgps_result$N;
  tau2<-dfgps_result$RSS/N;
  y <- dfgps_result$y;
  y <- y-mean(y)
  k <- dfgps_result$df
  mml_vec <- N * log(2 * pi * tau2) + N + (k+1)*log(sum(y^2)/2/tau2)+log(k+1)-2*gamma((k+3)/2);
  mml_index <- which.min(mml_vec)
  mml_index <- as.integer(mml_index)
  p = dfgps_result$p
  p = as.integer(p)
  delta_t = dfgps_result$delta_t
  delta_t = as.double(delta_t)
  betavec = as.integer(dfgps_result$coefficient_index)
  tuning <- dfgps_result$tuning[mml_index]
  if (stand.coef == FALSE)
    tuning <- dfgps_result$tuning_stand[mml_index]
  beta_mml = msgps::coef.dfgps(dfgps_result, tuning, intercept, stand.coef)$coefficient
  df <- dfgps_result$df[mml_index]
  return(list(result = mml_vec, step = mml_index, tuning = tuning,
              coef = beta_mml, df = df))
}

## optimization ##

SARpredassomain<-function(data,compare='rrblup',assess=TRUE,methods=c("Cp","AICc","GCV","BIC","MML"),max.step=20)
{

  Y=data$train$Y
  W=data$train$IBS
  train.index=data$train.index;

  maxvalue=NULL;
  for(i in 1:length(W))
  {
    tmp=W[[i]];
    maxvalue=c(maxvalue,max(eigen(tmp)$values));
  }
  maxvalue=max(maxvalue);

  ## rescale by sqrt ##
  maxvalue1=maxvalue;
  maxvalue=NULL;
  for(i in 1:length(W))
  {
    data$train$IBS[[i]]=data$train$IBS[[i]]/sqrt(maxvalue1);
    data$IBS[[i]]=data$IBS[[i]]/sqrt(maxvalue1);
    tmp=data$train$IBS[[i]];
    maxvalue=c(maxvalue,max(eigen(tmp)$values));
  }
  maxvalue=max(maxvalue);
  W=data$train$IBS

  env=new.env();
  assign("Y",Y,env);
  assign("W",W,env);

  ## initial estimates ##
  converge=TRUE;
  set.seed(10);
  int1=runif(length(W),-1/maxvalue,1/maxvalue);
  opt1 <- optimx::optimx(int1,neg.likelihood.SAR.MLE.sigma,gr=neg.firstderi.SAR.MLE.sigma, hessian = TRUE,env=env,method="L-BFGS-B",itnmax=5000)
  second<-attr(opt1,"details")[1,]$nhatend;

  if(!opt1$kkt2 | is.na(opt1$kkt2))
  {
    step=1;
    while((!(opt1$kkt2)| is.na(opt1$kkt2)) & step < max.step)
    {
      int1=runif(length(W),-1/maxvalue,1/maxvalue);
      opt1 <- optimx::optimx(int1,neg.likelihood.SAR.MLE.sigma,gr=neg.firstderi.SAR.MLE.sigma, hessian = TRUE,env=env,method="L-BFGS-B",itnmax=5000)

      second<-attr(opt1,"details")[1,]$nhatend;
      step=step+1;
    }
    if(!(opt1$kkt2) & step == max.step)
    {
      opt1[1,1:length(get("W",env))]=0; # no variable would be selected;
      second=neg.secondderi.SAR.MLE.sigma(unlist(opt1[1,1:length(get("W",env))]),env=env);
      converge=FALSE;
    }
  }
  B=expm::sqrtm(second);

  ## The below is finding the penalized solution ###
  #  if(length(get("W",env))==1) B=sqrt(second[1,1])
  if(converge)
  {
    MLE=matrix(unlist(opt1[1,1:length(get("W",env))]),ncol=1)
    Y.lla=B %*% MLE
    X.lla=B
    for(i in 1:ncol(X.lla))
      X.lla[,i]=X.lla[,i]*(MLE[i,1])
    fit4 <- msgps::msgps(X.lla,Y.lla[,1],penalty="enet",alpha=0,intercept=FALSE)

    ## Getting coefficients and tests##
    COEFS=TESTS=NULL;
    vars=solve(second);
    for(i in 1:length(methods))
    {
      if(methods[i]!="MML")
      {
        coefs=coef(fit4)[,methods[i]]*MLE ;
        tests=coefs/sqrt(diag(vars));
      }
      if(methods[i]=="MML")
      {
        tmp=mml.dfgps(fit4$dfgps_result, intercept = fit4$intercept, stand.coef = fit4$stand.coef)
        coefs=tmp$coef*MLE ;
        tests=coefs/sqrt(diag(vars));
      }
      COEFS=rbind(COEFS,matrix(coefs,nrow=1));
      TESTS=rbind(TESTS,matrix(tests,nrow=1));
    }
    rownames(TESTS)=rownames(COEFS)=methods;

    ## Getting Predictions ##
    Wall=data$IBS;
    train.index=data$train.index;
    In=diag(nrow(Wall[[1]]));
    PRED=NULL;
    ASSESS=NULL;
    for(me in 1:length(methods))
    {
      predcoef=COEFS[me,];
      Ctheta=predcoef[1]*Wall[[1]];if(length(Wall)>1){for(i in 2:length(Wall)) Ctheta=Ctheta+predcoef[i]*Wall[[i]]}

      Q=t(In-Ctheta) %*% (In-Ctheta)
      VARS=solve(Q)
      pred2=mean(Y)+VARS[-train.index,train.index] %*% solve(VARS[train.index,train.index]) %*% (Y-mean(Y))
      pred=matrix(pred2,ncol=1)
      colnames(pred)=paste(methods[me],c("pred"),sep="_");
      PRED=cbind(PRED,pred);
      if(assess)
      {
        COR=cor(data$Y[-data$train.index],pred2,use="na.or.complete");
        MSE=mean((data$Y[-data$train.index]-pred2)^2, na.rm = TRUE);
        tmp=matrix(c(COR,MSE),nrow=1);
        colnames(tmp)= c("COR","MSE");
        rownames(tmp)=methods[me];
        ASSESS=rbind(ASSESS,tmp);
      }
    }
    if(assess)
    {
      PRED=cbind("YTrue"=data$Y[-data$train.index],PRED)
    }

    if(tolower(compare)=='rrblup')
    {
      testid=(1:length(data$Y))[-train.index];
      M=data$Geno
      rownames(M) <- 1:nrow(data$Geno)
      A <- rrBLUP::A.mat(M)
      Y1=data$Y
      Y1[testid]=NA
      datablup <- data.frame(y=Y1,gid=1:nrow(data$Geno))
      #predict breeding values
      ans <- rrBLUP::kin.blup(data=datablup,geno="gid",pheno="y",K=A);
      PRED=cbind(PRED,"rrBLUP"=ans$g[testid]+mean(Y1,na.rm=T));

      if(assess)
      {
        CORrrblup <- cor(data$Y[testid],ans$g[testid],use="na.or.complete");
        MSErrblup= mean((data$Y[testid]-(ans$g[testid]+mean(Y1,na.rm=T)))^2, na.rm = TRUE);
        tmp=matrix(c(CORrrblup,MSErrblup),nrow=1);
        colnames(tmp)= colnames(ASSESS)
        rownames(tmp)="rrBLUP";
        ASSESS=rbind(ASSESS,tmp);
      }
    }
    Result=list();
    Result$Pred=PRED;
    Result$Assess=ASSESS;
    #Result$Coefs=COEFS;
    #Result$Tests=TESTS;
    #Result$opt1=opt1;
  }
  if(!converge)
  {
    Result=list();
    Result$Pred=list();
    Result$Assess=list();
    #Result$Coefs=list();
    #Result$Tests=list();
    #Result$opt1=opt1;
    Result$Errors="MLE does not converge! Try new initial values!"
  }
  Result;
}

#' @title Genetic Risk Prediction Using a Spatial Autoregressive Model with Adaptive Lasso
#'
#' @description
#' \code{SARpred} returns the predicted values of the phenotypes.
#' @details
#' This function is used to predict outcomes based on individual's genetic profiles.
#'
#' @param Y A vector of phenotypes. Missing values should be coded as \code{NA}.
#' @param Geno A matrix of genotypes, with each row representing individual and column representing single nucleotide variant.
#' @param TrainID A bool vector with \code{true} indicating the individual is in the training sample.
#' @param genelist A list with each element represents a group.
#' @param Similarity A list with \code{i}-th element measuring the similarity for a particular chuck of genome listed in the \code{genelist[[i]]}.
#' @param SaveSimilarity A bool indicating whether the similarity should be saved for futher use. By default, similarity is not saved.
#' @param compare A string that indicates which method the SARAL compares to. Currently it only supports GBLUP.
#' @param assess A bool. If true, the method will calculate Pearson correlation and mean square error from the testing data. This option is ignored if all the phenotypes of the testing sample is \code{NA} (i.e. \code{sum(!is.na(Y[!TrainID]))==0}).
#' @param methods A string vector that determines which model selection criterion is used to select model for SARAL. By default, it uses Mallows' Cp (Cp), bias corrected AIC (AICc), generalized cross validataion (GCV), BIC, and information theoretic minimum message length (MML).
#' @return A list that contains the predicted values, the pearson correlations and mean square errors (if \code{assess=TRUE}), and error if algorithm does not converge. The list also contains a list of similarity measure (if \code{SaveSimilarity=TRUE}).
#' @examples
#' # This may take 2 hours, don't run if not needed #
#' Y=SARAL::example_SARAL$Y;
#' Geno=SARAL::example_SARAL$Geno;
#' TrainID=SARAL::example_SARAL$TrainID;
#' genelist=SARAL::example_SARAL$Genelist;
#' Result<-SARALpred(Y,Geno,TrainID,genelist,compare='rrblup',assess=TRUE,methods=c("Cp","AICc","GCV","BIC","MML"))
#' @export
SARALpred<-function(Y, Geno, TrainID,genelist=list(),Similarity=NULL,SaveSimilarity=FALSE,YTest=NULL,compare='rrblup',assess=TRUE,methods=c("Cp","AICc","GCV","BIC","MML"))
{
  YTrain=Y[TrainID];
  YTest=Y[!TrainID];
  if(sum(!is.na(YTest))==0 & assess==TRUE)
  {
    warning("Can't assess the prediction performance due to the lack of true values!")
    assess=FALSE;
  }

  ## checking genotypes for both training and testing ##
  if(is.null(colnames(Geno)))
  {
    stop("Genotypes do not have their names!")
  }
  GenoTrain=Geno[TrainID,];
  GenoTest=Geno[!TrainID,];

  ## delete indiviudals in the training set without phenotypes measured ##
  tmp=is.na(YTrain);
  if(sum(tmp)!=0){warning("Individuals without phenotypes in the training set are not used for training the prediction model!")}
  YTrain=YTrain[!tmp];
  GenoTrain=GenoTrain[!tmp,]

  data=list();
  Y=c(YTrain,YTest);
  Geno=rbind(GenoTrain,GenoTest);
  train.index=1:length(YTrain);
  data$Y=Y;
  data$train.index=train.index;
  data$Geno=Geno;
  data$Gene=genelist;
  IBS=list();IBSTrain=list();
  if(length(genelist)==0 & is.null(Similarity)){
    warning("no annotation is provided, and all the SNPs will be treated as if they come from the same gene");
    IBS[[1]]=as.matrix(dist(as.matrix(data$Geno)))
    IBSTrain[[1]]=IBS[[1]][train.index,train.index];
  }
  if(length(genelist)>0 & is.null(Similarity))
  {
    for(i in 1:length(genelist))
    {
      cat("calculating similartiy for the",i,"th gene!","\n");
      geno=data$Geno[,colnames(data$Geno) %in% genelist[[i]]];
      IBS[[i]]=as.matrix(dist(as.matrix(geno)));
      IBSTrain[[i]]=IBS[[i]][train.index,train.index];
    }
  }
  if(!is.null(Similarity))
  {
    if(length(genelist)!=length(Similarity))
    {
      stop("Similarity should be calculated according the genelist. The number of chucks(i.e. the length of the genelist) and the number of similarities are different! Please check!");
    }
    # checking the dimension of similarities
    for(i in 1:length(Similarity))
    {
      if((length(data$Y)!=nrow(Similarity[[i]])) | (length(data$Y)!=ncol(Similarity[[i]])))
      {
        stop("Similarity should be calculated for each pair of individuals, and thus it should be square matrix with the dimension equals to the total sample size! Please check!");
      }
    }
    IBS=Similarity;
    for(i in 1:length(genelist))
    {
      IBSTrain[[i]]=IBS[[i]][train.index,train.index];
    }
  }
  data$IBS=IBS;
  data$train=list();
  data$train$Y=YTrain;
  data$train$Geno=GenoTrain;
  data$train$IBS=IBSTrain;
  cat("Building Risk Prediction Models...");
  Result<-try(SARpredassomain(data,compare=compare,assess=assess,methods=methods),silent=TRUE);
  if(SaveSimilarity) Result$IBS=IBS;
  Result;
}


library('OpenMx')

setwd('~/git/sem_python/tests')
data <- read.csv('HolzingerSwineford1939.csv')

visual <- c('x1', 'x2', 'x3')
textual <- c('x4', 'x5', 'x6')
speed <- c('x7', 'x8', 'x9')
manifest <- c(visual, textual, speed)
latent <- c('visual', 'textual', 'speed')
data <- data[manifest]

model <- mxModel(
    "HolzingerSwineford1939",
    type="RAM",
    manifestVars=manifest,
    latentVars=latent,
    mxData(observed=data, type="raw"),
    mxPath(from=manifest, arrows=2, free=TRUE, values=diag(var(data)) / 2),
    mxPath(from=latent, arrows=2, free=FALSE, values=1),
    mxPath(from=latent, connect='unique.bivariate', arrows=2, free=TRUE, values=1),
    mxPath(from="visual",to=visual, arrows=1, free=TRUE, values=1, labels=c('visual_x1', 'visual_x2', 'visual_x3')),
    mxPath(from="textual",to=textual, arrows=1, free=TRUE, values=1, labels=c('textual_x4', 'textual_x5', 'textual_x6')),
    mxPath(from="speed",to=speed, arrows=1, free=TRUE, values=1, labels=c('speed_x7', 'speed_x8', 'speed_x9')),
    mxPath(from='one', to=manifest, free=FALSE, values=colMeans(data)))

fit <- mxRun(model)

summary(fit)


isPrime <- function(n) {
  if (n == 2) return(TRUE)
  if ( (n <= 1) || ( n %% 2 == 0 ) ) return(FALSE)
  for( i in 3:sqrt(n) ) {
    if ( n %% i == 0 ) return(FALSE)
  }
  TRUE
}


# SMAA-1: uncertainty represented by the theoretical probability distributions used to
# generate the "true" observed values. See SMAA-Boot.r for more details.

SMAA1<-function(nI,J,runs,input,dstbn,ta,la)
  {

  x=array(rep(0,nI*J*runs),c(runs,nI,J))
  # Generate array of criterion values (Normal SMAA)
  if (dstbn=="normal"){
    for (i in 1:nI){
      for (j in 1:J){
        x[,i,j]=rnorm(runs,input[i,j,4],input[i,j,5])
      }
    }
  }
  if (dstbn=="skew"){
    for (i in 1:nI){
      for (j in 1:J){
        x[,i,j]=input[i,j,4]+rgamma(runs,shape=input[i,j,5],scale=input[i,j,6])-input[i,j,5]*input[i,j,6]
      }
    }
  }

  # Standardize data by column (criteria) across all generated values
  for (j in 1:J){
    x[,,j]=(x[,,j]-min(x[,,j]))/(max(x[,,j])-min(x[,,j]))
  }

  # Generate matrix of weights (inter-criteria importance)
  w=wts(nC, runs)

  # Compute utilities
  u=array(rep(0,runs*nI*J),c(runs,nI,J))
  for(j in 1:J)
  {
    cutoffs = c(0,ta[j],1)
    values = c(0,la[j],1)
    xt = as.vector(x[,,j])
    xt_pvf = smaa.pvf(xt,cutoffs=cutoffs,values=values,outOfBounds="clip")
    u[,,j] = matrix(xt_pvf,runs,nI)
  }

  # Run SMAA
  b = smaa(u,w)$ra
  b = unclass(b)
  b

}


############
#Calculation of some likelihoods
#
############

gaussian_lik<-function(x,Omega){
  #Omega is precision matrix (inverse of covariance mat)
  d<-length(x)
  -log(2*pi)*d/2 + log( det(Omega) )/2 - crossprod(x,Omega)%*%x /2
}

trw_lik<-function(vert_means,edge_means,vert_coef,edge_coef,part_fn){
  sum( vert_means*vert_coef) + sum( edge_means*edge_coef ) - part_fn
}


#!/usr/bin/env RScript

# $ brew tap homebrew/science
# $ brew install R

NUM_TRIALS <- 10000
PRIOR_LOWER_MAX <- 100

# Runs a single trial where an envelope is chosen.  If the chosen envelope has
# a value < cutoff, the function will switch envelopes, otherwise it will keep
# the envelope it has chosen. Returns the value of the envelope it ultimately
# selects.
singleTrial <- function(cutoff, rand1, rand2) {
  lower_value <- rand1 * PRIOR_LOWER_MAX
  higher_value <- 2 * lower_value
  if (rand2 < 0.5) {
    if (lower_value >= cutoff) lower_value else higher_value
  } else {
    if (higher_value >= cutoff) higher_value else lower_value
  }
}

# Runs many trials at a given cutoff to approximate the expected value.
multiTrial <- function(cutoff) {
  total <- 0
  # runif performance is pretty bad, this saves 7 seconds of runtime.
  rand_vals <- runif(2 * (NUM_TRIALS + 1))
  for (i in 1:NUM_TRIALS) {
    rand1 <- rand_vals[2 * i - 1]
    rand2 <- rand_vals[2 * i]
    # Inlining singleTrial would save another ~1.3 seconds.
    total <- total + singleTrial(cutoff, rand1, rand2)
  }
  total / NUM_TRIALS
}

for (cutoff in 0:(2 * PRIOR_LOWER_MAX)) {
  print(sprintf("cutoff=%s, expected_value=%f", cutoff, multiTrial(cutoff)))
}


# 4. faza: Analiza podatkov

#Leto 1935 je naše izhodišče, zato ga postavimo kot leto 0

pdf("slike/populacija.pdf")

leto <- demographics$Year - 1900
pop <- demographics$Population.x1000 / 1000

plot(leto, pop, xlab = "Leto", ylab = "Populacija x 1000000")

legend(40, 300, c("Linerana", "Kvadratna"), lty=c(1,1), col = c("blue","red"))

#Npišemo funkcijo za linearno rast

linearna <- lm(pop ~ leto)
abline(linearna, col="blue")

#Preverimo če je populacija kvadratna funkcija

kvadratna <- lm(pop ~ I(leto^2) + leto)
curve(predict(kvadratna, data.frame(leto=x)), add = TRUE, col = "red")

#Loess model za primerjavo (model loess uporablja lokalno prilagajanje)

loess <- loess(pop ~ leto)

#Pogledamo ostanke pri modelih. Tisti, ki ima manjši ostanek je bolj natančen

vsota.kvadratov <- sapply(list(linearna, kvadratna, loess), function(x) sum(x$residuals^2))

dev.off()

#Narisali bomo napoved za rast prebivalstva do leta 2030 po modelu za modeala linear in kvadratna

pdf("slike/napoved.pdf")

plot(demographics$Year, pop, xlim = c(1935, 2050), ylim = c(120, 450),
     xlab = "Leto", ylab = "Populacija (v mil)",
     main = "Predvidena rast prebivalstva po različnih modelih")
abline(h = 400,col = "black", lwd = 1.5, lty = 1)

#Presečišča izračunamo na roko

points(2040, 400,  col = "black", pch = 21)
points(2048, 400,  col = "black", pch = 21)

#V presečiščih potegnemo navpične črte

abline(v=2040, col = "magenta", lty = 1)
abline(v=2048, col = "magenta", lty = 1)

napoved <- function(x,model){predict(model, data.frame(leto=x-1900))}

curve(napoved(x, linearna), add= TRUE, lwd = 1.5, col = "blue")
curve(napoved(x, kvadratna), add = TRUE, lwd = 1.5, col = "red")

#Narišemo še legendo
legend(1932, 380, c("Linerana (lm(pop ~ leto))", "Kvadratna (lm(pop ~ I(leto^2) + leto))",
                    "400 miljonov prebivalcev"),
       lty=c(1,1), col = c("blue","red", "black"))

dev.off()

# Narisali bomo še graf ZDA po gostoti prebivalstva, saj je to ena izmed stvari, ki me je
# na začetku zanimala

#Paketi za delo z zemljevidi
library(sp)
library(maptools)
library(rgeos)
gpclibPermit()

pdf("slike/gostota.pdf")

USA <- uvozi.zemljevid("http://audrey.fmf.uni-lj.si/states_21basic.zip",
                       "USA", "states.shp", mapa = "zemljevid")

nocemo <- c("Alaska", "Hawaii", "Puerto Rico", "U.S. Virgin Islands")
states <- USA[!(USA$STATE_NAME %in% nocemo),]

m <- match(states$STATE_NAME, rownames(ZDA))

gostota <- ZDA[,8]
max.gostota <- max(gostota)
min.gostota <- min(gostota)
norm.gostota <- (gostota - min.gostota)/(max.gostota - min.gostota)
#Uporabimo koren zaradi bolj enakomerne porazdelitve
barve <- rgb(1, 0, 0, sqrt(norm.gostota))

k <- 8 # število stopenj
stopnje <- seq(min.gostota, max.gostota, (max.gostota - min.gostota)/(k-1))
norm.stopnje <- (stopnje - min.gostota)/(max.gostota - min.gostota)
barve.stopnje <- rgb(1, 0, 0, sqrt(norm.stopnje))

plot(states, col = barve[m])
title( main = expression(paste("Gostota prebivalstva podana v ", 1/mi^2)))

legend("bottomleft", legend = round(stopnje), fill = barve.stopnje, cex = 0.7)

dev.off()

#k-means clustering
#Iz tabelele ZDA poberemo vse imenske spremenljivke (Abbr, Capital, Largest.City, Size)

data <- ZDA
data$Abbr <- NULL
data$Capital<- NULL
data$Largest.City <- NULL
data$Size<- NULL

data1 <- scale(data)

#Narišemo nekaj grafov

rezultati <- kmeans(data1, centers = 4)
center <- rezultati$centers
skupina <- rezultati$cluster
barve <- c("red", "green", "blue", "yellow")

pdf("slike/clustering_1.pdf")

plot(data[,"Population.2013"]/1000000,data[,"Pop.Density"], col = barve[skupina],
     xlab = "Populacija v milijonih", ylab = "Gostota prebivalstva",
     main = "Razvrščanje - Odvisnost gostote od populacije")

dev.off()

pdf("slike/clustering_2.pdf")

plot(data[,"Total.area.in.mi2"]/1000, data[,"Population.2013"]/1000000, col = barve[skupina],
     xlab = "Velikost x 1000 (mi^2)", ylab = "Populacija v milijonih",
     main = "Razvrščanje - Odvisnot populacije od velikosti države")

dev.off()

pdf("slike/clustering_3.pdf")

plot(data[,"Total.area.in.mi2"]/1000, data[,"Pop.Density"], col = barve[skupina],
     xlab = "Velikost x 1000 (mi^2)", ylab = "Gostota prebivalstva",
     main = "Razvrščanje - Odvisnost gostote od velikosti države")

dev.off()

#Narišemo še zemljevid in ga pobarvamo po skupinah

pdf("slike/zemljevid_grupe.pdf")

USA <- uvozi.zemljevid("http://audrey.fmf.uni-lj.si/states_21basic.zip",
                       "USA", "states.shp", mapa = "zemljevid")

nocemo <- c("Alaska", "Hawaii", "Puerto Rico", "U.S. Virgin Islands")
states <- USA[!(USA$STATE_NAME %in% nocemo),]

plot(states, col = barve[skupina])
title( main = "Države razdeljene po skupinah glede na k-means razvrščanje")

dev.off()


 DGESVJ Example Program Results

 Singular values
     9.9966  3.6831  1.3569  0.5000
 Left singular vectors
          1       2       3       4
 1  -0.2774  0.6003 -0.1277  0.1323
 2  -0.2020  0.0301  0.2805  0.7034
 3  -0.2918 -0.3348  0.6453  0.1906
 4   0.0938  0.3699  0.6781 -0.5399
 5   0.4213 -0.5266  0.0413 -0.0575
 6  -0.7816 -0.3353 -0.1645 -0.3957

 Right singular vectors
          1       2       3       4
 1  -0.1921  0.8030  0.0041 -0.5642
 2   0.8794  0.3926 -0.0752  0.2587
 3  -0.2140  0.2980  0.7827  0.5027
 4   0.3795 -0.3351  0.6178 -0.6017

 Error estimate for the singular values
        2.2E-15

 Error estimates for left singular vectors
        3.5E-16    9.5E-16    2.6E-15    4.4E-15

 Error estimates for right singular vectors
        3.5E-16    9.5E-16    2.6E-15    2.6E-15


#' Slackwater/suspension method to calculate paleoslope from preserved sediments
#'
#' \code{lynds_three} calculates the slope of an ancient river, provided you know the flow depth, the grain size of the bed material, and the maximum grain size of suspended sediment. Implemented from Lynds et al. (2014)
#' @param ws_mode Allows you to choose one of two different methods for calculating the settling velocity of the bedload particles. 'simple' ignores the Corey Shape Factor and the Powers Index. See documentation for \code{settle} for more information. For now, this feature is disabled.
#' @param Dbed The median grain size of bedload sediments in meters.
#' @param Dsusp The maximum grain size of suspended sediments in meters.
#' @param H The paleoflow depth in meters.
#' @param rhos The density of the sediment in kg/m^3
#' @param rhof The density of the fluid in kg/m^3
#' @return Returns a list with two elements: \code{S}, the dimensionless slope, and \code{F}, the ratio of total boundary shear stress to skin friction shear stress.
#' @export

#	Third method to reconstruct paleoslope from Lynds et al 2014
#	Eric Barefoot
#	Nov 2017

#	define needed variables and data types

#source(paste0(fd,'settle.r'))

lynds_three = function(Dbed, Dsusp, H, rhos = 2650, rhof = 1000, ws_mode = 'simple') {

	#	D is the D50b or median bedload grainsize
	#	H is Hbf or the bankfull flow depth

	#	constants
	#	NOTE: a number of these relationships depend on older dune scaling relationships. may be worthwhile upgrading to something as recommended by venditti 2017

	g = 9.8
	Cd = 0.21			#	drag coefficient for separated flow
	k = 0.407			#	von Karman constant
	hd = 0.3 * H		#	height of dunes. *** may also be able to calculate a priori from leclair?? ***
	lam = hd / 0.063 	#	for ratio of hd to lambda
	zo = 0.056 * 2 * Dbed	#	boundary layer thickness

	wsmax = settle('simple', Dsusp, constants = list(g = g, rhos = rhos, rhof = rhof, nuu = 1.004e-6))$ws

	F = 1 + (Cd / (2 * k^2)) * (hd / lam) * (log(hd / zo) - 1)^2

	#	final slope equation

	S = (F * wsmax^2) / (g * H)

	return(list(S = S, F = F))

}


 E04TAJ Example Program Results

 Solve the first LP

 E04MT, Interior point method for LP problems
 Status: converged, an optimal solution found
 Final primal objective value  8.500000E+02
 Final dual objective value    8.500000E+02

 Primal variables:
   idx   Lower bound       Value       Upper bound
     1   0.00000E+00    2.00000E+02         inf
     2   0.00000E+00    1.00000E+02    1.00000E+02

 The new variable has been added, solve the handle again

 E04MT, Interior point method for LP problems
 Status: converged, an optimal solution found
 Final primal objective value  9.000000E+02
 Final dual objective value    9.000000E+02

 Primal variables:
   idx   Lower bound       Value       Upper bound
     1   0.00000E+00    5.00000E+01         inf
     2   0.00000E+00    1.00000E+02    1.00000E+02
     3   0.00000E+00    5.00000E+01    5.00000E+01

 The new constraint has been added, solve the handle again

 E04MT, Interior point method for LP problems
 Status: converged, an optimal solution found
 Final primal objective value  8.750000E+02
 Final dual objective value    8.750000E+02

 Primal variables:
   idx   Lower bound       Value       Upper bound
     1   0.00000E+00    1.50000E+02         inf
     2   0.00000E+00    5.00000E+01    1.00000E+02
     3   0.00000E+00    5.00000E+01    5.00000E+01


#par(mfrow=c(1,2), mgp = c(1.5, 0.5, 0),tck=0.02)

V<- 4.66*10^(-13)

#V是基础弯月面体积

vne1<- 0.5*q[1]/fv + 4.66*10^(-13)

vne2<- (3*10^(-12))*0.9/fv + 4.66*10^(-13)

vne3<-(q[7]*(1-k))/fv+4.66*10^(-13)

#vne是体积增量

fv<-c(1:200)
q<-c(1.5*10^(-12),8.33*10^(-12),16.67*10^(-12),
     1.5/60*10^(-12),27/60*10^(-12),54/60*10^(-12),3*10^(-12))
k<-c(0.1,0.3,0.5,0.7,0.8)

#fv,q,k分别为电压频率，流量和占空比

coll<-rainbow(5)

plot(fv,vne2, col=coll[1],mgp = c(1.5, 0.5, 0),tck=0.02,type="b",pch=1,cex=0.6,lwd=1.5,lty=2,xlab = expression(italic(f["v"])(Hz)),
     ylab = expression (italic(V["ne"]+V["m"](m^3))),xlim=c(0,200),ylim=c(4.66*10^(-13), 9*10^(-13)))

pcc<-c(1,2,3,4,5)

for(i in 2:5){
  lines(fv,(q[7]*(1-k[i])/fv + 4.66*10^(-13)),col=coll[i],pch=pcc[i],cex=0.6, type="b",lwd=1.5,
        lty=2)
}

abline(h=(V+0.05*V),col="blue",lwd=1.5,lty=4)
abline(h=(V+0.1*V),col="blue",lwd=1.5,lty=4)
abline(h=(V+0.2*V),col="blue",lwd=1.5,lty=4)
abline(h=(V+0.6*V),col="blue",lwd=1.5,lty=4)

legend("topright",c("kv=0.1","kv=0.3","kv=0.5",
                    "kv=0.7","kv=0.8"),col=coll,
       inset = .02,pch=pcc,bty = "n",lty=2,lwd=1.5,cex=0.8)


REBOL [
    System: "REBOL [R3] Language Interpreter and Run-time Environment"
    Title: "REBOL 3 Mezzanine: Math"
    Rights: {
        Copyright 2012 REBOL Technologies
        REBOL is a trademark of REBOL Technologies
    }
    License: {
        Licensed under the Apache License, Version 2.0
        See: http://www.apache.org/licenses/LICENSE-2.0
    }
]

pi: 3.14159265358979323846

; Shorthands for radian forms of trig functions, first introduced by Red.
; http://www.red-lang.org/2014/08/043-floating-point-support.html

cos: :cosine/radians
sin: :sine/radians
tan: :tangent/radians  ; contentious with color "tan" (in CSS and elsewhere)
acos: :arccosine/radians
asin: :arcsine/radians
atan: :arctangent/radians

modulo: func [
    "Compute a remainder of A divided by B with the sign of B."
    return: [any-number! money! time!]
    a [any-number! money! time!]
    b [any-number! money! time!] "Must be nonzero."
    /adjusted "Set 'almost zero' and 'almost B' to zero"
][
    ; This function tries to find the remainder that is "almost non-negative"
    ; Example: 0.15 - 0.05 - 0.1 // 0.1 is negative,
    ; but it is "almost" zero, i.e. "almost non-negative"

    ; Compute the smallest remainder with the same sign as b
    let r: remainder a b
    if (sign? r) = negate sign? b [r: r + b]
    if not adjusted [return r]
    if (sign? a) = negate sign? b [a: negate a]
    ; If r is "almost" b (i.e. negligible compared to b), the
    ; result will be 0. Otherwise the result will be r
    any [
        a + r = a, b + r = b  ; 'almost zero'
        all [  ; 'almost b'
            (a + r) = (a + b)
            positive? (r + r) - b
        ]
    ] then [
        return 0.0
    ]
    return r
]

mod: enfixed :modulo
pow: enfixed :power

sign-of: func [
    "Returns sign of number as 1, 0, or -1 (to use as multiplier)."
    number [any-number! money! time!]
][
    case [
        positive? number [1]
        negative? number [-1]
    ] else [0]
]

extreme-of: func [
    {Finds the value with a property in a series that is the most "extreme"}

    return: "Position where the extreme value was found"
        [any-series!]
    series [any-series!]
    comparator "Comparator to use, e.g. LESSER? for MINIMUM-OF"
        [action!]
    /skip "Treat the series as records of fixed size"
        [integer!]
][
    skip: default [1]
    if 1 > skip [cause-error 'script 'out-of-range skip]
    let spot: series
    iterate-skip series skip [
        if (comparator first series first spot) [spot: series]
    ]
    return spot
]

minimum-of: redescribe [
    {Finds the smallest value in a series}
](
    specialize :extreme-of [comparator: :lesser?]
)

maximum-of: redescribe [
    {Finds the largest value in a series}
](
    specialize :extreme-of [comparator: :greater?]
)

; A simple iterative implementation; returns 1 for negative
; numbers. FEEL FREE TO IMPROVE THIS!
;
factorial: func [n [integer!]] [
    if n < 2 [return 1]
    let res: 1
    ; should avoid doing the loop for i = 1...
    count-up i n [res: res * i]
]

; This MATH implementation is from Gabrielle Santilli circa 2001, found
; via http://www.rebol.org/ml-display-thread.r?m=rmlXJHS. It implements the
; much-requested (by new users) idea of * and / running before + and - in
; math expressions. Expanded to include functions.
;
math: func [
    {Process expression taking "usual" operator precedence into account.}

    expr [block!]
        {Block to evaluate}
    /only
        {Translate operators to their prefix calls, but don't execute}

    ; !!! This creation of static rules helps avoid creating those rules
    ; every time, but has the problem that the references to what should
    ; be locals are bound to statics as well (e.g. everything below which
    ; is assigned with BLANK! really should be relatively bound to the
    ; function, so that it will refer to the specific call.)  It's not
    ; technically obvious how to do that, not the least of the problem is
    ; that statics are currently a usermode feature...and injecting relative
    ; binding information into something that's not the function body itself
    ; isn't implemented.

    <static>

    slash (the /)

    expr-val (_)

    expr-op (_)

    expression  ([
        term (expr-val: term-val)
        while [
            ['+ (expr-op: 'add) | '- (expr-op: 'subtract)]
            term (expr-val: compose [(expr-op) (expr-val) (term-val)])
        ]
        end
    ])

    term-val (_)

    term-op (_)

    term ([
        pow (term-val: power-val)
        while [
            ['* (term-op: 'multiply) | slash (term-op: 'divide)]
            pow (term-val: compose [(term-op) (term-val) (power-val)])
        ]
    ])

    power-val (_)

    pow ([
        unary (power-val: unary-val)
        opt ['** unary (power-val: compose [power (power-val) (unary-val)])]
    ])

    unary-val (_)

    pre-uop (_)

    post-uop (_)

    unary ([
        (post-uop: pre-uop: [])
        opt ['- (pre-uop: 'negate)]
        primary
        opt ['! (post-uop: 'factorial)]
        (unary-val: compose [(post-uop) (pre-uop) (prim-val)])
    ])

    prim-val (_)

    primary ([
        set prim-val any-number!
        | set prim-val [word! | path!] (prim-val: reduce [prim-val])
            ; might be a funtion call, looking for arguments
            while [
                nested-expression (append prim-val take nested-expr-val)
            ]
        | ahead group! into nested-expression (prim-val: take nested-expr-val)
    ])

    p-recursion (_)

    nested-expr-val ([])

    save-vars (func [][
            p-recursion: reduce [
                :p-recursion :expr-val :expr-op :term-val :term-op :power-val :unary-val
                :pre-uop :post-uop :prim-val
            ]
        ])

    restore-vars (func [][
            set [
                p-recursion expr-val expr-op term-val term-op power-val unary-val
                pre-uop post-uop prim-val
            ] p-recursion
        ])

    nested-expression ([
            ;all of the static variables have to be saved
            (save-vars)
            expression
            (
                ; This rule can be recursively called as well,
                ; so result has to be passed via a stack
                insert nested-expr-val ^expr-val
                restore-vars
            )
            ; vars could be changed even it failed, so restore them and fail
            | (restore-vars) fail

    ])
][
    clear nested-expr-val
    let res: either parse expr expression [expr-val] [blank]

    either only [
        res
    ][
        ret: reduce res
        all [
            1 = length of ret
            any-number? ret/1
        ] else [
            fail [
                unspaced ["Cannot be REDUCED to a number (" mold ret ")"]
                ":" mold res
            ]
        ]
        ret/1
    ]
]


#' Matrix Exponentiation
#'
#' Matrix exponentiation via Pade' approximations.
#'
#' @param x
#' A numeric matrix.
#' @param p
#' Order of the Pade' approximation.  Should be between 1 and 13.
#' 6 is typical.
#'
#' @return
#' exp(x)
#'
#' @export
expm <- function(x, p=6)
{
  if (nrow(x) != ncol(x))
    stop("Matrix exponentiation is only defined for square matrices.")

  if (p < 1L || p > 13L)
    stop("argument 'p' must be between 1 and 13.")

  if (!is.double(x))
    storage.mode(x) <- "double"

  exp <- .Call(R_libexpm_expm_5_1, x, as.integer(p))

  return( exp )
}


#' @name BMGL-EV
#' @rdname  BMGL-EV
#' @title Bivarite MGL-EV and survival MGL-EV copula
#' @description  Density, distribution function, and h-function the bivariate MGL-EV and survival MGL-EV copula with copula parameter delta.
#' @param u1,u2 numeric vectors of equal length with values in \eqn{[0,1]}.
#' @param param copula parameter, denoted by delta.
#' @md
#' @importFrom stats qbeta
#' @importFrom stats pbeta
#' @details
#' The h-function is defined as the conditional distribution function of a bivariate copula, i.e.,
#' \deqn{h_1(u_2|u_1,\delta) := P(U_2 \leq u_2 | U_1 = u_1) = \partial C(u_1,u_2) / \partial u_1,}
#'
#' \deqn{h_2(u_1|u_2,\delta) := P(U_1 \leq u_1 | U_2 = u_2) := \partial C(u_1,u_2) / \partial u_2,}
#'
#' where \eqn{(U_1, U_2) \sim C}, and \eqn{C} is a bivariate copula distribution function with parameter(s) \eqn{\delta}. For more details see Aas et al. (2009).
#' @references #' Zhengxiao Li, Jan Beirlant, Liang Yang. A new class of copula regression models for modelling multivariate heavy-tailed data. 2021, arXiv:2108.05511.
#'
#' @return
#' * \code{dcMGLEV.bivar}, \code{pcMGLEV.bivar} and \code{hMGLEV.bivar}  give values of density distribution and h-function for the 2-dimensional MGL copula with copula parameter \eqn{\delta>0}.
#' * \code{dcMGLEV180.bivar}, \code{pcMGLEV180.bivar} and \code{hMGLEV180.bivar}  give values of density and distribution and h-function for the 2-dimensional MGL copula with copula parameter \eqn{\delta>0}.
#' *  \code{hMGLEV.bivar} and \code{hMGLEV180.bivar} return a list with
#' ** hfunc1: \eqn{\partial C(u_1,u_2) / \partial u_1,}
#' ** hfunc2: \eqn{\partial C(u_1,u_2) / \partial u_2,}
NULL

#' @rdname  BMGL-EV
#' @export
#' @examples
#' pcMGLEV.bivar(u1 = c(0.3, 0.9), u2 = c(0.5, 0.8), param = 2)
pcMGLEV.bivar <- function(u1, u2, param) {
  out <- u1 + u2 - 1 + pcMGLEV180.bivar(1 - u1, 1 - u2, param = param)
  return(out)
}

#' @rdname  BMGL-EV
#' @export
#' @examples
#' dcMGLEV.bivar(u1 = 0.001, u2 = 0.999, param = 1)
dcMGLEV.bivar <- function(u1, u2, param) {
  dcMGLEV180.bivar(1 - u1, 1 - u2, param = param)
}

#' @rdname  BMGL-EV
#' @export
#' @examples
#' pcMGLEV180.bivar(u1 = c(0.3, 0.9), u2 = c(0.5, 0.8), param = 2)
pcMGLEV180.bivar <- function(u1, u2, param) {
  lf <- function(y1, y2, param) {
    delta <- param
    z2 <- (y2)^(-delta) / (y1^(-delta) + y2^(-delta))
    z1 <- (y1)^(-delta) / (y1^(-delta) + y2^(-delta))
    out <- y1 * pbeta(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) + y2 * pbeta(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5)
    return(out)
  }

  out <- exp(-lf(-log(u1), -log(u2), param = param))
  index1 <- u1 == 0 | u2 == 0
  index2 <- u1 == 1 & u2 != 0
  index3 <- u1 == 0 & u2 == 1
  out[index1] <- 0
  out[index2] <- u2[index2]
  out[index3] <- u1[index3]

  return(out)
}

#' @rdname  BMGL-EV
#' @export
#' @examples
#' dcMGLEV180.bivar(u1 = 0.5, u2 = 0.78, param = 1.8)
dcMGLEV180.bivar <- function(u1, u2, param) {
  lf <- function(y1, y2, param) {
    delta <- param
    z2 <- (y2)^(-delta) / (y1^(-delta) + y2^(-delta))
    z1 <- (y1)^(-delta) / (y1^(-delta) + y2^(-delta))
    out <- y1 * pbeta(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) + y2 * pbeta(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5)
    return(out)
  }

  pbeta_dev <- function(y, shape1, shape2) {
    (1 - y)^(shape2 - 1) * y^(shape1 - 1) / beta(shape1, shape2)
  }

  pbeta_dev2 <- function(y, shape1, shape2) {
    -(1 - y)^(shape2 - 2) * y^(shape1 - 2) * ((y - 1) * shape1 + (shape2 - 2) * y + 1) / beta(shape1, shape2)
  }
  z2_x1 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta * x1^(-delta - 1) * x2^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z1_x1 <- function(x1, x2, param) {
    delta <- param
    part1 <- -delta * x1^(-delta - 1) * x2^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z2_x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- -delta * x2^(-delta - 1) * x1^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z1_x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta * x2^(-delta - 1) * x1^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z2_x1x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta^2 * (x1 * x2)^(-delta - 1) * (x2^(-delta) - x1^(-delta))
    part2 <- (x2^(-delta) + x1^(-delta))^3
    part1 / part2
  }

  z1_x1x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta^2 * (x1 * x2)^(-delta - 1) * (x1^(-delta) - x2^(-delta))
    part2 <- (x2^(-delta) + x1^(-delta))^3
    part1 / part2
  }

  lf_dev_x1 <- function(x1, x2, param) {
    delta <- param
    z2 <- x2^(-delta) / (x2^(-delta) + x1^(-delta))
    z1 <- 1 - z2
    out <- pbeta(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) + x1 * pbeta_dev(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z2_x1(x1 = x1, x2 = x2, param = delta) + x2 * pbeta_dev(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z1_x1(x1 = x1, x2 = x2, param = delta)
    out
  }

  lf_dev_x2 <- function(x1, x2, param) {
    delta <- param
    z2 <- x2^(-delta) / (x2^(-delta) + x1^(-delta))
    z1 <- 1 - z2
    out <- pbeta(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5) + x2 * pbeta_dev(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z1_x2(x1 = x1, x2 = x2, param = delta) + x1 * pbeta_dev(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z2_x2(x1 = x1, x2 = x2, param = delta)
    out
  }

  lf_dev2 <- function(x1, x2, param) {
    delta <- param
    z2 <- x2^(-delta) / (x2^(-delta) + x1^(-delta))
    z1 <- 1 - z2
    If <- function(z) {
      pbeta(z, shape1 = 0.5, shape2 = 1 / delta + 0.5)
    }
    If_dev <- function(z) {
      pbeta_dev(y = z, shape1 = 0.5, shape2 = 1 / delta + 0.5)
    }
    If_dev2 <- function(z) {
      pbeta_dev2(y = z, shape1 = 0.5, shape2 = 1 / delta + 0.5)
    }
    p1 <- If_dev(z2) * z2_x2(x1 = x1, x2 = x2, param = delta)
    p2 <- x1 * (If_dev2(z2) * z2_x2(x1 = x1, x2 = x2, param = delta) * z2_x1(x1 = x1, x2 = x2, param = delta)
      + If_dev(z2) * z2_x1x2(x1 = x1, x2 = x2, param = delta))
    p3 <- ((If_dev(z1) + x2 * If_dev2(z1) * z1_x2(x1 = x1, x2 = x2, param = delta)) * z1_x1(x1 = x1, x2 = x2, param = delta)
      + x2 * If_dev(z1) * z1_x1x2(x1 = x1, x2 = x2, param = delta))
    out <- p1 + p2 + p3
    out
  }
  # final results
  p1 <- pcMGLEV180.bivar(u1 = u1, u2 = u2, param = param) / (u1 * u2)
  p2 <- lf_dev_x1(-log(u1), -log(u2), param = param) * lf_dev_x2(-log(u1), -log(u2), param = param) - lf_dev2(-log(u1), -log(u2), param = param)
  out <- p1 * p2
  return(out)
}

#' @rdname  BMGL-EV
#' @export
#' @examples
#' hcMGLEV180.bivar(u1 = 0.5, u2 = 0.78, param = 1.8)
hcMGLEV180.bivar <- function(u1, u2, param) {
  delta <- param
  lf <- function(y1, y2, param) {
    delta <- param
    z2 <- (y2)^(-delta) / (y1^(-delta) + y2^(-delta))
    z1 <- (y1)^(-delta) / (y1^(-delta) + y2^(-delta))
    out <- y1 * pbeta(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) + y2 * pbeta(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5)
    return(out)
  }

  pbeta_dev <- function(y, shape1, shape2) {
    (1 - y)^(shape2 - 1) * y^(shape1 - 1) / beta(shape1, shape2)
  }

  pbeta_dev2 <- function(y, shape1, shape2) {
    -(1 - y)^(shape2 - 2) * y^(shape1 - 2) * ((y - 1) * shape1 + (shape2 - 2) * y + 1) / beta(shape1, shape2)
  }
  z2_x1 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta * x1^(-delta - 1) * x2^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z1_x1 <- function(x1, x2, param) {
    delta <- param
    part1 <- -delta * x1^(-delta - 1) * x2^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z2_x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- -delta * x2^(-delta - 1) * x1^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z1_x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta * x2^(-delta - 1) * x1^(-delta)
    part2 <- (x2^(-delta) + x1^(-delta))^2
    part1 / part2
  }

  z2_x1x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta^2 * (x1 * x2)^(-delta - 1) * (x2^(-delta) - x1^(-delta))
    part2 <- (x2^(-delta) + x1^(-delta))^3
    part1 / part2
  }

  z1_x1x2 <- function(x1, x2, param) {
    delta <- param
    part1 <- delta^2 * (x1 * x2)^(-delta - 1) * (x1^(-delta) - x2^(-delta))
    part2 <- (x2^(-delta) + x1^(-delta))^3
    part1 / part2
  }

  lf_dev_x1 <- function(x1, x2, param) {
    delta <- param
    z2 <- x2^(-delta) / (x2^(-delta) + x1^(-delta))
    z1 <- 1 - z2
    out <- pbeta(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) + x1 * pbeta_dev(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z2_x1(x1 = x1, x2 = x2, param = delta) + x2 * pbeta_dev(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z1_x1(x1 = x1, x2 = x2, param = delta)
    out
  }

  lf_dev_x2 <- function(x1, x2, param) {
    delta <- param
    z2 <- x2^(-delta) / (x2^(-delta) + x1^(-delta))
    z1 <- 1 - z2
    out <- pbeta(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5) + x2 * pbeta_dev(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z1_x2(x1 = x1, x2 = x2, param = delta) + x1 * pbeta_dev(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) * z2_x2(x1 = x1, x2 = x2, param = delta)
    out
  }

  # final results
  Cu1u2 <- pcMGLEV180.bivar(u1 = u1, u2 = u2, param = delta)
  index1 <- u1 == 0 & u2 != 0
  index2 <- u1 != 0 & u2 == 0

  hfunc1 <- Cu1u2 / u1 * lf_dev_x1(x1 = -log(u1), x2 = -log(u2), param = delta)
  hfunc2 <- Cu1u2 / u2 * lf_dev_x2(x1 = -log(u1), x2 = -log(u2), param = delta)

  u10 <- rep(1e-10, length(u1[index1]))
  u20 <- rep(1e-10, length(u2[index2]))
  hfunc1[index1] <- pcMGLEV180.bivar(u1 = u10, u2 = u2[index1], param = delta) / u10 * lf_dev_x1(x1 = -log(u10), x2 = -log(u2[index1]), param = delta)
  hfunc2[index1] <- 0.0000000001

  hfunc1[index2] <- 0.0000000001
  hfunc2[index2] <- pcMGLEV180.bivar(u1 = u1[index2], u2 = u20, param = delta) / u20 * lf_dev_x2(x1 = -log(u1[index2]), x2 = -log(u20), param = delta)

  list(hfunc1 = hfunc1, hfunc2 = hfunc2) # h_1(u_2|u_1,??)
}

#' @rdname  BMGL-EV
#' @export
#' @examples
#' hcMGLEV.bivar(u1 = 0.5, u2 = 0.78, param = 1.8)
hcMGLEV.bivar <- function(u1, u2, param) {
  hfunc1 <- 1 - hcMGLEV180.bivar(u1 = 1 - u1, u2 = 1 - u2, param = param)$hfunc1
  hfunc2 <- 1 - hcMGLEV180.bivar(u1 = 1 - u1, u2 = 1 - u2, param = param)$hfunc2
  list(hfunc1 = hfunc1, hfunc2 = hfunc2)
}

#' @title  the Pickands dependence function \eqn{A} in survival MGL-EV copula
#'
#' @param w \eqn{w \in [0,1]}.
#' @param param copula parameter in survival MGL-EV copula.
#'
#' @return the value of the Pickands dependence function in \eqn{[0.5,1]}
#' @md
#' @details
#' - In the bivariate case
#' \eqn{d=2} the stable tail dependence function \eqn{\ell} can be represented in terms of the Pickands dependence function \eqn{A}:
#'
#' \deqn{
#' 		\begin{align}
#' 		A_{\delta}\left(w\right)=w I_{{\frac{1}{2}, \frac{1}{\delta}+\frac{1}{2}}}\left[\frac{\left(1-w \right)^{-\delta}}{\left(1-w \right)^{-\delta} + w^{-\delta} }\right]  + \left(1-w\right) I_{{\frac{1}{2}, \frac{1}{\delta}+\frac{1}{2}}}\left[\frac{w^{-\delta}}{\left(1-w \right)^{-\delta} + w^{-\delta} }\right].
#' 		\end{align}
#' }
#' where \eqn{A_{\delta}} is the Pickands dependence function of  survival MGL-EV copula.
#' Here \eqn{I_{m,n}^{-1}()} denotes the inverse of the beta cumulative distribution function \eqn{I_{m,n}()} (or regularized incomplete beta function)
#' with parameters shape1 = m and shape2 = n
#' implemented by R's \code{\link[stats]{qbeta}} and \code{\link[stats]{pbeta}} respectively.
#'
#'
#' - The extreme value copula  \eqn{\bar{C}^{MGL-EV}} of the  survival MGL copula is given by
#' 	\deqn{
#' 		\bar{C}^{MGL-EV}(u_1,u_2;\delta)=\exp\left[\log\left(u_1u_2\right)A_{\delta}\left(\frac{\log\left(u_2\right)}{\log\left(u_1u_2\right)}\right)\right].
#' }
#'
#' @importFrom stats qbeta
#' @importFrom stats pbeta
#'
#' @export
#' @examples
#' Afunction(w = 0.7, param = 1.2)
#'
#' delta <- 0.7
#' w.vector <- seq(0.0001, 0.9999, length.out = 100)
#' y.vector <- Afunction(w = w.vector, param = delta)
#' plot(w.vector, y.vector, lwd = 2, col = 3, ylim = c(0.5, 1))
#'
#' delta <- 1
#' w.vector <- seq(0.0001, 0.9999, length.out = 100)
#' y.vector <- Afunction(w = w.vector, param = delta)
#' lines(w.vector, y.vector, lwd = 2, col = 4)
#'
#' delta <- 3
#' w.vector <- seq(0.0001, 0.9999, length.out = 100)
#' y.vector <- Afunction(w = w.vector, param = delta)
#' lines(w.vector, y.vector, lwd = 2, col = 5)
#'
#' delta <- 5
#' w.vector <- seq(0.0001, 0.9999, length.out = 100)
#' y.vector <- Afunction(w = w.vector, param = delta)
#' lines(w.vector, y.vector, lwd = 2, col = 1)
Afunction <- function(w, param) {
  delta <- param
  k <- -delta
  z2 <- (1 - w)^k / (w^k + (1 - w)^k)
  z1 <- (w)^k / (w^k + (1 - w)^k)
  out <- w * pbeta(z2, shape1 = 0.5, shape2 = 1 / delta + 0.5) + (1 - w) * pbeta(z1, shape1 = 0.5, shape2 = 1 / delta + 0.5)
  return(out)
}