#' Get GEE identity Co-Variance Matrix
#'
#' Calculates GEE identity variance co-variance matrix.
#'
#' @param p.vec vector of probabilities
#' @param rho overdispersion parameter
#' @param dat matrix of multinomial clusters
#'
#' @return matrix of covariance
get_var_ident <- function (p.vec, rho, dat) {
  n <- dim(dat)[[2]]  # dimensions of multinom
  m <- n - 1  # order of multinom
  ni <- rowSums(dat) # cluster sizes
  num.clus <- dim(dat)[[1]]

  # helper vars
  rho.sq <- rho ^ 2
  dispi <- ni * (1 + (ni - 1) * rho.sq)
  p.mat <- matrix(p.vec, num.clus, m, byrow = TRUE)

  r.vec <- dat[, 1:m] - ni * p.mat
  var.mat <- diag(p.vec, m) - p.vec %*% t(p.vec)
  var.mat.inv <- solve(var.mat)

  Bi <- var.mat.inv * sum(ni ^ 2 / dispi)
  Mi <- diag(numeric(m), m)

  for (i in 1:num.clus) {
    ri <- r.vec[i, ]
    Yi.var <- ri %*% t(ri)
    Vi.inv <- (1 / dispi[i]) * var.mat.inv
    Di <- ni[i] * diag(numeric(m) + 1, m)
    Mi <- Mi + t(Di) %*% Vi.inv %*% Yi.var %*% Vi.inv %*% Di
  }

  cov.mat <- ( (sum(ni) - 1) / (sum(ni) - m) ) * (num.clus / (num.clus - 1)) * (solve(Bi) %*% Mi %*% solve(Bi))
  cov.mat
}

#' Get GEE glogit Co-Variance Matrix
#'
#' Calculates GEE glogit variance co-variance matrix.
#'
#' @param betas vector of betas
#' @param rho overdispersion parameter
#' @param dat matrix of multinomial clusters
#'
#' @return matrix of covariance
get_var_glogit <- function(betas, rho, dat) {
  n <- dim(dat)[[2]]  # dimensions of multinom
  m <- n - 1  # order of multinom
  ni <- rowSums(dat) # cluster sizes
  num.clus <- dim(dat)[[1]]

  # helper vars
  betas.exp <- exp(betas)
  rho.sq <- rho ^ 2
  denom <- 1 + sum(betas.exp)
  dispi <- (ni * (1 + (ni - 1) * rho.sq))
  p.vec <- as.vector(betas.exp / denom)
  p.mat <- matrix(p.vec, num.clus, m, byrow = TRUE)

  # create matrices
  bi <- matrix(0, m, m)
  mi <- diag(numeric(m), m)
  var.mat <- diag( p.vec, m ) - p.vec %*% t( p.vec )
  var.mat.inv <- solve(var.mat)
  r.vec <- dat[, 1:m] - ni * p.mat
  d.bar <- create_beta_equations(betas, rho, dat) / num.clus

  for (i in 1:num.clus) {
    ri <- r.vec[i, ]
    vi.inv <- (1 / dispi[i]) * var.mat.inv
    di <- ni[i] * (diag( betas.exp * denom, m ) - betas.exp %*% t( betas.exp )) / (denom ^ 2)
    dj <- t(di) %*% vi.inv %*% ri
    bi <- bi + t(di) %*% vi.inv %*% di
    mi <- mi + (dj - d.bar) %*% t(dj - d.bar)
  }

  cov.mat <- ( (sum(ni) - 1) / (sum(ni) - m) ) * (num.clus / (num.clus - 1)) * ( solve(bi) %*% mi %*% solve(bi) )
  cov.mat
}


twrc.calc <- function(twri, from=NA, to=NA, zero.from=FALSE) {
    if (class(twri)[1] == 'numeric') {
        ## use all twri entries
        twrc <- cumprod(twri + 1) - 1
    } else if (class(twri)[1] == 'matrix') {
        ## use all twri entries
        ## twrc <- cumprod(twri + 1) - 1
        # twrc <- t(t(cumprod(twri + 1))) - 1
        twrc <- apply(twri, 2, function(x) t(t(cumprod(x + 1))) - 1 )
    } else {
        ## twri must be an xts object
        ## use first and/or last twri entries for from and to if not defined
        if (is.na(from)) from <- zoo::index(twri[1,])
        if (is.na(to))   to   <- zoo::index(twri[nrow(twri),])
        ## cumprod works differently on xts than regular matrix so following is a bit complex
        duration <- paste(from, '/', to, sep='')
        if (isTRUE(zero.from)) {
            ## set twrc for from date to zero
            twrc <- xts::as.xts( t(t(cumprod(twri[duration]+1)) / as.vector(twri[from]+1) - 1) )
        } else {
            ## use from date when calculating twrc
            twrc <- xts::as.xts( t(t(cumprod(twri[duration]+1)) - 1) )
        }
    }
    return(twrc)
}
## twrivec1 <- c(0.1, 0.2, 0.3, 0.4, 0.5)
## twrivec2 <- c(0.11, 0.12, 0.13, 0.14, 0.15)
## twrimat  <- cbind(a=twrivec1, b=twrivec2)
## rownames(twrimat) <- c('2020-01-31', '2020-02-28', '2020-03-31', '2020-04-30', '2020-05-31')
## twrixts  <- xts::as.xts(twrimat)
## twrcvec1 <- twrc.calc(twrivec1)
## twrcmat  <- twrc.calc(twrimat)


library(nloptr)
library(rlist)
library(Rlab)
library(bssm)

fit = function(observed_I, f_inc, f_inf, prior_R, lags=7, lags2=3){
  "
  Parameters
  ----------
  observed_I : numeric vector
    Daily observed number of new cases.
  f_inc : numeric vector
    Incubation  time distribution. Should be the same length as 'observed_I'.
  f_inf : numeric vector
    Infectious  time distribution. Should be the same length as 'observed_I'.

  Returns
  -------
  model : list
    model betas , R and R_c.
  "
  omega = NULL
  F_inf = cumsum(f_inf)
  right_tail_inf = c(1, 1 - F_inf)
  for (tau in 1:length(observed_I)) {
    omega = c(omega, 0)
    for (tau_prime in 1:tau) {
      omega[tau] = omega[tau] + f_inc[tau_prime] * right_tail_inf[tau - tau_prime + 1]
    }
  }

  f = f_inc[1:lags2]
  f = f/sum(f)

  infection_time = sum(omega,na.rm=TRUE)
  priorMean= prior_R / infection_time

  expected_value = sum((omega/sum(omega))*seq(1,length(omega)))

lags3 = 9
#cases=base$newCases
  initialVector=rep(0,lags3)
  cases= observed_I

 #Dependiente
  casesMatrix_T=matrix(0,length(cases)-lags2+1,lags2)
  for(i in 1:dim(casesMatrix_T)[1]){
    casesMatrix_T[i,]=cases[i:(i+lags2-1)]
  }
  incubPotential_T=casesMatrix_T%*%f

  omega = omega[1:lags]

  omega = rev(omega*infection_time/sum(omega))

  #Independiente
  longCases=c(initialVector,cases)
  casesMatrix_T=matrix(0,length(longCases)-lags,lags)
  for(i in 1:dim(casesMatrix_T)[1]){
    casesMatrix_T[i,]=longCases[i:(i+lags-1)]
  }
  infectPotential_T=casesMatrix_T%*%omega
  infectPotential_T=infectPotential_T[1:length(incubPotential_T)]
  infectPotential_T[1]=1

   pars=c(0,0)
    obj1 <- function(pars) {
      tryCatch({
      pars2=pars
      pars2=exp(pars2)
      x=log(infectPotential_T)
      y=as.matrix(incubPotential_T)
      Z=t(cbind(as.matrix(x),1,0))
      n=length(incubPotential_T)
      dim(Z)=c(1,3,n)
      Z=as.array(Z)
      Ti=rep(c(1,0,0,0,1,0,0,1,1),n)
      dim(Ti)=c(3,3,n)

      R=rep(c(0,pars2[1],0,0,0,pars2[2]),n)
      dim(R)=c(3,2,n)

      a1=c(1,priorMean,priorMean)
      P1=diag(c(0,10^9,10^9))
      distribution="poisson"
      u=0
      model=ssm_mng(y, Z, Ti, R, a1, P1, distribution, state_names=c("Base", "Beta", "Beta_P"))

      objectiveFunction=-logLik(model, nsim = 1000, nsim_states = 0)
      if(objectiveFunction==-Inf){
        objectiveFunction=-objectiveFunction
      }
      }, error = function(e) {
        objectiveFunction=Inf
      } )
      return(objectiveFunction)
    }

    lb=c(-10,-10)
    ub=c(10,10)
    x0 = c(0,0)

    local_opts = list( "algorithm" = "NLOPT_LN_BOBYQA",
                       "xtol_rel" = 1.0e-7 )
    opts = list( "algorithm" = "NLOPT_LN_BOBYQA",
                 "xtol_rel" = 1.0e-7,
                 "maxeval" = 100000,
                 "local_opts" = local_opts )

    res = nloptr( x0=x0, eval_f=obj1, eval_grad_f=NULL,lb=lb, ub=ub, opts=opts)
    pars=res$solution

    pars2=pars
    pars2=exp(pars2)
    x=log(infectPotential_T)
    y=as.matrix(incubPotential_T)
    Z=t(cbind(as.matrix(x),1,0))
    n=length(incubPotential_T)
    dim(Z)=c(1,3,n)
    Z=as.array(Z)
    Ti=rep(c(1,0,0,0,1,0,0,1,1),n)
    dim(Ti)=c(3,3,n)

    R=rep(c(0,pars2[1],0,0,0,pars2[2]),n)
    dim(R)=c(3,2,n)

    a1=c(1,priorMean,priorMean)
    P1=diag(c(0,10^9,10^9))
    distribution="poisson"
    u=0
    model=ssm_mng(y, Z, Ti, R, a1, P1, distribution, state_names=c("Base", "Beta", "Beta_P"))
    betaT=sim_smoother(model, nsim = 1)[-1,2,1]
    for(h in 2:1000){
      betaT=cbind(betaT,sim_smoother(model, nsim = 1)[-1,2,1])
    }

    beta=exp(betaT)

    simuQL=function(simu){
      return(quantile(simu,c(0.05,0.95)))
    }

  data=cbind(t(apply(beta, 1, simuQL)),apply(beta, 1, mean))
  colnames(data)=c("lb","ub", "beta")

  # lb=qgamma(0.05, shape=shape1, rate=rate1)
  # ub=qgamma(0.95, shape=shape1, rate=rate1)
  # beta=((shape1-1)/rate1)
  #
  # data=cbind(betaParameteres,lb, beta,ub)
  data=as.data.frame(data)
  data$R=data$beta*sum(omega)
  data$Rlb=data$lb*sum(omega)
  data$Rub=data$ub*sum(omega)

  #R_Caso
  lb=data$lb
  ub=data$ub
  beta=data$beta
  longCaseslb=c(rep(lb[1], length=lags-1),lb)
  longCasesub=c(rep(ub[1], length=lags-1),ub)
  longCasesbeta=c(rep(beta[1], length=lags-1),beta)

  data$R_c=data$beta*sum(omega)
  data$R_clb=data$lb*sum(omega)
  data$R_cub=data$ub*sum(omega)

  for(i in 1:dim(betaT)[1]){
    for(j in 1:i){
      data$R_c[i]=data$R_c[i] + (longCasesbeta[i]*omega[j])
      data$R_clb[i]=data$R_clb[i] + (longCaseslb[i]*omega[j])
      data$R_cub[i]= data$R_cub[i] + (longCasesub[i]*omega[j])
    }
  }
  return(list(data=data))
}


johnson_tol <- function(x, jfit='all', alpha=0.01, P=0.99, side=1, plots='no') {

    ## input:   x     = data set
    ##          alpha = 1 - confidence
    ##          P     = proportion = coverage (tolerance interval only)
    ##          side  = 1 = 1-sided tolerance limit
    ##                = 2 = 2-sided tolerance limit
    ##          jfit  = 'all' = uses SuppDists::JohnsonFit to determine parameters
    ##                = 'SU'  = uses ExtDist::eJohnsonSU to determine parameters
    ##                = list of user specified parameters
    ##                  e.g., jparms <- list(gamma   = -1.039,
    ##                                       delta   = 1.66,
    ##                                       xi      = 14.46,
    ##                                       lambda  = 6.95,
    ##                                       type    = 'SU',
    ##                       johnson_tol(mtcars$mpg, jfit=jparms)
    ##
    ## output:  jparms = Johnson fit parameters used in tolerance limit calculation
    ##          xtol_lower = lower bound tolerance limit
    ##          xtol_upper = upper bound tolerance limit

    proportion <- P

    ##--------------------------------------------------------
    ## initialize tolerance limits
    xntol_lower  = NA
    xntol_upper  = NA
    xtol_lower   = NA
    xtol_upper   = NA

    ##--------------------------------------------------------
    ## determine Johnson parameters

    if (jfit[1] == 'all') {
        ## let R figure out which Johnson distribution fits best
        jparms  <- SuppDists::JohnsonFit(x)
    } else if (jfit[1] == 'SU') {
        ## force the Johnson SU distribution
        jparms.out <- ExtDist::eJohnsonSU(x)
        jparms <- list(gamma   = jparms.out$gamma,
                       delta   = jparms.out$delta,
                       xi      = jparms.out$xi,
                       lambda  = jparms.out$lambda,
                       type    = 'SU')
    } else {
        ## use Johnson parameters specified in jfit
        ## needs to be in same list format as created by SuppDists::JohnsonFit
        jparms <- jfit
    }
    gamma  <- jparms$gamma
    delta  <- jparms$delta
    xi     <- jparms$xi
    lambda <- jparms$lambda
    type   <- jparms$type

    ##--------------------------------------------------------
    ## transform x to normal distribution, xn
    ## https://www.sigmamagic.com/blogs/how-do-i-transform-data-to-normal-distribution/

    if (type == 'SU') {
        xn <- gamma + delta * asinh( (x - xi)/ lambda )
    } else if (type == 'SB') {
        xn <- try( gamma + delta *   log( (x - xi)/(lambda + xi - x) ) )
    } else {
        ## type == 'SL'
        xn <- try( gamma + delta *   log( (x - xi)/ lambda ) )
    }
    df <- data.frame(x, xn)

    if (plots != 'no') {
        plotspace(1,2)
        hist(x)
        hist(xn)
    }

    ##--------------------------------------------------------
    ## error check then proceed
    na_rows <- df[is.na(df$xn),]
    if (nrow(na_rows) != 0) {

        ## xn values could not be calculated for all x values
        cat('\n')
        cat('#####################################\n')
        cat('  ERROR IN JOHNSON_TOL  \n')
        cat('  xn(x) = NA or NaN for some x values \n')
        cat('#####################################\n')
        print(jparms)
        print(na_rows)
        xntol_out <- tolerance::normtol.int(xn, alpha = alpha, P=proportion, side=side)
    }

    ##--------------------------------------------------------
    ## calculate normal tolerance limit, xntol

    xntol_out <- tolerance::normtol.int(xn, alpha = alpha, P=proportion, side=side)
    if (side == 1) {
        xntol_lower <- xntol_out$'1-sided.lower'
        xntol_upper <- xntol_out$'1-sided.upper'
    } else if (side == 2) {
        xntol_lower <- xntol_out$'2-sided.lower'
        xntol_upper <- xntol_out$'2-sided.upper'
    }

    ##-----------------------------------------------------------------------------
    ## transform xntol back to johnson tolerance limit, xtol

    if (type == 'SU') {
        ## xn <- gamma + delta * asinh( (x - xi)/ lambda )
        xtol_lower = xi + lambda * sinh( (xntol_lower - gamma)/delta )
        xtol_upper = xi + lambda * sinh( (xntol_upper - gamma)/delta )

    } else if (type == 'SB') {
        ## Not sure tolerance limits have meaning for a bounded fit,
        ## but can define lower and upper bounds.

        ## Given xn <- gamma + delta *   log( (x - xi)/(lambda + xi - x) )
        ## Johnson SB undefined for (x - xi)/(lambda + xi - x) <= 0

        ## Based on aboove and knowing lambda > 0 by definition:
        ## On low end, need x-xi > 0
        xtol_lower <- xi
        ## On high end, need lambda + xi - x > 0
        xtol_upper <- lambda + xi

    } else {
        ## type == 'SL'
        ## xn <- gamma + delta *   log( (x - xi)/ lambda )
        ## On low end, need x-xi > 0 since lambda is defined as > 0
        xtol_lower <- xi
        xtol_upper <- xi + lambda * exp( (xntol_upper - gamma)/delta )

    }

    return(list(sided=side,
                alpha=alpha,
                P=P,
                jfit=jfit,
                jparms=jparms,
                x=x,
                xn=xn,
                xtol_lower=xtol_lower,
                xtol_upper=xtol_upper))
}

## ## test

## johnson_tol(mtcars$mpg)

## out <- johnson_tol(mtcars$mpg)
## upper_tolerance_limit_john <- out$xtol_upper
## upper_tolerance_limit_john
## jparms <- out$jparms

## johnson_tol(mtcars$mpg, jfit=jparms)


# Selection by comparison

# Poker and roulette winnings from Monday to Friday:
poker_vector <- c(140, -50, 20, -120, 240)
roulette_vector <- c(-24, -50, 100, -350, 10)
days_vector <- c("Monday", "Tuesday", "Wednesday", "Thursday", "Friday")
names(poker_vector) <- days_vector
names(roulette_vector) <- days_vector

# Which days did you make money on poker?
selection_vector <- c(poker_vector) > 0

# Print out selection_vector - returns TRUE and FALSE values for each element reviewed
selection_vector

# Select from poker_vector these days - only select the elements that match
poker_winning_days <- poker_vector[selection_vector]

# Which days did you make money on roulette?
selection_vector <- roulette_vector > 0

# Select from roulette_vector these days
roulette_winning_days <- roulette_vector[selection_vector]


# P-value analysis for AR(1) model
# We are mainly interested here in the distribution of p-values
# in case of drift an LR test. The key question is whether the distribution
# is uniform.

# Helper function for correlated errors ----
xy.errors <- function(n = 1000, mu = rep(1032, 2L), Sigma = matrix(c(23, 20, 20, 23), ncol = 2)) {
  as.list(data.frame(
    MASS::mvrnorm(n, mu = c('x' = mu[1], 'y' = mu[2]), Sigma = Sigma)
  ))
}

lin.sig <- function(z, dfdiff) {

  n <- length(z)

  seekmin <- function(M0, bps, xreg = NULL) {
    for (bp in bps) {
      bptrend <- c(rep(0, bp - 1), trend[bp:length(trend)] - trend[bp])
      reg <- if (!is.null(xreg)) cbind(xreg, bptrend) else cbind(bptrend)
      .M <- lm(z ~ reg - 1)
      .M[['xreg']] <- reg
      .M[['bp']] <- bp
      if (logLik(.M) > logLik(M0)) M0 <- .M
    }
    M0
  }

  bps.local <- function(M) {
    unique(c(max(1L, M$bp - 2*sidays):M$bp, M$bp:min(M$bp + 2*sidays, length(z) - 1)))
  }

  # Regressor definitions
  trend <- 1:n
  sidays <- as.integer(sqrt(n)) # first sweep seek interval in days
  bps <- which(!duplicated((trend[-length(trend)] - trend[1L]) %/% (sidays))) # breakpoints for fitting

  M0 <- lm(z ~ -1)

  M1 <- seekmin(M0 = M0, bps = bps)
  M1 <- seekmin(M1, bps = bps.local(M1))

  gwloggeR:::lrtest(logLik(M0), logLik(M1), df.diff = dfdiff)
}

# AR(1) model: intecept (OK) ----
set.seed(2020)
list2env(xy.errors(n = 1000, mu = c(0,0), Sigma = diag(c(5, 5))), envir = environment())
x <- gwloggeR:::model_drifts.simulate(mu = 1032, phi1 = 0.9, a = x)
y <- gwloggeR:::model_drifts.simulate(mu = 1032, phi1 = 0.9, a = y)
plot(x - y, type = 'l')
forecast::auto.arima(x - y, stationary = TRUE, trace = TRUE)

p <- replicate(n = 1000, expr = {
  n <- 10000
  list2env(xy.errors(n = n, mu = c(0,0), Sigma = diag(c(5, 5))), envir = environment())
  x <- gwloggeR:::model_drifts.simulate(mu = 1032, phi1 = 0.9, a = x)
  y <- gwloggeR:::model_drifts.simulate(mu = 1032, phi1 = 0.9, a = y)
  gwloggeR:::lrtest(
    logLik(arima(x - y, order = c(1, 0, 0), include.mean = FALSE)),
    logLik(arima(x - y, order = c(1, 0, 0))),
    df.diff = 1L
  )
})
hist(p)
sum(p < 0.05)/length(p)
# pvals are distributed uniformly

# AR(1) model: drift (NOK) ----
set.seed(2020)
p <- replicate(n = 1000, expr = {
  n <- 1000
  list2env(xy.errors(n = n, mu = c(0,0), Sigma = diag(c(5, 5))), envir = environment())
  x <- gwloggeR:::model_drifts.simulate(mu = 1000, phi1 = 0.9, a = x)
  y <- gwloggeR:::model_drifts.simulate(mu = 1050, phi1 = 0.9, a = y)
  fit <- gwloggeR:::model_drifts.fit(
    x = x - y,
    timestamps = seq(as.POSIXct('2000-01-01'), by = '12 hours', length.out = n),
    ar1 = 0.9,
    dfdiff = 2.8
  )
  fit$drift.significance
})
hist(p)
sum(p < 0.05)/length(p)
# pvals are not distributed uniformly under 2L df difference LR test.
# LR test df difference seems also to be dependent on number of observations (n).
# For 1000-10000 obs. a df difference of 2.8 seems to produce good results.

# AR(1) model: correlated + drift (NOK) ----
set.seed(2020)
p <- replicate(n = 1000, expr = {
  n <- 1000
  list2env(xy.errors(n = n, mu = c(0,0)), envir = environment())
  x <- gwloggeR:::model_drifts.simulate(mu = 1000, phi1 = 0.9, a = x)
  y <- gwloggeR:::model_drifts.simulate(mu = 1050, phi1 = 0.9, a = y)
  fit <- gwloggeR:::model_drifts.fit(
    x = x - y,
    timestamps = seq(as.POSIXct('2000-01-01'), by = '12 hours', length.out = n),
    ar1 = 0.9,
    dfdiff = 2.8
  )
  fit$drift.significance
})
hist(p)
sum(p < 0.05)/length(p)
# Doesn't seem to be different from non-correlated AR(1) drift.

# Linear model: drift (NOK) ----
set.seed(2020)
list2env(xy.errors(Sigma = diag(c(5, 5))), envir = environment())
plot(x, y)
plot(x - y, type = 'l')

list2env(xy.errors(), envir = environment())
plot(x, y)
plot(x - y, type = 'l')

p <- replicate(n = 1000, expr = {
  n <- 1000
  list2env(xy.errors(n = n, Sigma = diag(c(5, 5))), envir = environment())
  lin.sig(z = x - y, dfdiff = 2.8)
})
hist(p)
sum(p < 0.05)/length(p)
# pvals are not distributed uniformly under 2L df difference LR test.
# LR test df difference seems also to be dependent on number of observations (n).
# For 1000-10000 obs. a df difference of 2.8 seems to produce good results, just like in AR(1) case.

# Linear model: correlated + drift (NOK) ----
p <- replicate(n = 1000, expr = {
  n <- 1000
  list2env(xy.errors(n = n), envir = environment())
  lin.sig(z = x - y, dfdiff = 2.8)
})
hist(p)
sum(p < 0.05)/length(p)
# Doesn't seem to be different from non-correlated drift.


#' This function is used to estimate  the  different paramters of interest like the time varying transmission rates, proportion of reported cases and thebasic reproduction rates.
#'
#' @param N  (Mandatory) : The population size.
#' @param data (Mandatory) input :If the model is Multinomial then the data matrix should contain 3 columns namely Confirmed,Recovered and Death, while if the model is Poisson or Binomial, then the data should contain only one column namely Confirmed. Please see that the names of the colums are maintained.
#' @param data_init (Mandatory) This is the initial data values that should be provided by the user which is a six size length vector. The first entry should contain the Total Confirmed, Total Recovered ,Total Death , Daily Confirmed ,Daily Recovered and Daily Death for the Starting Date.If the starting total confirmed is 0 , please replace it by 1
#' @param init_pars = NULL( default) . Else the user can give a user input initial paramters which should consist of the initial values of the time varying beta , proportion of testing for the different periods.
#' @param niter = 1e5 (default)  No of iteration for the MCMC metropolis hasting algorithm.
#' @param BurnIn = 5e4 (default) This is the Burn-In Period for the MCMC algorithm
#' @param model = Multinomial(DEFAULT) This is the likelihood function that will be used. There are three options available namely Multinomial, Poisson and Binomial.
#' @param plot = TRUE(Default) This will give the box plot for the basic reproductuon number for the different periods.
#' @param auto.initialize = TRUE(default) This is the option for using a mle based initial parameter.
#' @param period_start The total time period is divided into small periods depending on the lockdowm measures imposed by the goverment. So this is a vector consisting of the start dates for the different time periods.
#' @param ... arguments passed to the function model_initializeR and model_plotR which is used for the initializing the parameters. The parameters are described below:
#'            \itemize{
#'                 \item{"step_pars"}{=init_pars/500 (default) . It is the variance of the proposal distribution for the Metropolis Hastings Algorithm which is assumed to be a Random Walk.
#'                 \item{"alpha_p"}{= 0.5 (default) It is defined as the ratio of rate of spread of infection by tested positive patients to that by false negatives. We have taken $\alpha_p < 1$ as patients who are tested positive are subjected to quarantine where the chance of spreading the disease is less than that of false negative patients who are mostly unaware of their infectious nature. So, false negative individuals continue to spread the disease freely at a higher rate than tested positive individuals. }
#'                 \item{"alpha_u"}{= 0.7 (default) It is defined as the  scaling factor for the rate of spread of infection by untested individuals. $\alpha_u$ is assumed to be < 1 as U mostly consists of asymptomatic or mildly symptomatic cases who are known to spread the disease at a much lower rate than those with higher levels of symptoms.}
#'                 \item{"beta_1 }{= 0.6 (default) . It is the scaling factor for rate of recovery  for untested individuals .  $\beta_1$ is  assumed to be less than 1.  The condition of Untested individuals is not so severe as they consists of mostly asymptomatic people. So, they are assumed to recover faster than the Current Positive Ones. }
#'                 \item{"beta_2"}{= 0.7 (default) . It is the inverse of the scaling factor for rate of recovery  for false negative individuals .  $\beta_2$ is assumed to be less than 1. It is assumed that the recovery rate is slower than the detected ones for the False Negative ones because they are not getting any hospital treatments. }
#'                 \item{"delta_1}{= 0.3 (default) It is the scaling factor for death rate for undetected individuals .  $\delta_1 $ is assumed to be less than 1. Similarly  for the Untested ones, the death rate is taken to be lesser because they are mostly asymptomatic. So, their probability of dying is much less.}
#'                 \item{"delta_2"}{= 0.7 (default). It is the inverse of  the scaling factor for death rate for false negative individuals . $\delta_2$ is assumed to be less than 1. Same as before, the death rate for False Negative ones are assumed to be higher than the Current detected Positive as they are not receiving proper treatment.}
#'                 \item{"lambda"}{=  1 / (66.26 * 365)(default) Natural birth  rate. The value given here as the default value is the world's common birth  rate.}
#'                 \item{"mu"}{=  1 / (66.26 * 365)(default) Natural  death rates. This is assumed to be equal with natural birth rate for the sake of simplicity.}
#'                 \item{"D_d"}{= 17.8 (default) Mean days till death for positive individuals.}
#'                 \item{"D_e"}{= 5.2 (default) Incubation period .}
#'                 \item{"Dr"}{= 17.8 (default) Mean days till recovery for positive individuals.}
#'                 \item{"f"}{=0.15 (default) False negative probability of RT-PCR test.}
#'                 \item{"mCFR"}{= NULL (It is calculated from the data  by default) It is defined as the ratio of the total reported deceased cases and the total removed cases  till that day.}
#'                 \item{"init.exposed.ratio "}{= 3 (default) This is the scaling factor for the calculation of the initial number of exposed people from the sum of the initial number of unreported, repoted people.}
#'                 \item{"init.confirmed.ratio"}{= 0.15 (default) This is the initial value of the probability of being tested.}
#'                 \item{"opt_num"}{= 100 (default) The number of times an user wants to run the mle optimization before deciding on the best initial parameter.}
#'                 \item{"trace_plot.common_axis"}{=FALSE(Default) This will give the trace plot for  the convergence of the mcmc estimated time varying parameters}
#'                 \item{"save plot"}{=TRUE (Default) It is the option for saving the plots in the directory folder.}
#'
#'                        }
#'
#'
#'
#' @return
#' @export
#'
#' @examples

model_estimateR <- function(data, data_init,N, init_pars = NULL, niter = 1e5, BurnIn = 5e3,
                            model = "Multinomial", plot = TRUE, period_start, end_beta, auto.initialize = TRUE,
                            ... ){
  library(dplyr)

  if(model == "Multinomial"){
    if(! all(c("Confirmed", "Recovered", "Deceased" ) %in% colnames(data))){
      stop("Data does not contain required columns")
    }
  } else if (model == "Poisson" || model == "Binomial"){
    if(! all(c("Confirmed") %in% colnames(data))){
    stop("Data does not contain required columns")
    }
  } else
    stop("Incorrect model specified")

  if(length(data_init) != 6) stop("Incorrect initial values: length must be 6")

  if(any(data < 0) || data_init < 0) stop("Negative values in data")

  var_init = model_initializeR(data = data, data_init = data_init, init_pars = init_pars, model = model, end_beta=end_beta,
                               period_start = period_start, auto.initialize = auto.initialize, ...)

  fix_pars = var_init$fix_pars
  init_state_num = var_init$init_state_num
  init_pars = var_init$init_pars
  period_start = var_init$period_start

  pars_estimate = mcmc_performR(data = data, init_state_num =  init_state_num, init_pars = init_pars, model = model,
                                niter = niter, BurnIn = BurnIn, fix_pars = fix_pars, period_start = period_start, ...)

  ## Plot

  if(plot == TRUE){
    plots <- model_plotR(mcmc_pars = pars_estimate, n_period = length(period_start), data = data,
                         data_initial = data_initial, call = "estimateR", model = model, ...)
    return(list(mcmc_pars = pars_estimate, "plots" = plots))
  }

  return(list(mcmc_pars = pars_estimate))
}


pack.circles <- function(rfix, xfix,
  size=c(100, 100), max.iter=10, overlap=0 ) {
  #
  # Simple circle packing algorithm based on inverse size weighted repulsion
  #
  # config   - matrix with two cols: radius, N
  # size     - width and height of bounding rectangle
  # max.iter - maximum number of iterations to try
  # overlap  - allowable overlap expressed as proportion of joint radii

  # ============================================================================
  #  Global constants
  # ============================================================================
  # round-off tolerance
  TOL <- 0.0001

  # convert overlap to proportion of radius
  if (overlap < 0 | overlap >= 1) {
    stop("overlap should be in the range [0, 1)")
  }
  PRADIUS <- 1 - overlap

  NCIRCLES <- length(rfix)
  # ============================================================================
  #  Helper function - Draw a circle
  # ============================================================================
  draw.circle <- function(x, y, r, col) {
    lines( cos(seq(0, 2*pi, pi/180)) * r + x, sin(seq(0, 2*pi, pi/180)) * r + y , col=col )
  }

  # ============================================================================
  #  Helper function - Move two circles apart. The proportion of the required
  #  distance moved by each circle is proportional to the size of the other
  #  circle. For example, If a c1 with radius r1 overlaps c2 with radius r2,
  #  and the movement distance required to separate them is ds, then c1 will
  #  move ds * r2 / (r1 + r2) while c2 will move ds * r1 / (r1 + r2). Thus,
  #  when a big circle overlaps a little one, the little one moves a lot while
  #  the big one moves a little.
  # ============================================================================
  repel <- function(xyr, c0, c1) {
    dx <- xyr[c1, 1] - xyr[c0, 1]
    dy <- xyr[c1, 2] - xyr[c0, 2]
    d <- sqrt(dx*dx + dy*dy)
    r <- xyr[c1, 3] + xyr[c0, 3]
    w0 <- xyr[c1, 3] / r
    w1 <- xyr[c0, 3] / r

    if (d < r - TOL) {
      p <- (r - d) / d
      # xyr[c1, 1] <<- toroid(xyr[c1, 1] + p*dx*w1, 1)
      xyr[c1, 2] <<- toroid(xyr[c1, 2] + p*dy*w1, 2)
      # xyr[c0, 1] <<- toroid(xyr[c0, 1] - p*dx*w0, 1)
      xyr[c0, 2] <<- toroid(xyr[c0, 2] - p*dy*w0, 2)

      return(TRUE)
    }

    return(FALSE)
  }

  # ============================================================================
  #  Helper function - Adjust a coordinate such that if it is distance d beyond
  #  an edge (ie. outside the area) it is moved to be distance d inside the
  #  opposite edge. This has the effect of treating the area as a toroid.
  # ============================================================================
  toroid <- function(coord, axis) {
    tcoord <- coord

    if (coord < 0) {
      tcoord <- coord + size[axis]
    } else if (coord >= size[axis]) {
      tcoord <- coord - size[axis]
    }

    tcoord
  }

  # ============================================================================
  #  Main program
  # ============================================================================

  # ------------------------------------------
  # create a random initial layout
  # ------------------------------------------
  xyr <- matrix(0, NCIRCLES, 3)

  # generate random y axis
  all_y <- runif(NCIRCLES, size[2] * 0.3, size[2] * 0.7)
  # arrange y axis so larger dot in the middle
  generated.rank <- order(abs(all_y - size[2] / 2), decreasing = TRUE)
  data.rank <- order(rfix)

  for (i in 1:length(rfix)) {
    # rearranging x axis to new size
    xyr[i, 1] <- (xfix[i] - min(xfix))/(max(xfix) - min(xfix)) * size[1]
    xyr[data.rank[i], 2] <- all_y[generated.rank[i]]
    xyr[i, 3] <- rfix[i] * PRADIUS
  }

  # ------------------------------------------
  # iteratively adjust the layout
  # ------------------------------------------
  for (iter in 1:max.iter) {
    moved <- FALSE
    for (i in 1:(NCIRCLES-1)) {
      for (j in (i+1):NCIRCLES) {
        if (repel(xyr, i, j)) {
          moved <- TRUE
        }
      }
    }
    cat(".")
    if (!moved) break
  }

  cat(paste(iter, "iterations\n"));

  # ------------------------------------------
  # draw the layout
  # ------------------------------------------
  plot(0, type="n", xlab="x", xlim=c(0,size[1]), ylab="y", ylim=c(0, size[2]))

  xyr[, 3] <- xyr[, 3] / PRADIUS
  for (i in 1:nrow(xyr)) {
    draw.circle(xyr[i, 1], xyr[i, 2], xyr[i, 3], "gray")
  }

  # ------------------------------------------
  # return the layout
  # ------------------------------------------
  colnames(xyr) <- c("x", "y", "radius")
  invisible(xyr)
}


#' math
#'
#' Basic math operations, like trig, rounding, exp/logs.
#'
#' @details
#' In each case, the corresponding base R function is called on the local data.
#'
#' @section Communication:
#' Each operation is completely local.
#'
#' @param x
#' A shaq or a numeric vector.
#' @param base
#' Logarithm base.
#' @param digits
#' Number of decimal places to use.
#' @param ...
#' Additional arguments.
#'
#' @return
#' A shaq.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#' y = ranshaq(runif, 10, 3)
#'
#' sqrt(x)
#' log(y)
#'
#' finalize()
#' }
#'
#' @name math
#' @rdname math
NULL

ply_simple = function(x, fun, ...)
{
  DATA(x) = fun(DATA(x), ...)
  x
}

# ------------------------------------------------------------------------------
# exp and log
# ------------------------------------------------------------------------------

#' @rdname math
#' @export
setMethod("sqrt", signature(x="shaq"), function(x) ply_simple(x, sqrt))

#' @rdname math
#' @export
setMethod("abs", signature(x="shaq"), function(x) ply_simple(x, abs))

#' @rdname math
#' @export
setMethod("exp", signature(x="shaq"), function(x) ply_simple(x, exp))

#' @rdname math
#' @export
setMethod("log", signature(x="shaq"), function(x, base=exp(1)) ply_simple(x, log, base=base))

#' @rdname math
#' @export
setMethod("log2", signature(x="shaq"), function(x) ply_simple(x, log2))

#' @rdname math
#' @export
setMethod("log10", signature(x="shaq"), function(x) ply_simple(x, log10))

# ------------------------------------------------------------------------------
# trig
# ------------------------------------------------------------------------------

#' @rdname math
#' @export
setMethod("sin", signature(x="shaq"), function(x) ply_simple(x, sin))

#' @rdname math
#' @export
setMethod("cos", signature(x="shaq"), function(x) ply_simple(x, cos))

#' @rdname math
#' @export
setMethod("tan", signature(x="shaq"), function(x) ply_simple(x, tan))

#' @rdname math
#' @export
setMethod("asin", signature(x="shaq"), function(x) ply_simple(x, asin))

#' @rdname math
#' @export
setMethod("acos", signature(x="shaq"), function(x) ply_simple(x, acos))

#' @rdname math
#' @export
setMethod("atan", signature(x="shaq"), function(x) ply_simple(x, atan))

#' @rdname math
#' @export
setMethod("sinh", signature(x="shaq"), function(x) ply_simple(x, sinh))

#' @rdname math
#' @export
setMethod("cosh", signature(x="shaq"), function(x) ply_simple(x, cosh))

#' @rdname math
#' @export
setMethod("tanh", signature(x="shaq"), function(x) ply_simple(x, tanh))

#' @rdname math
#' @export
setMethod("asinh", signature(x="shaq"), function(x) ply_simple(x, asinh))

#' @rdname math
#' @export
setMethod("acosh", signature(x="shaq"), function(x) ply_simple(x, acosh))

#' @rdname math
#' @export
setMethod("atanh", signature(x="shaq"), function(x) ply_simple(x, atanh))

# ------------------------------------------------------------------------------
# rounding
# ------------------------------------------------------------------------------

#' @rdname math
#' @export
setMethod("ceiling", signature(x="shaq"), function(x) ply_simple(x, ceiling))

#' @rdname math
#' @export
setMethod("floor", signature(x="shaq"), function(x) ply_simple(x, floor))

#' @rdname math
#' @export
setMethod("trunc", signature(x="shaq"), function(x, ...) ply_simple(x, trunc, ...))

#' @rdname math
#' @export
setMethod("round", signature(x="shaq"), function(x, digits=0) ply_simple(x, round, digits=digits))


There are 517 Heronian triangles up to a maximal side length of 200.
Showing the first ten ordered first by perimeter, then by area:
       a  b  c perimeter area
 [1,]  3  4  5        12    6
 [2,]  5  5  6        16   12
 [3,]  5  5  8        18   12
 [4,]  5 12 13        30   30
 [5,]  4 13 15        32   24
 [6,]  9 10 17        36   36
 [7,] 10 13 13        36   60
 [8,]  8 15 17        40   60
 [9,]  7 15 20        42   42
[10,] 13 14 15        42   84


#' Shrinkage-based Diagonal Quadratic Discriminant Analysis (SDQDA)
#'
#' Given a set of training data, this function builds the Shrinkage-based
#' Diagonal Quadratic Discriminant Analysis (SDQDA) classifier, which is based
#' on the DQDA classifier, often attributed to Dudoit et al. (2002). The DQDA
#' classifier belongs to the family of Naive Bayes classifiers, where the
#' distributions of each class are assumed to be multivariate normal. To improve
#' the estimation of the class variances, Pang et al. (2009) proposed the SDQDA
#' classifier which uses a shrinkage-based estimators of each class covariance
#' matrix.
#'
#' The DQDA classifier is a modification to the well-known QDA classifier, where
#' the off-diagonal elements of the pooled covariance matrix are assumed to be
#' zero -- the features are assumed to be uncorrelated. Under multivariate
#' normality, the assumption uncorrelated features is equivalent to the
#' assumption of independent features. The feature-independence assumption is a
#' notable attribute of the Naive Bayes classifier family. The benefit of these
#' classifiers is that they are fast and have much fewer parameters to estimate,
#' especially when the number of features is quite large.
#'
#' The matrix of training observations are given in `x`. The rows of
#' `x` contain the sample observations, and the columns contain the
#' features for each training observation.
#'
#' The vector of class labels given in `y` are coerced to a `factor`.
#' The length of `y` should match the number of rows in `x`.
#'
#' An error is thrown if a given class has less than 2 observations because the
#' variance for each feature within a class cannot be estimated with less than 2
#' observations.
#'
#' The vector, `prior`, contains the _a priori_ class membership for
#' each class. If `prior` is NULL (default), the class membership
#' probabilities are estimated as the sample proportion of observations
#' belonging to each class. Otherwise, `prior` should be a vector with the
#' same length as the number of classes in `y`. The `prior`
#' probabilities should be nonnegative and sum to one.
#'
#' @export
#'
#' @inheritParams lda_diag
#' @param num_alphas the number of values used to find the optimal amount of
#' shrinkage
#' @return `qda_shrink_cov` object that contains the trained SDQDA classifier
#'
#' @references Dudoit, S., Fridlyand, J., & Speed, T. P. (2002). "Comparison of
#' Discrimination Methods for the Classification of Tumors Using Gene Expression
#' Data," Journal of the American Statistical Association, 97, 457, 77-87.
#' @references Pang, H., Tong, T., & Zhao, H. (2009). "Shrinkage-based Diagonal
#' Discriminant Analysis and Its Applications in High-Dimensional Data,"
#' Biometrics, 65, 4, 1021-1029.
#' @examples
#' library(modeldata)
#' data(penguins)
#' pred_rows <- seq(1, 344, by = 20)
#' penguins <- penguins[, c("species", "body_mass_g", "flipper_length_mm")]#' set.seed(42)

#' sdqda_out <- qda_shrink_cov(species ~ ., data = penguins[-pred_rows, ])
#' predicted <- predict(sdqda_out, penguins[pred_rows, -1], type = "class")
#'
#' sdqda_out2 <- qda_shrink_cov(x = penguins[-pred_rows, -1], y = penguins$species[-pred_rows])
#' predicted2 <- predict(sdqda_out2, penguins[pred_rows, -1], type = "class")
#' all.equal(predicted, predicted2)
qda_shrink_cov <- function(x, ...) {
  UseMethod("qda_shrink_cov")
}

#' @rdname qda_shrink_cov
#' @export
qda_shrink_cov.default <- function(x, y, prior = NULL, num_alphas = 101, ...) {
  x <- pred_to_matrix(x)
  y <- outcome_to_factor(y)
  complete <- complete.cases(x) & complete.cases(y)
  x <- x[complete,,drop = FALSE]
  y <- y[complete]

  obj <- diag_estimates(x, y, prior, pool = FALSE)

  # Calculates the shrinkage-based estimator for each diagonal sample class
  # covariance matrix. We add these to the corresponding obj$est$var_shrink
  for(k in seq_len(obj$num_groups)) {
    obj$est[[k]]$var_shrink <- var_shrinkage(
      N = obj$est[[k]]$n,
      K = 1,
      var_feature = obj$est[[k]]$var,
      num_alphas = num_alphas,
      t = -1
    )
  }

  # Creates an object of type 'qda_shrink_cov'
  obj$col_names <- colnames(x)
  obj <- new_discrim_object(obj, "qda_shrink_cov")

  obj
}

#' @inheritParams lda_diag
#' @importFrom stats model.frame model.matrix model.response
#' @rdname qda_shrink_cov
#' @export
qda_shrink_cov.formula <- function(formula, data, prior = NULL, num_alphas = 101, ...) {
  # The formula interface includes an intercept. If the user includes the
  # intercept in the model, it should be removed. Otherwise, errors and doom
  # happen.
  # To remove the intercept, we update the formula, like so:
  # (NOTE: The terms must be collected in case the dot (.) notation is used)
  formula <- no_intercept(formula, data)

  mf <- model.frame(formula = formula, data = data)
  .terms <- attr(mf, "terms")
  x <- model.matrix(.terms, data = mf)
  y <- model.response(mf)

  est <- qda_shrink_cov.default(x = x, y = y, prior = prior, num_alphas = num_alphas)

  est$.terms <- .terms
  est <- new_discrim_object(est, class(est))
  est
}

#' Outputs the summary for a SDQDA classifier object.
#'
#' Summarizes the trained SDQDA classifier in a nice manner.
#'
#' @param x object to print
#' @param ... unused
#' @keywords internal
#' @export
print.qda_shrink_cov <- function(x, ...) {
  cat("Shrinkage-Based Diagonal QDA\n\n")
  print_basics(x, ...)
  invisible(x)
}

#' SDQDA prediction of the class membership of a matrix of new observations.
#'
#' The SDQDA classifier is a modification to QDA, where the off-diagonal
#' elements of the pooled sample covariance matrix are set to zero. To improve
#' the estimation of the pooled variances, we use a shrinkage method from Pang
#' et al.  (2009).
#'
#' @rdname qda_shrink_cov
#' @export
#' @inheritParams predict.lda_diag

predict.qda_shrink_cov <- function(object, newdata, type = c("class", "prob", "score"), ...) {
  type <- rlang::arg_match0(type, c("class", "prob", "score"), arg_nm = "type")
  newdata <- process_newdata(object, newdata)

  scores <- apply(newdata, 1, function(obs) {
    sapply(object$est, function(class_est) {
      with(class_est, sum((obs - xbar)^2 / var_shrink + log(var_shrink))
           + log(prior))
    })
  })

  if (type == "prob") {
    # Posterior probabilities via Bayes Theorem
    means <- lapply(object$est, "[[", "xbar")
    covs <- lapply(object$est, "[[", "var_shrink")
    priors <- lapply(object$est, "[[", "prior")
    res <- posterior_probs(x = newdata, means = means, covs = covs, priors = priors)
    res <- as.data.frame(res)

  } else if (type == "class") {
    res <- score_to_class(scores, object)
  } else {
    res <- t(scores)
    res <- as.data.frame(res)
  }
  res
}


                         CHAPTER  3

                    Arithmetic Functions

     This chapter describes FRANZ LISP's functions for doing
arithmetic.  Often the same function is known by many names.
For example, _a_d_d is also _p_l_u_s, and _s_u_m.  This is  caused  by
our  desire  to  be  compatible with other Lisps.  The FRANZ
LISP user should avoid using functions with names such as  +
and * unless their arguments are fixnums.  The Lisp compiler
takes advantage of these implicit declarations.

     An attempt to divide or to generate  a  floating  point
result  outside  of the range of floating point numbers will
cause a floating exception signal from  the  UNIX  operating
system.   The  user  can catch and process this interrupt if
desired (see the description of the _s_i_g_n_a_l function).

   3.1.  Simple Arithmetic Functions

(add ['n_arg1 ...])
(plus ['n_arg1 ...])
(sum ['n_arg1 ...])
(+ ['x_arg1 ...])

     RETURNS: the sum of the arguments. If no arguments  are
              given, 0 is returned.

     NOTE: if the size of the partial sum exceeds the  limit
           of a fixnum, the partial sum will be converted to
           a bignum.  If any of the arguments  are  flonums,
           the  partial  sum  will  be converted to a flonum
           when that argument is processed  and  the  result
           will thus be a flonum.  Currently, if in the pro-
           cess of doing the addition a bignum must be  con-
           verted  into  a  flonum  an  error  message  will
           result.

9

9Arithmetic Functions                                     3-1

Arithmetic Functions                                     3-2

(add1 'n_arg)
(1+ 'x_arg)

     RETURNS: its argument plus 1.

(diff ['n_arg1 ... ])
(difference ['n_arg1 ... ])
(- ['x_arg1 ... ])

     RETURNS: the result of subtracting from n_arg1 all sub-
              sequent  arguments. If no arguments are given,
              0 is returned.

     NOTE: See the description of add for  details  on  data
           type conversions and restrictions.

(sub1 'n_arg)
(1- 'x_arg)

     RETURNS: its argument minus 1.

(minus 'n_arg)

     RETURNS: zero minus n_arg.

(product ['n_arg1 ... ])
(times ['n_arg1 ... ])
(* ['x_arg1 ... ])

     RETURNS: the product  of  all  of  its  arguments.   It
              returns 1 if there are no arguments.

     NOTE: See the  description  of  the  function  _a_d_d  for
           details  and  restrictions  to the automatic data
           type coercion.

(quotient ['n_arg1 ...])
(/ ['x_arg1 ...])

     RETURNS: the result of dividing the first  argument  by
              succeeding ones.

     NOTE: If there are no arguments, 1  is  returned.   See
           the  description  of the function _a_d_d for details
           and restrictions of data type coercion.  A divide
           by zero will cause a floating exception interrupt
           -- see the description of the _s_i_g_n_a_l function.

9

9                                   Printed: January 31, 1984

Arithmetic Functions                                     3-3

(*quo 'i_x 'i_y)

     RETURNS: the integer part of i_x / i_y.

(Divide 'i_dividend 'i_divisor)

     RETURNS: a list whose car is  the  quotient  and  whose
              cadr  is  the  remainder  of  the  division of
              i_dividend by i_divisor.

     NOTE: this is restricted to integer division.

(Emuldiv 'x_fact1 'x_fact2 'x_addn 'x_divisor)

     RETURNS: a list of the quotient and remainder  of  this
              operation:
              ((x_fact1 * x_fact2) + (sign extended) x_addn) / x_divisor.

     NOTE: this  is  useful for creating a bignum arithmetic
           package in Lisp.

   3.2.  predicates

(numberp 'g_arg)

(numbp 'g_arg)

     RETURNS: t iff g_arg is a  number  (fixnum,  flonum  or
              bignum).

(fixp 'g_arg)

     RETURNS: t iff g_arg is a fixnum or bignum.

(floatp 'g_arg)

     RETURNS: t iff g_arg is a flonum.

(evenp 'x_arg)

     RETURNS: t iff x_arg is even.

9

9                                   Printed: January 31, 1984

Arithmetic Functions                                     3-4

(oddp 'x_arg)

     RETURNS: t iff x_arg is odd.

(zerop 'g_arg)

     RETURNS: t iff g_arg is a number equal to 0.

(onep 'g_arg)

     RETURNS: t iff g_arg is a number equal to 1.

(plusp 'n_arg)

     RETURNS: t iff n_arg is greater than zero.

(minusp 'g_arg)

     RETURNS: t iff g_arg is a negative number.

(greaterp ['n_arg1 ...])
(> 'fx_arg1 'fx_arg2)
(>& 'x_arg1 'x_arg2)

     RETURNS: t iff the arguments are in a strictly decreas-
              ing order.

     NOTE: In functions _g_r_e_a_t_e_r_p and > the function  _d_i_f_f_e_r_-
           _e_n_c_e  is  used to compare adjacent values. If any
           of the arguments are non-numbers, the error  mes-
           sage will come from the _d_i_f_f_e_r_e_n_c_e function.  The
           arguments to > must  be fixnums or both  flonums.
           The arguments to >& must both be fixnums.

(lessp ['n_arg1 ...])
(< 'fx_arg1 'fx_arg2)
(<& 'x_arg1 'x_arg2)

     RETURNS: t iff the arguments are in a strictly increas-
              ing order.

     NOTE: In functions _l_e_s_s_p and < the function  _d_i_f_f_e_r_e_n_c_e
           is used to compare adjacent values. If any of the
           arguments are non numbers, the error message will
           come from the _d_i_f_f_e_r_e_n_c_e function.  The arguments
           to < may be either fixnums or flonums but must be
           the  same type.  The arguments to <& must be fix-
           nums.

9

9                                   Printed: January 31, 1984

Arithmetic Functions                                     3-5

(= 'fx_arg1 'fx_arg2)

(=& 'x_arg1 'x_arg2)

     RETURNS: t iff the arguments have the same value.   The
              arguments to = must be the either both fixnums
              or both flonums.  The arguments to =& must  be
              fixnums.

   3.3.  Trignometric Functions

           Some of these funtcions are taken from  the  host
      math  library,  and  we take no further responsibility
      for their accuracy.

(cos 'fx_angle)

     RETURNS: the (flonum)  cosine  of  fx_angle  (which  is
              assumed to be in radians).

(sin 'fx_angle)

     RETURNS: the sine of fx_angle (which is assumed  to  be
              in radians).

(acos 'fx_arg)

     RETURNS: the (flonum) arc cosine of fx_arg in the range
              0 to J.

(asin 'fx_arg)

     RETURNS: the (flonum) arc sine of fx_arg in  the  range
              -J/2 to J/2.

(atan 'fx_arg1 'fx_arg2)

     RETURNS: the (flonum) arc tangent of fx_arg1/fx_arg2 in
              the range -J to J.

   3.4.  Bignum/Fixnum Manipulation

9

9                                   Printed: January 31, 1984

Arithmetic Functions                                     3-6

(haipart bx_number x_bits)

     RETURNS: a fixnum (or bignum) which contains the x_bits
              high  bits  of  (_a_b_s _b_x__n_u_m_b_e_r)  if  x_bits is
              positive,    otherwise    it    returns    the
              (_a_b_s _x__b_i_t_s) low bits of (_a_b_s _b_x__n_u_m_b_e_r).

(haulong bx_number)

     RETURNS: the number of significant bits in bx_number.

     NOTE: the result is equal to the least integer  greater
           to or equal to the base two logarithm of one plus
           the absolute value of bx_number.

(bignum-leftshift bx_arg x_amount)

     RETURNS: bx_arg shifted left by x_amount.  If  x_amount
              is  negative,  bx_arg will be shifted right by
              the magnitude of x_amount.

     NOTE: If bx_arg is shifted right, it will be rounded to
           the nearest even number.

(sticky-bignum-leftshift 'bx_arg 'x_amount)

     RETURNS: bx_arg shifted left by x_amount.  If  x_amount
              is  negative,  bx_arg will be shifted right by
              the magnitude of x_amount and rounded.

     NOTE: sticky rounding is done this way: after shifting,
           the low order bit is changed to 1 if any 1's were
           shifted off to the right.

   3.5.  Bit Manipulation

(boole 'x_key 'x_v1 'x_v2 ...)

     RETURNS: the result of the bitwise boolean operation as
              described in the following table.

     NOTE: If there are more than 3 arguments, then  evalua-
           tion  proceeds  left  to  right with each partial
           result becoming the new value of x_v1.  That is,
                (_b_o_o_l_e '_k_e_y '_v_1 '_v_2 '_v_3) =_ (_b_o_o_l_e '_k_e_y (_b_o_o_l_e '_k_e_y '_v_1 '_v_2) '_v_3).
           In the following table, * represents bitwise and,
           + represents bitwise or, O+ represents bitwise xor
           and  _  represents  bitwise  negation  and is the
           highest precedence operator.

Arithmetic Functions                                     3-7

8____________________________________________________________________________________________
                                     (boole 'key 'x 'y)

8________________________________________________________________________________________________________________________________________________________________________________________
  key         0          1          2         3         4          5          6         7
 result       0        x * y     _ x * y      y      x * _ y       x        x O+ y     x + y

 common
 names                  and                          bitclear                xor       or

8____________________________________________________________________________________________

  key         8          9         10        11         12        13         14        15
 result   _ (x + y)   _(x O+ y)     _ x     _ x + y     _ y      x + _ y   _ x + _ y    -1
 common
 names       nor       equiv               implies                          nand
8____________________________________________________________________________________________
7|8|7|7|7|7|7|7|7|7|7|7|7|7|7|

9                                                                                |8|7|7|7|7|7|7|7|7|7|7|7|7|7|

9
(lsh 'x_val 'x_amt)

     RETURNS: x_val shifted left by x_amt if x_amt is  posi-
              tive.   If x_amt is negative, then _l_s_h returns
              x_val shifted right by the magnitude if x_amt.

     NOTE: This always  returns  a  fixnum  even  for  those
           numbers  whose  magnitude  is  so large that they
           would normally be represented as a  bignum,  i.e.
           shifter  bits  are  lost.   For  more general bit
           shifters,  see   _b_i_g_n_u_m-_l_e_f_t_s_h_i_f_t   and   _s_t_i_c_k_y-
           _b_i_g_n_u_m-_l_e_f_t_s_h_i_f_t.

(rot 'x_val 'x_amt)

     RETURNS: x_val rotated left by x_amt if x_amt is  posi-
              tive.  If  x_amt  is  negative,  then x_val is
              rotated right by the magnitude of x_amt.

   3.6.  Other Functions

           As noted above, some of the  following  functions
      are  inherited  from  the  host math library, with all
      their virtues and vices.

9

9                                   Printed: January 31, 1984

Arithmetic Functions                                     3-8

(abs 'n_arg)
(absval 'n_arg)

     RETURNS: the absolute value of n_arg.

(exp 'fx_arg)

     RETURNS: _e raised to the fx_arg power (flonum) .

(expt 'n_base 'n_power)

     RETURNS: n_base raised to the n_power power.

     NOTE: if either of the arguments are flonums, the  cal-
           culation will be done using _l_o_g and _e_x_p.

(fact 'x_arg)

     RETURNS: x_arg factorial. (fixnum or bignum)

(fix 'n_arg)

     RETURNS: a fixnum as close as we can get to n_arg.

     NOTE: _f_i_x will round down.  Currently, if  n_arg  is  a
           flonum  larger  than  the  size of a fixnum, this
           will fail.

(float 'n_arg)

     RETURNS: a flonum as close as we can get to n_arg.

     NOTE: if n_arg is a bignum larger than the maximum size
           of  a  flonum,  then  a  floating  exception will
           occur.

(log 'fx_arg)

     RETURNS: the natural logarithm of fx_arg.

(max 'n_arg1 ... )

     RETURNS: the maximum value in the list of arguments.

9

9                                   Printed: January 31, 1984

Arithmetic Functions                                     3-9

(min 'n_arg1 ... )

     RETURNS: the minimum value in the list of arguments.

(mod 'i_dividend 'i_divisor)
(remainder 'i_dividend 'i_divisor)

     RETURNS: the remainder when i_dividend  is  divided  by
              i_divisor.

     NOTE: The sign of the result will have the same sign as
           i_dividend.

(*mod 'x_dividend 'x_divisor)

     RETURNS: the  balanced  representation  of   x_dividend
              modulo x_divisor.

     NOTE: the  range  of  the  balanced  representation  is
           abs(x_divisor)/2    to    (abs(x_divisor)/2)    -
           x_divisor + 1.

(random ['x_limit])

     RETURNS: a fixnum between 0 and x_limit - 1 if  x_limit
              is  given.   If x_limit is not given, any fix-
              num, positive or negative, might be returned.

(sqrt 'fx_arg)

     RETURNS: the square root of fx_arg.

9

9                                   Printed: January 31, 1984


not <- function(x) { 1-x }
library(MASS)

a <- fractions(0.91)
b <- fractions(0.92)
c <- fractions(0.53)
ac <- not(a)
bc <- not(b)
cc <- not(c)
adenom <- a*bc*cc
bdenom <- ac*b*cc
cdenom <- ac*bc*c
h <- adenom + bdenom + cdenom
afinal <- adenom/h
bfinal <- bdenom/h
cfinal <- cdenom/h

print(afinal)
print(bfinal)
print(cfinal)


# Day 21: Dirac Dice

get_day21_input_path <- function() {
    paste(getwd(), "/2021/Day 21/Day21_input.txt", sep = "")
}

part1 <- function() {
    readings <- readLines(get_day21_input_path())

    p1_start <- as.numeric(unlist(strsplit(readings[1], ": "))[2])
    p2_start <- as.numeric(unlist(strsplit(readings[2], ": "))[2])

    p1_cur_space <- p1_start
    p2_cur_space <- p2_start

    num_rolls <- 0
    p1_score <- 0
    p2_score <- 0

    turn_num <- 1
    game_won <- FALSE

    while (!game_won) {
        sum_of_rolls <- 0
        for (i in 1:3) {
            sum_of_rolls <- sum_of_rolls + roll_det_100_die(num_rolls)
            num_rolls <- num_rolls + 1
        }
        if (turn_num %% 2 == 0) {
            p2_cur_space <- board_10_move_pawn(p2_cur_space, sum_of_rolls)
            p2_score <- p2_score + p2_cur_space

            if (p2_score >= 1000) {
                game_won <- TRUE
            }
        } else {
            p1_cur_space <- board_10_move_pawn(p1_cur_space, sum_of_rolls)
            p1_score <- p1_score + p1_cur_space

            if (p1_score >= 1000) {
                game_won <- TRUE
            }
        }
        turn_num <- turn_num + 1
    }

    cat("P1 Score: ", p1_score, "\n")
    cat("P2 Score: ", p2_score, "\n")
    cat("Roll Count: ", num_rolls, "\n")
    print(min(c(p1_score, p2_score)) * num_rolls)
}

part2 <- function() {
    print("TODO")
}

roll_det_100_die <- function(times_rolled) {
    if (times_rolled %% 100 == 0) {
        1
    } else {
        times_rolled + 1
    }
}

board_10_move_pawn <- function(cur_pos, num_spaces) {
    spaces_to_move <- num_spaces %% 10

    if (cur_pos + spaces_to_move <= 10) {
        cur_pos + spaces_to_move
    } else {
        (cur_pos + spaces_to_move) %% 10
    }
}

part1()
part2()


;; ==========================================
;; Script: date-time.r
;; downloaded from: www.REBOL.org
;; on: 14-May-2017
;; at: 8:21:19.889817 UTC
;; owner: fvzv [script library member who can
;; update this script]
;; ==========================================
;; ==================================================
;; email address(es) have been munged to protect them
;; from spam harvesters.
;; If you were logged on the email addresses
;; would not be munged
;; ==================================================
REBOL [
	file: %date-time.r
	title: "Date and time functions"
	date: 24-Feb-2011
	version: 1.1
	home: http://rebol.x10.mx
	author: "Francois Vanzeveren"
	email: %brainois--rebol--x10--mx
	purpose: {
		This script contains the Rebol implementation of some date and time functions provided in
		the glibc library and the gnumeric (and therefore Microsoft Excel) software.
		While the use and handling of date and time data are in most cases straightforward
		with Rebol, some of the advanced date and times functionalities found in glibc and
		gnumeric are still missing in Rebol.
		This script is therefore an attempt to fill the gap.
	}
	language: "English"
	history: [
		1.1 24-Feb-2011 "Francois Vanzeveren" {
			BUG: the function 'week-of-year was not correctly implemented, sometimes
				returning 0 as week number for the first week of the year.
			CLEANSING: iso-week-num removed (redundant with week-of-year/iso)
		}
		1.0 05-Jan-2003 "Francois Vanzeveren" "First public release"
	]
	library: [
		level: 'intermediate
		platform: 'all
		type: [function tool]
		domain: [extension financial]
		tested-under: [linux windows]
		support: none
		license: 'lgpl
		see-also: none
	]
]
;					M T W T F S S
;_base-monday: copy [1 2 3 4 5 6 7]
_base-sunday: copy [2 3 4 5 6 7 1]

end-of-month: function [
{
	Returns the last day of the month which is @months from the @start-date.
}
	start-date [date!]
	months [integer!]
] [
	last-day [integer!]
	new-month [integer!]
	new-year [integer!]
] [
	either greater-or-equal? months 0 [
		new-year: add start-date/year to-integer divide add start-date/month months 12
		new-month: remainder add start-date/month months 12
	] [
		either greater? start-date/month absolute months [
			new-year: start-date/year
			new-month: add start-date/month months
		] [
			new-year: add start-date/year subtract to-integer divide add start-date/month months 12 1
			new-month: add 12 remainder add start-date/month months 12
		]
	]
	last-day: multiply 31 to-integer found? find [0 1 3 5 7 8 10 12] new-month
	if all [not to-logic last-day found? find [4 6 9 11] new-month ] [
		last-day: 30
	]
	if not to-logic last-day [
		last-day: add 28 to-integer leap-year? make date! reduce [1 1 new-year]
	]
	make date! reduce [last-day new-month new-year]
]

end-of-month?: function [
{
	Returns true if @a-date is the last day of its month.
}
	a-date [date!]
] [] [
	equal? a-date end-of-month a-date 0
]

leap-year?: function [
{
	Returns true for a leap year.
}
	date [date!] "The date to check."
] [year [integer!]] [
	 year: date/year
	 any [
		 all [
			 equal? 0 remainder year 4
			 not-equal? 0 remainder year 100
		 ]
		 equal? 0 remainder year 400
	 ]
]

date-dif: function [
{
	Returns the difference between two dates.
}
	date1 [date!]
	date2 [date!]
	/y	{Returns the number of complete years between @date1 and @date2.}
	/m	{Returns the number of complete months between @date1 and @date2.}
	/d	{Returns the number of complete days between @date1 and @date2.}
	/ym	{Returns the number of full months between @date1 and @date2,
		not including the difference in years.}
	/md	{Returns the number of full days between @date1 and @date2,
		not including the difference in months.}
	/yd	{Returns the number of full days between @date1 and @date2,
		not including the difference in years.}
] [] [
	if y [
		return
		subtract
		subtract date2/year date1/year
		to-integer	any [ 	lesser? date2/month date1/month
							all [	equal? date2/month date1/month
									lesser? date2/day date1/day
							]
					]
	]
	if m [
		return
		subtract
		subtract
		add
		multiply
		subtract date2/year date1/year
		12
		date2/month
		date1/month
		to-integer lesser? date2/day date1/day
	]
	if ym [
		return
		either any [lesser? date1/month date2/month
					all [ equal? date1/month date2/month
						lesser-or-equal? date1/day date2/day
					]
		] [
			subtract
			subtract date2/month date1/month
			to-integer greater? date1/day date2/day
		] [
			subtract
			add
			subtract 12 date1/month
			date2/month
			to-integer greater? date1/day date2/day
		]
	]
	if md [
		return
		subtract
		add date2/day
		multiply get-refinement end-of-month date2 -1 'day to-integer greater? date1/day date2/day
		date1/day
	]
	if yd [
		if all [equal? date1/day date2/day
				equal? date1/month date2/month
		] [ return 0 ]
		return
		either any [
			greater? date2/month date1/month
			all [
				equal? date2/month date1/month
				greater? date2/day date1/day
			]
		] [
			use [ start-date [date!]] [
				start-date: make date! reduce [date1/day date1/month date2/year]
				subtract date2 start-date
			]
		] [
			use [ start-date [date!]] [
				start-date: make date! reduce [date1/day date1/month subtract date2/year 1 ]
				subtract date2 start-date
			]
		]
	]

	return subtract date2 date1
]

days360: function [
{
	Returns the number of days from @date1 to @date2
	following a 360-day calendar in which all months
	are assumed to have 30 days. By default, the US method is used.
}
	date1 [date!] "Starting date"
	date2 [date!] "Ending date"
	/euro {The European method will be used. In this case, if the day of
		the month is 31 it will be considered as 30.}
	/us {U.S. (NASD) method. If the starting date is the 31st of a month,
		it becomes equal to the 30th of the same month. If the ending
		date is the 31st of a month and the starting date is earlier
		than the 30th of a month, the ending date becomes equal to
		the 1st of the next month, otherwise the ending date becomes
		equal to the 30th of the same month.
		This is the default behaviour.}
] [] [
	either euro [
		;euro
		date1: subtract date1 to-integer equal? date1/day 31
		date2: subtract date2 to-integer equal? date2/day 31
	] [
		;US or default
		either all [
			end-of-month? date1
			end-of-month? date2
		] [
			date1/day: min date1/day date2/day
			date2/day: min date1/day date2/day
		] [
			date1: subtract date1 to-integer all [
				equal? date1/day 31
				any [ not-equal? date1/month date2/month
					not-equal? date1/year date2/year
					equal? date2/day 30
				]
			]
			if all [ equal? date1/month 2 ; February
				equal? date1/day 29 ; End of february for leap year...
				greater-or-equal? date2 subtract end-of-month date1 0 1
				any [ not-equal? date1/month date2/month
					not-equal? date1/year date2/year
				]
			] [
				date2: subtract date2 1
			]
			if equal? date2/day 31 [
				either lesser? date1/day 30 [
					date2: add date2 1
				][
					date2: subtract date2 1
				]
			]
		]
	]
	return
		add
		add
		multiply date-dif/m date1 date2 30
		multiply 30 to-integer lesser? date2/day date1/day
		subtract date2/day date1/day
]

edate: function [
{
	Returns the date that is the specified number of months
	before or after a given date.
}
	initial-date [date!] "The initial date."
	months [integer!] {The number of months before (negative number) or
		after (positive number) the initial date.}
] [
	new-day [integer!]
	new-month [integer!]
	new-year [integer!]
	new-date [integer!]
] [
	new-day: initial-date/day
	new-month: remainder add initial-date/month months 12
	new-year: add initial-date/year to-integer divide add initial-date/month months 12
	new-date: end-of-month make date! reduce [1 new-month new-year] 0
	if lesser? new-day new-date/day [
		new-date/day: new-day
	]
	return new-date
]

day-of-year: function [
{
	Returns the day number within @the-date/year.
	The first day of the year has value 1.
}
	the-date [date!]
] [] [
	add 1 subtract the-date make date! reduce [the-date/year 1 1]
]

week-of-year: function [
{
	Return the week of the year.
	The first week of the year has value 1.
}
	the-date [date!]
	/monday "Weeks are understood to start on Monday"
	/sunday "Weeks are understood to start on Sunday."
	/iso {Returns the ISO 8601 week number of @the-date.
		An ISO 8601 week starts on Monday. Weeks are numbered from 1.
		Week 01 of a year is per definition the first week that
		has the Thursday in this year, which is equivalent to
		the week that contains the fourth day of January. In other
		words, the first week of a new year is the week that has
		the majority of its days in the new year. Week 01 might also
		contain days from the previous year and the week before week
		01 of a year is the last week (52 or 53) of the previous year
		even if it contains days from the new year.
		See http://www.techno-science.net/?onglet=glossaire&definition=3075
	}
] [
	week [integer!]
	wd [integer!]
	day [integer!]
	jan1date [date!]
	mon [date!]
	thur [date!]
] [
	either iso [
		thur: add the-date
				subtract 4 the-date/weekday
		mon: make date! reduce [thur/year 1 4]
		mon: add mon
				subtract 1 mon/weekday
		week: round/ceiling divide subtract thur mon 7
	] [
		jan1date: make date! reduce [the-date/year 1 1]
		wd: jan1date/weekday ; Weeks are understood to start on Monday
		if sunday [
			; Weeks are understood to start on Sunday
			wd: pick _base-sunday wd
		]
		wd: subtract wd 1
		day: subtract day-of-year the-date 1
		week: add 1 to-integer divide add day wd 7
	]

	week ; return value
]

net-work-days: function [
{
	Returns the number of whole working days, beginning with
	@start_date and ending with @end_date, excluding days in
	@dates and weekends.
}
	start-date [date!]
	end-date [date!]
	/holidays dates [block!]
] [
	nb-of-holidays [integer!]
	diff-in-weeks [integer!]
	first-week-nwd [integer!] ; first week non weekend days
	last-week-nwd [integer!] ; last week non weekend days
	non-weekend-days [integer!]
	first-monday [date!] ; the first monday of the period, first week not included.
	last-friday [date!] ; the last friday of the period, last week not included.
] [
	if greater? start-date end-date [
		use [tmp-date [date!]] [
			tmp-date: end-date
			end-date: start-date
			start-date: tmp-date
		]
	]

	nb-of-holidays: 0
	if holidays [
		; Computes the number of holidays within the period
		foreach item dates [
			if all [
				date? item
				lesser-or-equal? item/weekday 5 ; saturday and sunday are not holidays, but weekend days
				greater-or-equal? item start-date
				lesser-or-equal? item end-date
			][
				nb-of-holidays: add nb-of-holidays 1
			]
		]
	]

	; number of non weekend days during the first week of the period
	first-week-nwd: multiply
		to-integer lesser-or-equal? start-date/weekday 5
		add 1 subtract 5 start-date/weekday
	; number of non weekend days during the last week of the period
	last-week-nwd: either lesser-or-equal? end-date/weekday 5 [ end-date/weekday ] [5]

	; the first monday of the period, first week not included.
	first-monday: add start-date add 1 subtract 7 start-date/weekday
	; the last friday of the period, last week not included.
	last-friday: subtract end-date add 2 end-date/weekday

	non-weekend-days: either greater? last-friday first-monday [
		diff-in-weeks: to-integer divide add 1 subtract last-friday first-monday 7
		add first-week-nwd
		add last-week-nwd
		add 5 multiply 5 diff-in-weeks
	] [
		subtract
			add first-week-nwd last-week-nwd
			multiply 5 to-integer equal?
				subtract end-date/weekday start-date/weekday
				subtract end-date start-date ; start-date and end-date are in the same week!
	]
	; return value
	subtract non-weekend-days nb-of-holidays
]

work-day: function [
{
	Returns the day which is @days working days from the @start-date.
	Weekends and holidays optionally supplied in @dates are respected.
}
	start-date [date!]
	days [integer!]
	/holidays dates [block!]
] [
	weekend-days [integer!]
	end-date [date!]
	days-gap [integer!]
] [
	if not holidays [
		dates: make block! []
	]
	weekend-days: multiply 2
		subtract
			to-integer divide days 5
			to-integer equal? remainder days 5 0

	end-date: add start-date add days weekend-days
	days-gap: add 1 subtract absolute days net-work-days/holidays start-date end-date dates
	while [ not-equal? days-gap 0 ] [
		end-date: either positive? days [add end-date days-gap] [subtract end-date days-gap]
		days-gap: add 1 subtract absolute days net-work-days/holidays start-date end-date dates
	]
	if negative? days [
		while [found? find dates end-date] [
			end-date: add end-date 1
		]
	]
	; return value
	end-date
]


gev.fit2 <- function (xdat, ydat = NULL, mul = NULL, sigl = NULL, shl = NULL,
    mulink = identity, siglink = identity, shlink = identity,
    muinit = NULL, siginit = NULL, shinit = NULL, show = TRUE,
    method = "Nelder-Mead", maxit = 10000, ndeps = 1e-6, ...)
{
  # modification of gev.fit() from ismev by C. Paciorek
  # differences from gev.fit()
  # (1) has params be scalar when no covariates to improve computational efficiency - this only makes much difference in speed when the data vector is fairly long
  # (2) robustly handles NAs in xdat
  # (3) modifies initial values for log link
  # (4) adds 'flag' output that indicates if MLE or standard errors may not be legitimate
  # (5) allows one to change the default step size of the finite difference approximation to the gradient in the optimization

  z <- list()
  npmu <- length(mul) + 1
  npsc <- length(sigl) + 1
  npsh <- length(shl) + 1
  z$trans <- FALSE
  in2 <- sqrt(6 * var(xdat, na.rm=T))/pi
  in1 <- mean(xdat, na.rm=T) - 0.57722 * in2
  if(identical(mulink, exp))
    in1 = log(in1)
  if(!identical(mulink, exp) && !identical(mulink, identity))
    warning("Default initial value for location is on incorrect scale; please supply your own.")
  if(identical(siglink, exp))
    in2 = log(in2)
  if(!identical(siglink, exp) && !identical(siglink, identity))
    warning("Default initial value for scale is on incorrect scale; please supply your own.")
  shinit.default = 0.1
  if(identical(shlink, exp))
    shinit.default = log(shinit.default)
  if(!identical(shlink, exp) && !identical(shlink, identity))
    warning("Default initial value for shape is on incorrect scale; please supply your own.")

  if (is.null(mul)) {
    mumat <- 1  # as.matrix(rep(1, length(xdat)))
    if (is.null(muinit))
      muinit <- in1
  } else {
    z$trans <- TRUE
    mumat <- cbind(rep(1, length(xdat)), ydat[, mul])
    if (is.null(muinit))
      muinit <- c(in1, rep(0, length(mul)))
  }
  if (is.null(sigl)) {
    sigmat <- 1 # as.matrix(rep(1, length(xdat)))
    if (is.null(siginit))
      siginit <- in2
  } else {
    z$trans <- TRUE
    sigmat <- cbind(rep(1, length(xdat)), ydat[, sigl])
    if (is.null(siginit))
      siginit <- c(in2, rep(0, length(sigl)))
  }
  if (is.null(shl)) {
    shmat <- 1  # as.matrix(rep(1, length(xdat)))
    if (is.null(shinit))
      shinit <- shinit.default
  } else {
    z$trans <- TRUE
    shmat <- cbind(rep(1, length(xdat)), ydat[, shl])
    if (is.null(shinit))
      shinit <- c(shinit.default, rep(0, length(shl)))
  }
  z$model <- list(mul, sigl, shl)
  z$link <- deparse(substitute(c(mulink, siglink, shlink)))
  init <- c(muinit, siginit, shinit)
  gev.lik <- function(a) {
    mu <- c(mulink(mumat %*% (a[1:npmu])))
    sc <- c(siglink(sigmat %*% (a[seq(npmu + 1, length = npsc)])))
    xi <- c(shlink(shmat %*% (a[seq(npmu + npsc + 1, length = npsh)])))
    y <- (xdat - mu)/sc
    y <- 1 + xi * y
    if (any(y <= 0, na.rm = TRUE) || any(sc <= 0))
      return(10^6)
    if(length(sc) == 1){
      l <- length(xdat[!is.na(xdat)]) * log(sc)
    } else{
      l <- sum(log(sc[!is.na(xdat)]))
    }
    l <- l + sum(y^(-1/xi), na.rm = TRUE) + sum(log(y) * (1/xi + 1), na.rm = TRUE)
    return(l)
  }
  x <- optim(init, gev.lik, hessian = TRUE, method = method,
             control = list(maxit = maxit, ndeps = rep(ndeps, length = length(init)), ...))
  z$conv <- x$convergence
  mu <- c(mulink(mumat %*% (x$par[1:npmu])))
  sc <- c(siglink(sigmat %*% (x$par[seq(npmu + 1, length = npsc)])))
  xi <- c(shlink(shmat %*% (x$par[seq(npmu + npsc + 1, length = npsh)])))
  z$nllh <- x$value
  z$data <- xdat
  if (z$trans) {
    z$data <- -log(as.vector((1 + (xi * (xdat - mu))/sc)^(-1/xi)))
  }
  z$mle <- x$par
  z$cov <- solve(x$hessian)
  z$se <- sqrt(diag(z$cov))
  z$vals <- cbind(mu, sc, xi)
  if (show) {
    if (z$trans)
      print(z[c(2, 3, 4)])
    else print(z[4])
    if (!z$conv)
      print(z[c(5, 7, 9)])
  }
  z$flag = 0
  if(sum(is.na(c(z$mle, z$se))) || min(xi) < -1 || min(z$se) < 1e-5){
    z$flag = 1
    warning("MLEs and standard errors may not be reliable; please check convergence, estimates, standard errors, and input data.")
  }
  class(z) <- "gev.fit"
  invisible(z)
}


# 4. faza: Analiza podatkov

#-----------------------------------------------------------------------------------------------------------------------------------------------
# Model rasti za elektriko in zemeljski plin
#-----------------------------------------------------------------------------------------------------------------------------------------------

elektrika_TD <- elektrika_TDa
plin_TD <- plin_TDa

names(elektrika_TD) <- c("a","b")
elektrika_TD$a <- as.numeric(as.character(elektrika_TD$a))
elektrika_TD$b <- as.numeric(as.character(elektrika_TD$b))

names(plin_TD) <- c("a","b")
plin_TD$a <- as.numeric(as.character(plin_TD$a))
plin_TD$b <- as.numeric(as.character(plin_TD$b))

modelelektrika <- lm(data=elektrika_TD, b ~ a)
napoved <- predict(modelelektrika, data.frame(a=c(2020, 2021, 2022, 2023, 2024, 2025)))
elektrika_TD1 <- elektrika_TD
elektrika_TD1 <- data.frame(a = c(2020, 2021, 2022, 2023, 2024, 2025),
                            b = c(napoved[1], napoved[2], napoved[3], napoved[4], napoved[5], napoved[6]))

names(elektrika_TD1) <- c("a", "b")

elektrika_TD$vrsta1 <- "podatki"
elektrika_TD1$vrsta1 <- "napoved"
elektrika_TD <- rbind(elektrika_TD, elektrika_TD1)
elektrika_TD$energent <- "Električna energija"

names(elektrika_TD) <- c("leto_in_cetrtletje", "cena_(EUR/kWh)", "vrsta", "energent")

modelplin <- lm(data=plin_TD, b ~ a)
napoved2 <- predict(modelplin, data.frame(a=c(2020, 2021, 2022, 2023, 2024, 2025)))
plin_TD1 <- plin_TD
plin_TD1 <- data.frame(a = c(2020, 2021, 2022, 2023, 2024, 2025),
                            b = c(napoved2[1], napoved2[2], napoved2[3], napoved2[4], napoved2[5], napoved2[6]))

names(plin_TD1) <- c("a", "b")

plin_TD$vrsta2 <- "podatki"
plin_TD1$vrsta2 <- "napoved"
plin_TD <- rbind(plin_TD, plin_TD1)
plin_TD$energent <- "Zemeljski plin"

names(plin_TD) <- c("leto_in_cetrtletje", "cena_(EUR/kWh)", "vrsta", "energent")

rownames(elektrika_TD) <- 1:nrow(elektrika_TD)
rownames(plin_TD) <- 1:nrow(plin_TD)

tabelanapovedi <- rbind(elektrika_TD, plin_TD)
tabelanapovedi$leto_in_cetrtletje <- as.numeric(as.character(tabelanapovedi$leto_in_cetrtletje))
tabelanapovedi$`cena_(EUR/kWh)` <- as.numeric(as.character(tabelanapovedi$`cena_(EUR/kWh)`))

#-----------------------------------------------------------------------------------------------------------------------------------------------
# Model rasti za deleže gospodinjstev
#-----------------------------------------------------------------------------------------------------------------------------------------------

poraba_TD1 <- TD_poraba_gospodinjstev %>% filter(energetski_vir == "Toplota iz okolice (TJ)")
poraba_TD2 <- TD_poraba_gospodinjstev %>% filter(energetski_vir == "Sončna energija (TJ)")
poraba_TD3 <- TD_poraba_gospodinjstev %>% filter(energetski_vir == "Daljinska toplota (TJ)")
poraba_TD1$energetski_vir <- NULL
poraba_TD2$energetski_vir <- NULL
poraba_TD3$energetski_vir <- NULL
poraba_TD1$leto <- as.numeric(as.character(poraba_TD1$leto))
poraba_TD2$leto <- as.numeric(as.character(poraba_TD1$leto))
poraba_TD3$leto <- as.numeric(as.character(poraba_TD1$leto))

# Toplota
modelporabetoplote <- lm(data=poraba_TD1, poraba ~ log(leto))
napoved3 <- predict(modelporabetoplote, data.frame(leto=c(2019, 2020, 2021, 2022, 2023, 2024, 2025, 2026, 2027, 2028, 2029, 2030)))
poraba_TD4 <- poraba_TD1
poraba_TD4 <- data.frame(leto = c(2019, 2020, 2021, 2022, 2023, 2024, 2025, 2026, 2027, 2028, 2029, 2030),
                            poraba = c(napoved3[1], napoved3[2], napoved3[3], napoved3[4], napoved3[5], napoved3[6], napoved3[7], napoved3[8],
                                       napoved3[9], napoved3[10], napoved3[11], napoved3[12]))
poraba_TD1 <- rbind(poraba_TD1, poraba_TD4)
names(poraba_TD1) <- c("leto", "porabatoplote")

# Sončna energija
modelporabesonca <- lm(data=poraba_TD2, poraba ~ log(leto))
napoved4 <- predict(modelporabesonca, data.frame(leto=c(2019, 2020, 2021, 2022, 2023, 2024, 2025, 2026, 2027, 2028, 2029, 2030)))
poraba_TD5 <- poraba_TD2
poraba_TD5 <- data.frame(leto = c(2019, 2020, 2021, 2022, 2023, 2024, 2025, 2026, 2027, 2028, 2029, 2030),
                         poraba = c(napoved4[1], napoved4[2], napoved4[3], napoved4[4], napoved4[5], napoved4[6], napoved4[7], napoved4[8],
                                    napoved4[9], napoved4[10], napoved4[11], napoved4[12]))
poraba_TD2 <- rbind(poraba_TD2, poraba_TD5)
names(poraba_TD2) <- c("leto", "porabasoncne")

# Daljinska toplota
modelporabedaljinske <- lm(data=poraba_TD3, poraba ~ log(leto))
napoved5 <- predict(modelporabedaljinske, data.frame(leto=c(2019, 2020, 2021, 2022, 2023, 2024, 2025, 2026, 2027, 2028, 2029, 2030)))
poraba_TD6 <- poraba_TD3
poraba_TD6 <- data.frame(leto = c(2019, 2020, 2021, 2022, 2023, 2024, 2025, 2026, 2027, 2028, 2029, 2030),
                         poraba = c(napoved5[1], napoved5[2], napoved5[3], napoved5[4], napoved5[5], napoved5[6], napoved5[7], napoved5[8],
                                    napoved5[9], napoved5[10], napoved5[11], napoved5[12]))
poraba_TD3 <- rbind(poraba_TD3, poraba_TD6)
names(poraba_TD3) <- c("leto", "porabadaljinske")

tabelanapovedi2 <- merge(poraba_TD1, poraba_TD2, by=c("leto"))
tabelanapovedi2 <- merge(tabelanapovedi2, poraba_TD3, by=c("leto"))

tabelanapovedi2$celotnaporaba <- with(tabelanapovedi2, porabatoplote + porabasoncne + porabadaljinske)
tabelanapovedi2$od1 <- with(tabelanapovedi2, 100 * porabatoplote / celotnaporaba)
tabelanapovedi2$od2 <- with(tabelanapovedi2, 100 * porabasoncne / celotnaporaba)
tabelanapovedi2$od3 <- with(tabelanapovedi2, 100 * porabadaljinske / celotnaporaba)

names(tabelanapovedi2) <- c("leto", "poraba1", "poraba2", "poraba3", "celotnaporaba", "Toplota iz okolice (%)", "Sončna energija (%)", "Daljinska toplota (%)")

tabelanapovedi2 <- tabelanapovedi2 %>% gather("energent","odstotek", 6:8)

#-----------------------------------------------------------------------------------------------------------------------------------------------
# Grafi
#-----------------------------------------------------------------------------------------------------------------------------------------------
colors <- c("cena_elektrike_(EUR/kWh)" = "blue", "cena_plina_(EUR/kWh)" = "red")

graf3 <- ggplot(data=tabelanapovedi, aes(x=leto_in_cetrtletje, y=`cena_(EUR/kWh)`, col=energent)) +
  geom_point(aes(shape = vrsta), size = 2, ) + geom_line() + xlab('leto') + ylab('cena (EUR/kWh)') + ggtitle('Napoved cene plina in elekrike') +
  geom_smooth(method="lm", aes(y=`cena_(EUR/kWh)`))

graf6 <- ggplot(data=tabelanapovedi2, aes(x=leto, y=odstotek, fill=energent)) +
  geom_bar(stat="identity", palette = "Blues") + xlab('leto') + ylab('letna poraba (%)') + ggtitle('Deleži porab, merljivih v TJ') +
  scale_fill_manual("Legenda", values = c("Toplota iz okolice (%)" = "#173F5F", "Sončna energija (%)" = "#20639B", "Daljinska toplota (%)" = "#3CAEA3"))


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

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

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

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

source("function.r")
inputfile = "hackensack.csv"
outputfile = "Results/hackensack_constrained_MCMC_"
outputplot = "Hackensack River"
data_col = 3
year_col = 1
ReferenceYear = 2018
ReturnPeriod = 100
burn_in = 500
CSVFile = read.csv(file = inputfile, header = T)
Data = CSVFile[,data_col]
Year = CSVFile[,year_col]
time_index = time.index(Year,ReferenceYear)
parameters = draw.MCMC.samples(Data,time_index,InitialValues = c(50,1,20,0.8),LocationInterceptPrior = c(0,200),LocationSlopePrior = c(0,5),ScalePrior = c(0,50),ShapePrior = c(-1,1),ProposalWidth = c(2,0.15,1,0.05),n_samples=10000)
parameters = parameters[-c(1:burn_in),]
mu_post = parameters[,1]
muslope_post = parameters[,2]
scale_post = parameters[,3]
shape_post = parameters[,4]
ret_post=rep(-1,length(mu_post))
for (i in 1:length(mu_post)){
  ret_post[i] = calc.nstat.ret.event(mu_post[i],muslope_post[i],scale_post[i],shape_post[i],n = ReturnPeriod,baseyear = ReferenceYear, analysisyear = ReferenceYear, epsilon = 1)
}

bw = c(2,0.02,0.75,0.020,10)
pdf(paste0(outputfile,"posterior_location_intercept.pdf"))
hist(mu_post, main = outputplot, xlab = NA,prob = T, col = "lightgrey", cex.lab = 1.33, cex.axis = 1.33, cex.main = 1.33)
points(density(mu_post, bw = bw[1]), type = 'l', lwd = 2)
dev.off()
pdf(paste0(outputfile,"posterior_location_slope.pdf"))
hist(muslope_post,main = outputplot, xlab = NA,prob = T, col = "lightgrey", cex.lab = 1.33, cex.axis = 1.33, cex.main = 1.33)
points(density(muslope_post, bw = bw[2], from = 0.05), type = 'l', lwd = 2)
dev.off()
pdf(paste0(outputfile,"posterior_scale.pdf"))
hist(scale_post, main = outputplot, xlab = NA,prob = T, col = "lightgrey", cex.lab = 1.33, cex.axis = 1.33, cex.main = 1.33)
points(density(scale_post, bw = bw[3]), type = 'l', lwd = 2)
dev.off()
pdf(paste0(outputfile,"posterior_shape.pdf"))
hist(shape_post, main = outputplot, xlab = NA,prob = T, col = "lightgrey", cex.lab = 1.33, cex.axis = 1.33, cex.main = 1.33)
points(density(shape_post, bw = bw[4]), type = 'l', lwd = 2)
dev.off()
pdf(paste0(outputfile,"posterior_retevent.pdf"))
hist(ret_post, main = outputplot, xlab = NA,prob = T, col = "lightgrey", cex.lab = 1.33, cex.axis = 1.33, cex.main = 1.33)
points(density(ret_post, bw = bw[5]), type = 'l', lwd = 2)
dev.off()

## CDF plot for return event
train_points = 100
cdf = ecdf(ret_post)
start = 0.8*quantile(cdf)[1]
end = 1.1*quantile(cdf)[5]
quants = seq(start,end,length.out = train_points)
quants_CDF = cdf(quants)
pdf(paste0(outputfile,"retevent-cdf.pdf"))
plot(quants,quants_CDF, type = 'l', lwd = 2,xlab = NA, main = outputplot,ylab = "Probability", cex.lab = 1.33, cex.axis = 1.33, cex.main = 1.33)
abline(h=0,lty=4,lwd=2)
abline(h=1,lty=4,lwd=2)
dev.off()

### Expected and MAP Values of the parameters and the return event and the 95% C.I. for return event
d_mu = density(mu_post, bw = bw[1])
d_muslope = density(muslope_post, bw = bw[2])
d_scale = density(scale_post, bw= bw[3])
d_shape = density(shape_post, bw = bw[4])
d_retEvent = density(ret_post, bw = bw[5])

mu_exp = mean(mu_post)
mu_map = d_mu$x[which.max(d_mu$y)]
muslope_exp = mean(muslope_post)
muslope_map = 0
scale_exp = mean(scale_post)
scale_map = d_scale$x[which.max(d_scale$y)]
shape_exp =mean(shape_post)
shape_map = d_shape$x[which.max(d_shape$y)]
retEvent_exp = mean(ret_post)
retEvent_map = d_retEvent$x[which.max(d_retEvent$y)]
NLLH_exp = likelihood.val(Data,time_index,mu_exp,muslope_exp,scale_exp,shape_exp)
NLLH_map = likelihood.val(Data,time_index,mu_map,muslope_map,scale_map,shape_map)
cat("Expected Values of the Parameters:",'\n')
cat("Location Intercept:", mu_exp, '\n')
cat("Location Slope:", muslope_exp, '\n')
cat("Scale:",scale_exp, '\n')
cat("Shape:", shape_exp, '\n')
cat("100 year Return Event:", retEvent_exp, '\n')
cat("NLLH:", NLLH_exp, '\n')
cat('\n',"MAP values of the Parameters:",'\n')
cat("Location Intercept:", mu_map, '\n')
cat("Location Slope:", muslope_map, '\n')
cat("Scale:",scale_map, '\n')
cat("Shape:", shape_map, '\n')
cat("100 year Return Event:", retEvent_map, '\n')
cat("NLLH:", NLLH_map, '\n')
## 95% C.I for Return Event

d_sort = sort(ret_post)
lb = d_sort[round(0.025*9500)]
ub = d_sort[round(0.975*9500)]

cat("95% C.I. for Return Event: [",lb,ub,"]",'\n' )


#' Variable Shields number method to calculate paleoslope from preserved sediments
#'
#' \code{lynds_two} calculates the slope of an ancient river, provided you know the flow depth, the grain size of the bed material, and make some assumptions about shear stress in the river. The important part here is that the function implements a different shields number depending on whether the bed material is fine or coarse. 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 D The median grain size of bedload 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 single dimensionless number giving the slope.
#' @export

#	Second method to reconstruct paleoslope from Lynds et al. (2014)
#	Eric Barefoot
#	Nov 2017

#	function takes two main arguments, the particle size, and the depth, both in meters. Then it uses them to calculate a slope, using a raft of assumptions.
#	to use a more complicated way to calculate settling velocity, use ws_mode = 'complex'

#	requires the 'settle' function, which lives in the same package

#source(file.path(fd,'settle.r'))

lynds_two = function(D, H, ws_mode = 'simple', rhos = 2650, rhof = 1000) {

	#	NOTES:
	#	in the future, need to allow options for csf and PI, but implement more smoothly.

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

	#	constants

	g = 9.8				#	gravity m/s^2
	nuu  = 1.004e-6		#	kinematic viscocity in Pa s at 20C
	rhos = rhos			# 	in kg/m^3
	rhof = rhof			#	in kg/m^3
	R = rhos/rhof - 1	#	should be close to 1650 for qtz sand
	csf = 0.7			# 	some csf for grains
	PI = 3.5			# 	average for natural grains. Varies from 0-6.

	#	key is to find the settling velocity of particles. there exist a wide variety of schemas for this. lynds uses dietrich 1982, realized in function 'settle'.

	#	function giving the particle reynolds number for a size class.

	Rep = function(D, R, g, nuu) {
		Rep = (D * sqrt(D * R * g)) / nuu
		return(Rep)
	}

	#	now determine Wstar

	Wstar = settle(ws_mode = 'simple', D, constants = list(g = g, nuu = nuu, rhos = rhos, rhof = rhof))$wstar

	#	now determine Rep

	Rp = Rep(D, R, g, nuu)

	#	determine the size class that we are in. divide for fine sand or medium sand

	if(D >= 0.25e-3 & D < 0.5e-3){szcls = 'medium'}
	else if (D < 0.25e-3 & D >= 0.0625e-3){szcls = 'fine'}
	else if (D >= 0.5e-3) {szcls = 'medium'; warning('coarse sand, choosing medium value')}
	else if (D < 0.0625e-3) {szcls = 'fine'; warning('very fine silt, choosing fine value')}
	else {stop('something is wrong with the ustar/ws values')}

	#	switch defines value for ustar/ws ratio

	u_w = switch(szcls,
				 medium = 1.6,
				 fine = 3.1
				)

	#	now solve equation 9 in Lynds 2014 for slope

	S = ((R * D) / H) * (u_w * (Wstar / Rp)^(1/3))^2

	return(S)

}


subroutine cross(x,y,ijk,cprd)
implicit double precision(a-h,o-z)
dimension x(3), y(3)
# Calculates a ``normalized'' cross product of the vectors joining
# [x(1),y(1)] to [x(2),y(2)] and [x(3),y(3)] respectively.
# The normalization consists in dividing by the square of the
# shortest of the three sides of the triangle.  This normalization is
# for the purposes of testing for collinearity; if the result is less
# than epsilon, the smallest of the sines of the angles is less than
# epsilon.

# Set constants
zero = 0.d0
one  = 1.d0
two  = 2.d0
four = 4.d0

# Adjust the coordinates depending upon which points are ideal,
# and calculate the squared length of the shortest side.

# case 0: No ideal points; no adjustment necessary.
if(ijk==0) {
	smin = -one
	do i = 1,3 {
		ip = i+1
		if(ip==4) ip = 1
		a = x(ip) - x(i)
		b = y(ip) - y(i)
		s = a*a+b*b
		if(smin < zero | s < smin) smin = s
	}
}

# case 1: Only k ideal.
if(ijk==1) {
	x(2) = x(2) - x(1)
	y(2) = y(2) - y(1)
	x(1) = zero
	y(1) = zero
	cn   = sqrt(x(2)**2+y(2)**2)
	x(2) = x(2)/cn
	y(2) = y(2)/cn
	smin  = one
}

# case 2: Only j ideal.
if(ijk==2) {
	x(3) = x(3) - x(1)
	y(3) = y(3) - y(1)
	x(1) = zero
	y(1) = zero
	cn   = sqrt(x(3)**2+y(3)**2)
	x(3) = x(3)/cn
	y(3) = y(3)/cn
	smin = one
}

# case 3: Both j and k ideal (i not).
if(ijk==3) {
		x(1) = zero
		y(1) = zero
		smin  = 2
}

# case 4: Only i ideal.
if(ijk==4) {
	x(3) = x(3) - x(2)
	y(3) = y(3) - y(2)
	x(2) = zero
	y(2) = zero
	cn   = sqrt(x(3)**2+y(3)**2)
	x(3) = x(3)/cn
	y(3) = y(3)/cn
	smin = one
}

# case 5: Both i and k ideal (j not).
if(ijk==5) {
	x(2) = zero
	y(2) = zero
	smin = two
}

# case 6: Both i and j ideal (k not).
if(ijk==6) {
	x(3) = zero
	y(3) = zero
	smin = two
}

# case 7: All three points ideal; no adjustment necessary.
if(ijk==7) {
	smin = four
}

a = x(2)-x(1)
b = y(2)-y(1)
c = x(3)-x(1)
d = y(3)-y(1)

cprd = (a*d - b*c)/smin
return
end


#' Generalized Linear Model Fitters
#'
#' Linear regression (Gaussian GLM), logistic regression, and poisson
#' regression model fitters.
#'
#' @details
#' Each function is implemented with gradient descent using the conjugate
#' gradients method ("CG") of the \code{optim()} function.
#'
#' Both of \code{x} and \code{y} must be distributed in an identical fashion.
#' This means that the number of rows owned by each MPI rank should match, and
#' the data rows \code{x} and response rows \code{y} should be aligned.
#' Additionally, each MPI rank should own at least one row.  Ideally they should
#' be load balanced, so that each MPI rank owns roughly the same amount of data.
#'
#' @section Communication:
#' The communication consists of an allreduce of 1 double (the local
#' cost/objective function value) at each iteration of the optimization.
#'
#' @param x,y
#' The input data \code{x} and response \code{y}.  Each must be a shaq, and
#' each must be distributed in an identical fashion.  See the details section
#' for more information.
#' @param maxiter
#' The maximum number of iterations.
#'
#' @return
#' The return is the output of an \code{optim()} call.
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' comm.set.seed(1234, diff=TRUE)
#'
#' x = ranshaq(rnorm, 10, 3)
#' y = ranshaq(function(i) sample(0:1, size=i, replace=TRUE), 10)
#'
#' fit = logistic.fit(x, y)
#' comm.print(fit)
#'
#' finalize()
#' }
#'
#' @references
#' McCullagh, P. and Nelder, J.A., 1989. Generalized Linear Models, no. 37 in
#' Monograph on Statistics and Applied Probability.
#'
#' Duda, R.O., Hart, P.E. and Stork, D.G., 1973. Pattern classification (pp.
#' 526-528). Wiley, New York.
#'
#' @seealso
#' \code{\link{lm_coefs}}
#'
#' @name glms
#' @rdname glms
NULL

# linkinv_gaussian = identity

cost_gaussian = function(theta, x, y)
{
  m = nrow(x)
  J.local = (1/(2*m))*sum((DATA(x)%*%theta - DATA(y))^2)

  as.double(allreduce_dbl(J.local))
}

#' @rdname glms
#' @export
reg.fit = function(x, y, maxiter=100)
{
  check.is.shaq(x)
  check.is.shaq(y)
  check.is.posint(maxiter)

  control = list(maxit=maxiter)
  theta = numeric(ncol(x))
  if (is.float(DATA(x)))
    theta = fl(theta)

  optim(par=theta, fn=cost_gaussian, x=x, y=y, method="CG", control=control)
}

linkinv_logistic = binomial(logit)$linkinv

cost_logistic = function(theta, x, y)
{
  m = nrow(x)
  eta = DATA(x)%*%theta
  h = linkinv_logistic(eta)
  J.local = (1/m)*sum((-DATA(y)*log(h)) - ((1-DATA(y))*log(1-h)))

  allreduce_dbl(J.local)
}

#' @rdname glms
#' @export
logistic.fit = function(x, y, maxiter=100)
{
  check.is.shaq(x)
  check.is.shaq(y)
  check.is.posint(maxiter)

  control = list(maxit=maxiter)
  theta = numeric(ncol(x))
  optim(par=theta, fn=cost_logistic, x=x, y=y, method="CG", control=control)
}

linkinv_poisson = poisson(log)$linkinv

cost_poisson = function(theta, x, y)
{
  eta = DATA(x) %*% theta
  J.local = -sum(DATA(y) * eta - linkinv_poisson(eta))

  allreduce_dbl(J.local)
}

#' @rdname glms
#' @export
poisson.fit = function(x, y, maxiter=100)
{
  check.is.shaq(x)
  check.is.shaq(y)
  check.is.posint(maxiter)

  control = list(maxit=maxiter)
  theta = numeric(ncol(x))
  optim(par=theta, fn=cost_poisson, x=x, y=y, method="CG", control=control)
}