library(foreign)
data <- read.dta('MPDataset.dta')
sweden <- droplevels(subset(data, country == 'sweden'))
levels(sweden$party) <- c("MP",
                          "V",
                          "S",
                          "FP",
                          "KD",
                          "M",
                          "SD",
                          "C",
                          "NyD")
sweden$party <- factor(sweden$party, levels=levels(sweden$party)[c(2,3,1,8,5,4,6,7,9)])
colors <- c("#b70410", "#f9232b", "#79cf49", "#00993c", "#211974",
            "#5cb7e9", "#0049d8", "#dedd37", "#ffff41")
# These are the additive scaled dimensions from Lowe et.al., pp. 135 sqq.
freemarket.l <- c(401, 402)
freemarket.r <- c(403, 412, 413, 415)
environment.l <- c(501, 416)
environment.r <- c(410)
stateconomy.l <- c(403, 404, 406, 412, 413, 504, 506, 701)
stateconomy.r <- c(401, 402, 407, 414, 505)
stateservices.l <- c(504, 506)
stateservices.r <- c(505, 507)
logrile.l <- c(103, 105, 106, 107, 202, 403, 404, 406, 412, 413, 504, 506, 701)
logrile.r <- c(104, 201, 203, 305, 401, 402, 407, 414, 505, 601, 603, 605, 606)
logplaneco.l <- c(403, 404, 412)
logplaneco.r <- c(401, 414)
libcons.l <- c(103, 105, 106, 107, 202)
libcons.r <- c(104, 201, 203, 305, 601, 603, 605, 606)
logitm <- function(dataset, vars.l, vars.r) {
    log(rowSums(dataset[paste0("per", vars.l)] + 0.5) / rowSums(dataset[paste0("per", vars.r)] + 0.5))
}
sweden$freemarket <- logitm(sweden, freemarket.l, freemarket.r)
sweden$environment <- logitm(sweden, environment.l, environment.r)
sweden$stateconomy <- logitm(sweden, stateconomy.l, stateconomy.r)
sweden$stateservices <- logitm(sweden, stateservices.l, stateservices.r)
sweden$logrile <- -logitm(sweden, logrile.l, logrile.r)
sweden$logplaneco <- logitm(sweden, logplaneco.l, logplaneco.r)
sweden$libcons <- logitm(sweden, libcons.l, libcons.r)
# These are logit scales for bipolar categories (again, Lowe et.al., pp. 131 sqq.)
logits <- function(dataset, var.l, var.r) {
    log(rowSums(dataset[paste0("per", var.l)] + 0.5) / rowSums(dataset[paste0("per", var.r)] + 0.5))
}
sweden$foreignalliances <- logits(sweden, 101, 102)
sweden$militarism <- -logits(sweden, 105, 104)
sweden$internationalism <- logits(sweden, 107, 109)
sweden$logeu <- logits(sweden, 108, 110)
sweden$constitutionalism <- logits(sweden, 203, 204)
sweden$decentralization <- logits(sweden, 301, 302)
sweden$protectionism <- logits(sweden, 406, 407)
sweden$keynesian <- logits(sweden, 409, 414)
sweden$nationalism <- -logits(sweden, 602, 601)
sweden$morality <- -logits(sweden, 604, 603)
sweden$multiculturalism <- logits(sweden, 607, 608)
sweden$laborpolicy <- logits(sweden, 701, 702)
sweden$logwelfare <- logits(sweden, 504, 505)
sweden$education <- logits(sweden, 506, 507)

## TODO: plot interesting 2d graph(s)
library(ggplot2)
library(reshape2)
library(Hmisc)

# Plot all variables from Lowe et.al.
vars <- c("freemarket", "environment", "stateconomy", "stateservices", "logrile",
          "logplaneco", "libcons", "foreignalliances", "militarism", "internationalism",
          "logeu", "constitutionalism", "decentralization", "protectionism", "keynesian",
          "nationalism", "morality", "multiculturalism", "laborpolicy", "logwelfare",
          "education")
for(var in vars) {
    pdf(paste0(var, ".pdf"), width=11.70, height=4.1)
    p <- ggplot(sweden, aes_string(x="edate", y=var, group="party", colour="party"))
    print(
      p + geom_line() + geom_point() + scale_colour_manual(name="Parti", values=colors) +
          labs(x = "År") +
          stat_summary(aes(group=country), fun.data="mean_cl_normal", geom="smooth", colour="#666666", fill="#cccccc")
    )
    dev.off()
}

# References
# Lowe, W., Benoit, K., Mikhaylov, S. and Laver, M. 2011. ”Scaling Policy Preferences from Coded Political Texts.” Legislative Studies Quarterly 36 (1): 123–155.


#' Compute one component of the periodogram.
#'
#' @param t Sampling times.
#' @param x Value of timeseries at each sample time, after demeaning and standardizing.
#' @param omega Angular frequency to evaluate periodogram at.
#' @param tau Time-shift parameter tau.
#' @param sincos Either "sin" or "cos": whichever component is desired.
#'
#' @return Periodogram component value.
#'
#' @examples
#' periodogram.component(1:10, sin(1:10), 1, tau(1:10, 1), "sin")
#'
#' @export
periodogram.component <- function(t, x, omega, tau, sincos) {

    ## Input Validation ##

    # Parse the strings "sin" and "cos" into their respective functions,
    # and raise an error if neither provided.
    sincos.fn <- switch(sincos, sin = sin, cos = cos)
    if (is.null(sincos.fn)) {
        stop("Invalid value '", sincos, "' provided for 'sincos'. ",
             "Must be either 'sin' or 'cos'.")
    }

    t.minus.tau <- outer(tau, t, FUN = `-`)
    sincos.vec <- sincos.fn(t.minus.tau * omega)

    (sincos.vec %*% x) / sqrt(rowSums(sincos.vec^2))

}


## Created on Friday, November 12, 2021 at 3:02pm EST by WeekendEditor on WeekendEditorMachine.
## Copyright (c) 2021, SomeWeekendReading.blog.  All rights reserved.  As if you care.

library("gsDesign")                                    # For ciBinomial()

##
## Simple-minded efficacy computation, with confidence limits using a scaled binomial model.
## (To be eventually replaced by my super-duper Beta ratios stuff with Gauss hypergeometric magic!)
##

## Molnupiravir example, hospitalizations:
## > signif(efficacyAndCL(384, 28, 376, 53), digits = 3)
##   LCL   Eff   UCL
## 0.205 0.483 0.665
##
## Paxlovid example, hospitalizations:
## > signif(efficacyAndCL(389, 3, 385, 27), digits = 3)
##   LCL   Eff   UCL
## 0.663 0.890 0.964
##
## Paxlovid example, deaths:
## > signif(efficacyAndCL(389, 0, 385, 7), digits = 3)
##  LCL  Eff  UCL
## 0.46 1.00 1.00
##
## Paxlovid final report, hospitalizations:
## > signif(efficacyAndCL(1039, 8, 1046, 66), digits = 3)
##   LCL   Eff   UCL
## 0.751 0.878 0.940
##
## Paxlovid final report, deaths:
## > signif(efficacyAndCL(1039, 0, 1046, 12), digits = 3)
##   LCL   Eff   UCL
## 0.679 1.000 1.000
##
## Try the qBetaRatio() method here?  Are these numbers small enough for the naive implementation?
## For molnumpiravir
## > 1 - medianCLBetaRatio(28 + 1, 384 - 28 + 1, 53 + 1, 376 - 53 + 1, 0.05, 0, 10)
efficacyAndCL <- function(Ntrt, Ktrt, Ncnt, Kcnt) {    # Treatment efficacy & 95% conf limit
  ## Ntrt = number of subjects in treatment arm
  ## Ktrt = number of sick in treatment arm
  ## Ncnt = number of subjects in control arm
  ## Kcnt = number of sick in control arm
  eff   <- 1 - (Ktrt / Ntrt) / (Kcnt / Ncnt)           # Point estimate, then confidence limits
  effCL <- rev(1 - ciBinomial(Ktrt, Kcnt, Ntrt, Ncnt, scale = "RR"))
  c(LCL = effCL[[1]], Eff = eff, UCL = effCL[[2]])     # Return 3-vector of LCL, estimate, and UCL
}                                                      #


#' @title calcAdmPwr
#'
#' @description Calculates ship power (kW) using the admiralty formula.
#'
#' @param totalInstalledPwr Total installed main engine power (vector of numericals,
#' kW) (maximum continuous rated power)
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#' @param refSpeed Reference speed of the ship (service speed or maximum speed)
#' (vector of numericals, m/s)
#' @param actualDraft Actual draft (vector of numericals, m)
#' @param maxDraft Maximum summer load line draft (vector of numericals, m)
#' @param serviceMargin A service margin to account for weather and sea effects:
#' \itemize{\item At-sea operations = 15 (Default) \item Coastal operations = 10}
#' Can supply either a vector of numericals, a single number, or rely on the default.
#' @param n Exponential relationship applied to the ship speed ratio (dimensionless).
#' Default = 3. This argument is not vectorized, so supply a single number or rely
#' on the default
#' @param refSpeedType Indicates if the reference speed is service speed or
#' maximum speed: \itemize{
#' \item "serviceSpeed (Default)"
#' \item "maxSpeed"}
#' Can supply either a vector of strings, a single value, or rely on the default.
#'
#' @details
#' Ship speed and actual draft are typically obtained from sources such as AIS
#' messages or ship records.
#'
#' This implementation assumes the following default values:
#'
#' n = 3 (IMO greenhouse gas study)
#'
#' serviceMargin = 10 or 15, based on IMO (Prpic Orsic and Faltinsen, 2012).
#' 15 indicates 15\% increased resistance in at-sea water conditions, and 10
#' indicates 10\% increased resistance in coastal water conditions.
#'
#' Note that service margin is treated as an added resistance here
#' (instead of as a reduced efficiency) to maintain consistency with the other
#' power models used in this library. (See MAN, 2011).
#'
#' @return power (vector of numericals, kW)
#'
#' @references
#'International Maritime Organization. 2014. "Third IMO GHG study 2014 - Final
#'report." London: International Maritime Organization.
#'
#'\href{https://www.man-es.com/marine/products/propeller-aft-ship}{MAN Energy
#' Solutions. 2011. "Basic Principles of Propulsion."}
#'
#'@seealso \itemize{
#'\item \code{\link{calcSpeedUnitConversion}}
#'\item \code{\link{calcPropPwr}}
#'\item \code{vignette("OverviewOfPowerModels", package="ShipPowerModel")}
#'\item \code{vignette("Admiralty.Formula.Example", package="ShipPowerModel")}
#'}
#'
#' @examples
#' calcAdmPwr(9363, seq(0,13,1), 15, 12.48, 13.57, serviceMargin = 15, n=3)
#'
#' @export

calcAdmPwr <- function(totalInstalledPwr, shipSpeed, refSpeed, actualDraft, maxDraft,
                           serviceMargin = 15, n=3,
                           refSpeedType = "serviceSpeed"){

  #The admiralty formula method requires the the reference speed to be maximum speed, to be consistent with the other terms.
  #Convert service speed to maximum speed by assuming service speed is 94% of maximum speed.
  refSpeed<-ifelse(tolower(refSpeedType) == "servicespeed",
                   refSpeed/0.94,
                   refSpeed
                  )#end ifelse

  power <- ifelse(shipSpeed==0,
                  0,
                  totalInstalledPwr*
                   pmin(1, #set maximum power to 100%
                        pmax(.02, #limit minimum power to 2%
                             ((actualDraft/maxDraft)^(2/3)*
                              (shipSpeed/refSpeed)^(n))*
                              ((100+serviceMargin)/100)
                            )
                       )
                 )#end ifelse
  return(power)

}#end of calcAdmPwr


#################################################################
#######    Risk Analysis for Wind Turbine Toolkit        ########
#################################################################

## FEM.mean.R  (2014-2020)
##
## Copyright 2014-2020 Alexandre Brouste

##    INPUT VARIABLES
#################################################################
##  x    :
## theta :
## Delta :
#################################################################

##    OUTPUT VARIABLES
#################################################################
##  forecast
#################################################################

# parameters = (kappa,theta,sigma) --> theta[1,2,3] respectively

af<-function(x,theta){return(theta[1]*(theta[2]-x))}

bf<-function(x,theta){return(theta[3]^2)}

bfprime<-function(x,theta){return(0)}

OU.FEM<-function(x0,theta,DeltaTime,param=list(Minf=-8,Msup=8,N=200),R=10){

  Minf<-param$Minf
  Msup<-param$Msup
  N<-param$N

  space<-seq(Minf,Msup,length=N+1)
  Delta<-(Msup-Minf)/N

  # Elements finis

  phi<-function(x,n){
    (1-1/Delta*abs(x-space[n+1]))*(x>space[n])*(x<space[n+2])
  }

  # Matrice C

  res1th<-2/3*Delta
  res2th<-Delta/6

  ##- Fill the matrix C

  C<-diag(rep(res1th,N-1))
  C[1,2]<-res2th

  for (i in 1:(N-2)){
    C[i,i+1]<-res2th
    C[i+1,i]<-res2th
  }

  # Matrice K

  phiprime<-function(x,n){
    ((x<space[n+1])*(x>space[n]) - (x>space[n+1])*(x<space[n+2]))/Delta
  }

  ## fill matrix K

  K<-C

  for (i in 2:(N-2)){

    j<-0
    functmp<-function(x){ (af(x,theta)-1/2*bfprime(x,theta))*phiprime(x,i)*phi(x,i+j) -1/2*bf(x,theta)*phiprime(x,i)*phiprime(x,i+j)}
    K[i,i]<-integrate(functmp,space[i],space[i+2],stop.on.error = FALSE)$value

    j<-1
    functmp<-function(x){ (af(x,theta)-1/2*bfprime(x,theta))*phiprime(x,i)*phi(x,i+j) -1/2*bf(x,theta)*phiprime(x,i)*phiprime(x,i+j)}
    K[i,i+1]<-integrate(functmp,space[i+1],space[i+2],stop.on.error = FALSE)$value

    j<--1
    functmp<-function(x){ (af(x,theta)-1/2*bfprime(x,theta))*phiprime(x,i)*phi(x,i+j) -1/2*bf(x,theta)*phiprime(x,i)*phiprime(x,i+j)}
    K[i,i-1]<-integrate(functmp,space[i],space[i+1],stop.on.error = FALSE)$value
  }

  #i==1
  i<-1;

  j<-0
  functmp<-function(x){ (af(x,theta)-1/2*bfprime(x,theta))*phiprime(x,i)*phi(x,i+j) -1/2*bf(x,theta)*phiprime(x,i)*phiprime(x,i+j) }
  K[1,1]<-integrate(functmp,space[1],space[3],stop.on.error = FALSE)$value

  j<-1
  functmp<-function(x){ (af(x,theta)-1/2*bfprime(x,theta))*phiprime(x,i)*phi(x,i+j) -1/2*bf(x,theta)*phiprime(x,i)*phiprime(x,i+j) }
  K[1,2]<-integrate(functmp,space[2],space[3],stop.on.error = FALSE)$value

  #i==N-1

  i<-N-1;

  j<-0
  functmp<-function(x){ (af(x,theta)-1/2*bfprime(x,theta))*phiprime(x,i)*phi(x,i+j) -1/2*bf(x,theta)*phiprime(x,i)*phiprime(x,i+j) }
  K[N-1,N-1]<-integrate(functmp,space[N-1],space[N+1],stop.on.error = FALSE)$value

  j<--1
  functmp<-function(x){ (af(x,theta)-1/2*bfprime(x,theta))*phiprime(x,i)*phi(x,i+j) -1/2*bf(x,theta)*phiprime(x,i)*phiprime(x,i+j) }
  K[N-1,N-2]<-integrate(functmp,space[N-1],space[N],stop.on.error = FALSE)$value

  # Resolution du schema numerique

  T<-DeltaTime

  Deltat<-T/R
  lambda<-matrix(0,N-1,R+1)

  ##### Condition initiale
  psi<-0

  for (i in 1:(N-1)){
    psi[i]<-phi(x0,i)
  }

  lambda[1:(N-1),1]<-solve(C)%*%psi

  for (ti in 2:(R+1)){

    ### Schéma implicite
    lambda[,ti]<-1/Deltat*solve(C/Deltat-K)%*%C%*%lambda[,ti-1,drop=FALSE]

  }

  densf<-function(x,R){
    S<-0

    for (i in 1:(N-1)){
      S<-S+lambda[i,R]*phi(x,i)
    }

    return(S)
  }

  x<-seq(Minf,Msup,length=1001)
  EW<-sum(x*densf(x,R+1))*(Msup-Minf)/1000

  return(list(m=EW,density=densf(x,R+1),x=x))
}


suppressMessages(library(gmp))
ONE <- as.bigz("1")
TWO <- as.bigz("2")
THREE <- as.bigz("3")
FOUR <- as.bigz("4")
SEVEN <- as.bigz("7")
TEN <- as.bigz("10")

q <- as.bigz("1")
r <- as.bigz("0")
t <- as.bigz("1")
k <- as.bigz("1")
n <- as.bigz("3")
l <- as.bigz("3")

char_printed <- 0

how_many <- 1000

first <- TRUE
while (how_many > 0) {
  if ((FOUR * q + r - t) < (n * t)) {
    if (char_printed == 80) {
      cat("\n")
      char_printed <- 0
    }
    how_many <- how_many - 1
    char_printed <- char_printed + 1
    cat(as.integer(n))
    if (first) {
      cat(".")
      first <- FALSE
      char_printed <- char_printed + 1
    }
    nr <- as.bigz(TEN * (r - n * t))
    n <- as.bigz(((TEN * (THREE * q + r)) %/% t) - (TEN * n))
    q <- as.bigz(q * TEN)
    r <- as.bigz(nr)
  } else {
    nr <- as.bigz((TWO * q + r) * l)
    nn <- as.bigz((q * (SEVEN * k + TWO) + r * l) %/% (t * l))
    q <- as.bigz(q * k)
    t <- as.bigz(t * l)
    l <- as.bigz(l + TWO)
    k <- as.bigz(k + ONE)
    n <- as.bigz(nn)
    r <- as.bigz(nr)
  }
}
cat("\n")


# Day 6: Lanternfish

get_day6_input_path <- function() {
    paste(getwd(), "/2021/Day 6/Day6_input.txt", sep = "")
}

part1 <- function(num_days = 80) {
    readings <- readLines(get_day6_input_path())

    days <- num_days
    fishies <- strtoi(unlist(strsplit(readings[1], ",")))

    lanternfish <- optimize_fishies(fishies, c(1:5))

    for (i in 1:days) {
        lanternfish[, 1] <- lanternfish[, 1] - 1

        sum_new_fishies <- sum(lanternfish[which(lanternfish[, 1] == -1), 2])

        lanternfish[, 1][lanternfish[, 1] == -1] <- 6
        if (sum_new_fishies > 0) {
            lanternfish <- rbind(lanternfish, c(8, sum_new_fishies))
        }
    }
    print(sum(lanternfish[, 2]))
    print(paste(sum(lanternfish[, 2])))
}

part2 <- function() {
    part1(256)
}

optimize_fishies <- function(fishies, starting_vals) {
    lanternfish <- matrix(ncol = 2)[-1, ]

    for (i in seq_len(length(starting_vals))) {
        sum_of_i <- sum(fishies == i)
        if (sum_of_i > 0) {
            lanternfish <- rbind(lanternfish, c(i, sum_of_i))
        }
    }

    lanternfish
}

part1()
part2()


sierpinski.triangle = function(n) {
	len <- 2^(n+1)
	b <- c(rep(FALSE,len/2),TRUE,rep(FALSE,len/2))
	for (i in 1:(len/2))
	{
		cat(paste(ifelse(b,"*"," "),collapse=""),"\n")
		n <- rep(FALSE,len+1)
		n[which(b)-1]<-TRUE
		n[which(b)+1]<-xor(n[which(b)+1],TRUE)
		b <- n
	}
}
sierpinski.triangle(5)


#' @title
#' Generate initial estimators
#'
#' @description
#' This function provides the initial estimators of U and V to initialize the
#' blockwise coordinate descent algorithm.
#'
#' @usage
#' NRRR.ini(Y, X, r, rx, ry, jx, jy, p, d, n)
#'
#'
#' @param Y response matrix of dimension n-by-jy*d.
#' @param X design matrix of dimension n-by-jx*p.
#' @param r rank of the local reduced-rank structure.
#' @param rx number of latent predictors.
#' @param ry number of latent responses.
#' @param jx number of basis functions to expand the functional predictor.
#' @param jy number of basis functions to expand the functional response.
#' @param p number of predictors.
#' @param d number of responses.
#' @param n sample size.
#'
#'
#' @return The function returns a list:
#'   \item{Ag}{the estimated U.}
#'   \item{Bg}{the estimated V.}
#'
#' @references Liu, X., Ma, S., & Chen, K. (2020).
#' Multivariate Functional Regression via Nested Reduced-Rank Regularization.
#' arXiv: Methodology.
#'
#' @examples
#' library(NRRR)
#' simDat <- NRRR.sim(n = 100, ns = 200, nt = 200, r = 5, rx = 3, ry = 3,
#'                    jx = 15, jy = 15, p = 10, d = 6, s2n = 1, rho_X = 0.5,
#'                    rho_E = 0, Sigma = "CorrAR")
#' fit_init <- with(simDat, NRRR.ini(Y = Yest, X = Xest, r = 5,
#'                  rx = 3, ry = 3, jx = 15, jy = 15,
#'                  p = 10, d = 6, n = 100))
#' fit_init$Ag
#' @export
NRRR.ini <- function(Y,X,r,rx,ry,jx,jy,p,d,n){
  #require(rrpack)
  if (r == 0) stop("r cannot be 0")
  if (r > min(dim(Y)[2])) stop("r cannot be greater than jy*d")
  if(p < rx) stop("rx cannot be greater than p")
  if(d < ry) stop("ry cannot be greater than d")

  # ignore the global structure to estimate C from RRR
  fit_RRR <- RRR(Y,X,nrank=r)
  Crr <- fit_RRR$C
  # Compute Bghat, i.e, V
  if(p==rx){
    Bghat <- diag(nrow=rx,ncol=rx)
  }else{
    Cbg <- matrix(nrow=p,ncol=d*jy*jx,NA)
    for(j in 1:jx){
      a1 <- d*jy*(j-1) + 1
      b1 <- d*jy*j

      a2 <- p*(j-1) + 1
      b2 <- p*j
      Cbg[,a1:b1] <- Crr[a2:b2,]
    }
    Bghat <- as.matrix(svd(Cbg, nu=rx,nv=rx)$u)
  }

  #Compute Aghat, i.e., U
  if(d==ry){
    Aghat <- diag(nrow=ry,ncol=ry)
  }else{
    Cag <- matrix(nrow=d,ncol=p*jy*jx,NA)
    for(j in 1:jy){
      a1 <- p*jx*(j-1) + 1
      b1 <- p*jx*j

      a2 <- d*(j-1) + 1
      b2 <- d*j

      Cag[,a1:b1] <- t(Crr[,a2:b2])
    }
    Aghat <- as.matrix(svd(Cag, nu=ry,nv=ry)$u)
  }

  return(list(Ag=Aghat,Bg=Bghat,C=Crr))
}


#'@title calcHMTotalRes
#'
#' @description Calculate total ship resistance (\code{Rtot}) (kN) using the
#' Holtrop & Mennen method.
#'
#' @param Rapp Appendage resistance (vector of numericals, kN) (see
#' \code{\link{calcHMAppendageRes}})
#' @param Rw Wave waking (similar to residual) resistance (vector of numericals, kN)
#' (see \code{\link{calcHMWaveMakingRes}})
#' @param Rb Bulbous bow resistance (vector of numericals, kN) (see
#' \code{\link{calcHMBulbousBowRes}})
#' @param Rtr Immersed transom resistance (vector of numericals, kN) (see
#' \code{\link{calcHMImmersedTransomRes}})
#' @param seawaterDensity Sea water density. Default = 1.025 (g/cm^2). Can
#' supply either a vector of numericals, a single number, or rely on the default
#' @param wettedSA Wetted hull surface area (vector of numericals, m^2) (see
#' \code{\link{calcHMWettedSA}})
#' @param shipSpeed Ship actual speed (vector of numericals, m/s) (see
#' \code{\link{calcSpeedUnitConversion}})
#' @param Cf Frictional resistance coefficient (vector of numericals, dimensionless)
#' (see \code{\link{calcCf}})
#' @param formFactor Form factor (1+k) (vector of numericals, dimensionless)
#' (see \code{\link{calcHMFormFactor}})
#' @param Ca Incremental hull (roughness) resistance coefficient (vector of
#' numericals, dimensionless) (see \code{\link{calcHMCa}})
#' @param serviceMargin A service margin to account for weather and sea effects:
#' \itemize{\item Coastal operations = 10 \item At-sea operations = 15 (default)}.
#' Can supply either a vector of numericals, a single number, or rely on the default
#'
#' @details
#' Note that service margin is included here as a resistance term.
#'
#' @return \code{Rtot} (vector of numericals, kN)
#'
#' @references
#'Holtrop, J. and Mennen, G. G. J. 1982. "An approximate power prediction
#'method." International Shipbuilding Progress 29.
#'
#' @seealso \code{\link{calcSpeedUnitConversion}}
#'
#' @family Holtrop-Mennen Calculations
#' @family Resistance Calculations
#'
#' @examples
#' calcHMTotalRes(Rapp=0.24,
#'                Rw=2.6,
#'                Rb=c(4.538188e-07,3.579217e-06,1.180116e-05,2.709520e-05,5.085940e-05),
#'                Rtr=c(0.58,2.2,4.8,8.1,12.1),
#'                seawaterDensity=1.025,
#'                wettedSA=10746.282,
#'                shipSpeed=seq(1,5,1),
#'                Cf=c(0.0019,0.0017,0.0016,0.0016,0.0015),
#'                formFactor=1.275601,
#'                Ca=0.0003356088,
#'                serviceMargin=15)
#'
#' @export

calcHMTotalRes<- function(Rapp,Rw,Rb,Rtr,seawaterDensity,wettedSA,shipSpeed,
                          Cf,formFactor,Ca,serviceMargin){
  Rtot<-
(    Rapp+Rw+Rb+Rtr+
    (.5*seawaterDensity*wettedSA*((shipSpeed)^2)*Cf)*(formFactor)+
    (.5*seawaterDensity*wettedSA*((shipSpeed)^2)*Ca))*(1+serviceMargin/100)
  return(Rtot)
}


#' Z-polytope sampler for linear inverse problems
#'
#' For the linear inverse problem y=Ax where y and x are counts, the y-fibre (solution set) is a Z-polytope (i.e. the points on the integer lattice within a convex polytope). This function implements samplers for the Z-polytope, with using a dynamic lattice basis or a full Markov basis. The underyling model for x can be Poisson, uniform or negative binomial.
#' @param y Vector of observed count data.
#' @param A Model configuration matrix, assumed to be binary.
#' @param lambda Mean vector for x.
#' @param U Optional matrix the columns of which should be a Markov (sub)-basis.
#' @param Method "MH" for Metropolis-Hastings sampler, "Gibbs" for Gibbs sampler.
#' @param Reorder Should the columns of A be reordered? Defaults to TRUE.
#' @param tune.par Tuning parameter (alpha) controlling variation in fitness values for lattice bases. Defaults to 0.5.
#' @param combine Should extra moves be included combining lattice basis vectors? Defaults to FALSE, but should usually be set to TRUE if A is not unimodular.
#' @param x.order If Reorder=FALSE, x.order can be used to reorder columns of A to match ordering of entries of x. Defaults to NULL when no such reordering is performed.
#' @param x.ini Vector of initial values for x. Default is NULL, when initial values derived through integer programming.
#' @param Model "Poisson", "Uniform", "NegBin" or "Normal" (the last being a discrete approximation).
#' @param Proposal "NonUnif" or "Unif" (default).
#' @param NB.alpha Dispersion parameter for negaqtive-binomial distribution. Defaults to 1.
#' @param ndraws Number of iterations to run sampler after burn-in. One iteration comprises cycling through the full basis (possibly augmented by a combined move). Defaults to 10^4.
#' @param burnin Number of iteractions for burn in period. Defaults to 2000, which is usually more than adequate.
#' @param verbose Controls level of detail in recording lattice bases used.
#' @param THIN Thinning parameter for output. Defaults to 1 (no thinning).
#' @return A list with components X (a matrix, each row corresponding to samplers for an entry of x) and x.order (a vector describing dynamic selection of lattice bases, if verbose=1).
#' @export
#' @examples
#' data(LondonRoad)
#' Xsampler(A=LondonRoad$A,y=LondonRoad$y,lambda=LondonRoad$lambda,Model="Poisson",Method="Gibbs",tune.par=0.5,combine=FALSE)

Xsampler <- function (y, A, lambda, U=NULL, Method="MH", Reorder=TRUE, tune.par=0.5, combine=FALSE, x.order=NULL, x.ini=NULL, Model="Poisson", Proposal="Unif", NB.alpha=1, ndraws = 10000, burnin = 2000, verbose = 0, THIN = 1) {
	require(lpSolve)
	require(numbers)
	require(extraDistr)
  	if(Model=="NegBin" & NB.alpha<=0) NB.alpha=1
	if(Model=="Uniform") Method <- "Gibbs"
	y <- as.numeric(y)
	r <- ncol(A)
	n <- nrow(A)
	tol <- 10^{-10}

	if (is.matrix(U)) Reorder=FALSE

	if (Reorder){
		lambda.star <- lambda
		lam.order <- order(lambda.star,decreasing=TRUE)
		A <- A[,lam.order]
		x.order <- lam.order
		for (i in 3:n){
			while (qr(A[,1:i])$rank < i){
				A <- A[,c(1:(i-1),(i+1):r,i)]
				x.order <- x.order[c(1:(i-1),(i+1):r,i)]
			}
		}
	}

	if (!Reorder) {
		if(is.null(x.order)) x.order <- 1:r
		A <- A[,x.order]
	}

	lambda <- lambda[x.order]

	if (is.matrix(U)){
	 	dA1 <- 1
		tune.par <- -1
	}
	if (!is.matrix(U)){
		A1 <- A[,1:n]
		dA1 <- det(A1)
		A2 <- as.matrix(A[,-c(1:n)])
		A1.inv <- solve(A1)
		C <- A1.inv%*%A2
		U <- rbind(-C,diag(r-n))
	}

	m <- ncol(U) + 1*combine

	X <- matrix(0, r, m*(ndraws + burnin)+1)
	if (verbose==1) X.ORDER <- matrix(0, r, m*(ndraws + burnin)+1)

	if (!is.null(x.ini)) x.ini <- x.ini[x.order]
	if (is.null(x.ini)){
		x.ini <- lp("max",objective.in=rep(1,r),const.mat=A,const.dir=rep("=",nrow(A)),const.rhs=y,all.int=T)$solution
	}
	x <- x.ini
      X[x.order,1] <- x
	if (verbose==1) X.ORDER[,1] <- x.order

	for (iter in seq(1, ndraws + burnin)) {
		for (j in 1:m){
			if (j <= ncol(U)) z <- U[,j]
			if (j > ncol(U)){
				delta <- 0
				while(sum(delta)==0) delta <- rpois(ncol(U),lambda=0.5)
				delta <- delta*sample(c(-1,1),size=ncol(U),replace=T)
				z <- U%*%delta
			}
			if (abs(dA1)!=1) { if(is_wholenumber(z)==F) z <- round(z*abs(dA1))/mGCD(round(abs(z*dA1))) }
			max.move <- floor(min((x/abs(z))[which(z<0)]))
			min.move <- -floor(min((x/abs(z))[which(z>0)]))
			x.min <- x+min.move*z
			x.max <- x+max.move*z
			indx <- 1:(max.move-min.move+1)
			update.indx <- which(z!=0)
			if (max(indx>1)){
				if (Method=="Gibbs"){
					if (Model!="Uniform") x.matrix <- round(t(mapply(seq,from=x.min[update.indx],by=z[update.indx],length.out=max.move-min.move+1)))
					if (Model=="Poisson") {
						log.probs <- colSums(dpois(x.matrix,lambda[update.indx],log=T))
						probs <- exp(log.probs-max(log.probs))
						x <- x.min + sample(indx-1,size=1,prob=probs)*z
					}
					if (Model=="NegBin"){
						log.probs <- colSums(dnbinom(x.matrix,mu=lambda[update.indx],size=lambda[update.indx]/NB.alpha,log=T))
						probs <- exp(log.probs-max(log.probs))
						x <- x.min + sample(indx-1,size=1,prob=probs)*z
					}
					if (Model=="Uniform") x <- x.min+sample(indx-1,size=1)*z
				}
				if (Method=="MH"){
					if (Proposal=="Unif") move.length <- sample(min.move:max.move,1)
					if (Proposal=="NonUnif"){
	            			if (Model=="Poisson") {
							aa <- x[n+j]+z[n+j]*min.move
							bb <- x[n+j]+z[n+j]*max.move
							move.length <- (rtpois(1,lambda=lambda[n+j],a=aa-0.5,b=bb)-x[n+j])/z[n+j]
							}
	            			if (Model=="NegBin") move.length <- sample(min.move:max.move,1,prob=dnbinom((x[n+j]+z[n+j]*min.move):(x[n+j]+z[n+j]*max.move),mu=lambda[n+j],size=lambda[n+j]/NB.alpha))
						if (Model=="Normal") move.length <- rtnorm(1,lambda[n+j],sd=sqrt((1+NB.alpha)*lambda[n+j]),lower=x[n+j]+z[n+j]*min.move,upper=x[n+j]+z[n+j]*max.move)
					}
					x.cand <- x + z*move.length
					if (Model=="Poisson"){
						L <- sum(dpois(x[update.indx],lambda[update.indx],log=T))
						L.cand <- sum(dpois(x.cand[update.indx],lambda[update.indx],log=T))
					}
					if (Model=="NegBin"){
						L <- sum(dnbinom(x[update.indx],mu=lambda[update.indx],size=lambda[update.indx]/NB.alpha,log=T))
						L.cand <- sum(dnbinom(x.cand[update.indx],mu=lambda[update.indx],size=lambda[update.indx]/NB.alpha,log=T))
					}
					if (Model=="Normal"){
						L <- sum(dnorm(x[update.indx],mean=lambda[update.indx],sd=sqrt((1+NB.alpha)*lambda[update.indx]),log=T))
						L.cand <- sum(dnorm(x.cand[update.indx],mean=lambda[update.indx],sd=sqrt((1+NB.alpha)*lambda[update.indx]),log=T))
					}
					if (Proposal=="Unif") acc.prob <- exp(L.cand - L)
					if (Proposal=="NonUnif"){
	            				if (Model=="Poisson"){
							q.can <- dpois(x.cand[n+j],lambda[n+j],log=T)
							q.cur <- dpois(x[n+j],lambda[n+j],log=T)
						}
	            				if (Model=="NegBin"){
							q.can <- dnbinom(x.cand[n+j],mu=lambda[n+j],size=lambda[n+j]/NB.alpha,log=T)
							q.cur <- dnbinom(x[n+j],mu=lambda[n+j],size=lambda[n+j]/NB.alpha,log=T)
						}
 						if (Model=="Normal") {
							q.can <- dnorm(x.cand[n+j],lambda[n+j],sqrt((1+NB.alpha)*lambda[n+j]),log=T)
							q.cur <- dnorm(x[n+j],lambda[n+j],sqrt((1+NB.alpha)*lambda[n+j]),log=T)
						}
			  			acc.prob <- exp(L.cand - L + q.cur - q.can)
					}
					if (is.na(acc.prob)) acc.prob <- 0
					if (runif(1) < acc.prob) x <- x.cand
				}
			}
			if (tune.par > 0){
                  	lambda.star <- rnorm(r,mean=lambda,sd=tune.par*lambda)
				ii <- sample(1:n,1)
				swap.indx <- abs(C[ii,])>tol
				if (any(swap.indx)){
					jj <- sample((1:(r-n))[swap.indx],1)
					if (lambda.star[ii] <= lambda.star[jj+n]/abs(C[ii,jj])){
					ei <- rep(0,n)
 					ej <- rep(0,r-n)
					ei[ii] <- 1
					ej[jj] <- 1
					dA1 <- round(C[ii,jj]*dA1)
					C <- C - outer(C[,jj]-ei,C[ii,]+ej)/C[ii,jj]
					U <- rbind(-C,diag(r-n))
					x.order[c(ii,jj+n)] <- x.order[c(jj+n,ii)]
					x[c(ii,jj+n)] <- x[c(jj+n,ii)]
 					lambda[c(ii,jj+n)] <- lambda[c(jj+n,ii)]
 					}
				}
			}
			X[x.order,1+(iter-1)*m+j] <- x
			if (verbose==1) X.ORDER[,1+(iter-1)*m+j] <- x.order
		}
	}
	if (verbose==1) x.order <- X.ORDER
	list(X=X[,seq(1,ncol(X),by=THIN)],x.order=x.order)
}


# Computes the Kullback-Leibler divergence based on kernel density
# estimates with Gaussian kernel

kld_d = function(x,y,...){

  integrand = function(x,y,t){
    denx = density(x, na.rm = T)
    deny = density(y, na.rm = T)
    f.x =  approx(denx$x,denx$y,t)$y
    f.y =  approx(deny$x,deny$y,t)$y
    tmpRatio = f.x *(log2(f.x) - log2(f.y))
    tmpRatio = ifelse(is.infinite(tmpRatio),0,ifelse(is.na(tmpRatio),0,tmpRatio))
    tmpRatio
  }
  integrate(integrand,-Inf,Inf,x = x,y = y,stop.on.error=FALSE)$value

}


#########################################################################################################
# Empirical Application Codes of
#
# "Threshold Unit Root Tests with Smooth Transitions"
#
# written by
#
# Dr. Mehmet ÖZCAN
# mehmetozcan@kmu.edu.tr
#
# *NOTES*
# 1)  Caner & Hansen (2001) Threshold Unit Root test and Threshold Effect test
#     programs are taken from Hansen's web page http://www.ssc.wisc.edu/~bhansen/ .
#     However, unit root test program are adjusted to test unit root null hypothesis
#     without any deterministic component.
#
# 2)  There are two indicator which come from Caner & Hansen (2001)'s codes. Caner &
#     Hansen investigate different type of threshol variable type and different trimming
#     intervals. In this study, lagged difference threshold variable and [0.15, 0.85]
#     trimming interval are used for all simulation experiments and empirical application.
#
#     thresh    Type of threshold variable
#  		  1 for long difference,   z(t-1)=y(t-1)-y(t-(m-1))
#  		  2 for lagged difference, z(t-1)=y(t-m)-y(t-m-1)
#  		  3 for lagged level,      z(t-1)=y(t-m)
#     trim      Trimming Range (normalized threshold, lambda)
#  		  1 for [.15,.85]
#  	 	  2 for [.10,.90]
#  		  3 for [.05,.95]
#
# 3) Results are printed to the screen.
#
# 4) All steps of application process are explained below. Please check them before run the codes.
#
# *Instructions*
#
# 1) First, please install required R packcages stated in PART-1
# 2) Run all codes in PART-1
# 3) Before run PART-2, please chose working directory folder that contains your "data.txt" file.
# 4) PART-2 codes analyse both the USA's and Turkey's data. Threfore, before analyse your data try
#    data of this study. It could be found at "data.txt" file in same repository of Dr. Özcan's GitHub page.
#
#
#
#########################################################################################################
# PART -1
#########################################################################################################
# Required Packcages
library(nloptr)
library(zoo)
# Required Functions
#########################################################################################################
# Starting value estimation for LNV(1998) Models (A, B & C) #
startLNV<-function(dta){
tt<-length(dta)
tr<-as.matrix(c(1:tt))
cc<-as.matrix(rep(1,tt))

tauGs<-c()
for(kk in 1:tt){ tauGs[kk]<-(kk/tt) }
gamaGs<-seq(1,10,1)

SSRA<-matrix(0,length(tauGs),length(gamaGs))
SSRB<-matrix(0,length(tauGs),length(gamaGs))
SSRC<-matrix(0,length(tauGs),length(gamaGs))

for(vk in 1:3){
for(vi in 1:(length(gamaGs))){
for(vj in 1:(length(tauGs))){
st<-as.matrix((1/(1+exp(-(gamaGs[vi])*((tr)-(tauGs[vj]*tt))))))
if(vk==1){X<-as.matrix(cbind(cc,st))}
if(vk==2){X<-as.matrix(cbind(cc,tr,st))}
if(vk==3){X<-as.matrix(cbind(cc,tr,st,(tr*st)))}
XX<-(MASS:::ginv(t(X)%*%X, tol=1e-25))
betas<-XX%*%(t(X)%*%dta)
Yhat<-t((t(betas)%*%t(X)))
ehat<-(dta-Yhat)
if(vk==1){SSRA[vj,vi]<-sum((ehat)^2)}
if(vk==2){SSRB[vj,vi]<-sum((ehat)^2)}
if(vk==3){SSRC[vj,vi]<-sum((ehat)^2)}
}
}
}

for(vs in 1:3){
if(vs==1){posA<-which(SSRA == min(SSRA), arr.ind = TRUE);
st<-as.matrix((1/(1+exp(-(gamaGs[posA[2]])*((tr)-(tauGs[posA[1]]*tt))))));
X<-as.matrix(cbind(cc,st))}
if(vs==2){posB<-which(SSRB == min(SSRB), arr.ind = TRUE);
st<-as.matrix((1/(1+exp(-(gamaGs[posB[2]])*((tr)-(tauGs[posB[1]]*tt))))));
X<-as.matrix(cbind(cc,tr,st))}
if(vs==3){posC<-which(SSRC == min(SSRC), arr.ind = TRUE);
st<-as.matrix((1/(1+exp(-(gamaGs[posC[2]])*((tr)-(tauGs[posC[1]]*tt))))));
X<-as.matrix(cbind(cc,tr,st,(tr*st)))}

XX<-(MASS:::ginv(t(X)%*%X, tol=1e-25))

if(vs==1){betasA<-XX%*%(t(X)%*%dta);
betasA<-rbind(betasA,gamaGs[posA[2]],tauGs[posA[1]])}
if(vs==2){betasB<-XX%*%(t(X)%*%dta);
betasB<-rbind(betasB,gamaGs[posB[2]],tauGs[posB[1]])}
if(vs==3){betasC<-XX%*%(t(X)%*%dta);
betasC<-rbind(betasC,gamaGs[posC[2]],tauGs[posC[1]])}
}
list(betasA=betasA, betasB=betasB, betasC=betasC)
}
#########################################################################################################
# LNV(1998) Models (A, B & C) Estimation with Sequential Quadratic Programing
estLNV<-function(yt, X, b0a, b0b, b0c){
tt<-length(yt)
stabA<-function(b){sum((yt-(b[1]*X[,1]+b[2]*(1/(1+exp(-(b[3])*((X[,2])-b[4]*tt))))))^2)}
stabB<-function(b){sum((yt-(b[1]*X[,1]+b[2]*X[,2]+b[3]*(1/(1+exp(-(b[4])*((X[,2])-b[5]*tt))))))^2)}
stabC<-function(b){sum((yt-(b[1]*X[,1]+b[2]*X[,2]+b[3]*(1/(1+exp(-(b[5])*((X[,2])-b[6]*tt))))+
b[4]*(X[,2])*(1/(1+exp(-(b[5])*((X[,2])-b[6]*tt))))))^2)}

lba<-c(-Inf,-Inf,0,0)
uba<-c(Inf,Inf,Inf,1)

lbb<-c(-Inf,-Inf,-Inf,0,0)
ubb<-c(Inf,Inf,Inf,Inf,1)

lbc<-c(-Inf,-Inf,-Inf,-Inf,0,0)
ubc<-c(Inf,Inf,Inf,Inf,Inf,1)

SA<-nloptr:::slsqp(b0a,fn=stabA,lower=lba,upper=uba, control=list(xtol_rel=1e-25))
SB<-nloptr:::slsqp(b0b,fn=stabB,lower=lbb,upper=ubb, control=list(xtol_rel=1e-25))
SC<-nloptr:::slsqp(b0c,fn=stabC,lower=lbc,upper=ubc, control=list(xtol_rel=1e-25))

staba<-function(b){(b[1]*X[,1]+b[2]*(1/(1+exp(-(b[3])*((X[,2])-b[4]*tt)))))}
yhatA<-staba(SA$par)

stabb<-function(b){b[1]*X[,1]+b[2]*X[,2]+b[3]*(1/(1+exp(-(b[4])*((X[,2])-b[5]*tt))))}
yhatB<-stabb(SB$par)

stabc<-function(b){(b[1]*X[,1]+b[2]*X[,2]+b[3]*(1/(1+exp(-(b[5])*((X[,2])-b[6]*tt))))+
b[4]*(X[,2])*(1/(1+exp(-(b[5])*((X[,2])-b[6]*tt)))))}
yhatC<-stabc(SC$par)

list(ehat=as.matrix(cbind((yt-yhatA),(yt-yhatB),(yt-yhatC))), yhat=as.matrix(cbind(yhatA,yhatB,yhatC)),BetaA=as.matrix(SA$par),BetaB=as.matrix(SB$par),BetaC=as.matrix(SC$par))
}
#########################################################################################################
# ADF Estimator
linear<-function(dat,p,cons,trend){
    t <- nrow(dat)
    n <- t - 1 - p
    dy <- as.matrix(dat[2:t]-dat[1:(t-1)])
    y  <- as.matrix(dy[(1+p):(t-1)])
    x  <- cbind(dat[(1+p):(t-1)], dy[p:(t-2)])

    if(p>=2){for (k in 2:p) x <- cbind(x,dy[(p+1-k):(t-1-k)])}
    if(cons==1 & trend==0)  x <- cbind(rep(1,n), x)
    if(cons==1 & trend==1)  x <- cbind(rep(1,n),seq(1,n,1),x)

    kx     <- ncol(x)
    xx     <- solve(t(x)%*%x, tol=1e-25)
    bols   <- xx%*%(t(x)%*%y)
    eols   <- y - x%*%bols
    sols   <- t(eols)%*%eols
    sigols <- sols/(n-kx)
    seols  <- sqrt(diag(xx)%*%sigols)
    rho    <- bols[1+cons+trend]
    tadf   <- rho/seols[1+cons+trend]
    ar0    <- as.matrix(bols[(cons+trend+2):(cons+trend+1+p)])
    bic<-log((sum(eols^2))/t)+(length(bols)*(log(t)/t))
    aic<-log((sum(eols^2))/t)+(length(bols)*(2/t))
    list(ar0=ar0,eols=eols,aic=aic,bic=bic,tadf=tadf,rho=rho)
}
#########################################################################################################
# Caner & Hansen (2001) Estimator
tur_est2 <- function(dat,p,mmin,mmax,m,constant,trend){
  t <- nrow(dat)
  n <- t - 1 - p
  mn <- mmax-mmin+1
  ms <- as.matrix(seq(mmin,mn,1))
  dy <- as.matrix(dat[2:t]-dat[1:(t-1)])
  y <- as.matrix(dy[(1+p):(t-1)])
  if(constant==1) x <- matrix(1,n,1)
  if (trend==1) x <- cbind(x,as.matrix(seq(1,n,1)))
  if(constant==1){x <- cbind(x,dat[(1+p):(t-1)],dy[p:(t-2)])}else{
  x <- cbind(dat[(1+p):(t-1)],dy[p:(t-2)])}
  if(p>1) for (ki in 2:p) x <- cbind(x,dy[(p+1-ki):(t-1-ki)])

  if (sum(coef)==0){
      xi_ns <- as.matrix(seq(1,p,1)+1+constant+trend)
        }else{
      idex <- colSums(as.matrix(coef%*%matrix(1,1,p))==(matrix(1,nrow(coef),1)%*%seq(1,p,1)))
      xi_ns <- seq(1,p,1)
      xi_ns <- as.matrix(xi_ns[idex==0]+1+constant+trend)
    }

  if (trend==0){
        if(constant==0){
	        if (sum(coef)==0){
            xi_s <- rbind(1)
                }else{xi_s <- rbind(1,(coef+1))
            }
        }
    }
  if (trend==0){
        if(constant==1){
	        if (sum(coef)==0){
            xi_s <- rbind(1,2)
                }else{
                xi_s <- rbind(1,2,(coef+2))
            }
        }
    }
  if (trend==1){
        if(constant==1){
	        if (sum(coef)==0){
            xi_s <- rbind(1,2,3)
                }else{
                xi_s <- rbind(1,2,3,(coef+3))
            }
         }
    }
  xs <- as.matrix(x[,xi_s])
  xns <- as.matrix(x[,xi_ns])
  if (thresh==1){
      qs <- dat[(1+p):(t-1)]-dat[(1+p-mmin):(t-1-mmin)]
      qs <- as.matrix(qs)
      if(p>1){
	  for (mi in (mmin+1):mmax){
          qs <- cbind(qs,(dat[(1+p):(t-1)]-dat[(1+p-mi):(t-1-mi)]))
      }
	  }
  }
  if (thresh==2){
      qs <- dat[(1+p-mmin+1):(t-1-mmin+1)]-dat[(1+p-mmin):(t-1-mmin)]
      qs <- as.matrix(qs)
      if(p>1){
	  for (mi in (mmin+1):mmax){
          qs <- cbind(qs,(dat[(1+p-mi+1):(t-1-mi+1)]-dat[(1+p-mi):(t-1-mi)]))
      }
	  }
  }
  if (thresh==3){
      qs <- dat[(1+p-mmin+1):(t-mmin)]
      qs <- as.matrix(qs)
      if(p>1){
	  for (mi in (mmin+1):mmax){
          qs <- cbind(qs,(dat[(1+p-mi+1):(t-mi)]))
      }
	  }
  }
  kx    <- ncol(x)
  ks    <- nrow(coef)+1+constant+trend
  xx    <- solve(t(x)%*%x, tol=1e-25)
  bols  <- xx%*%(t(x)%*%y)
  eols  <- y - x%*%bols
  sols  <- t(eols)%*%eols
  wwss  <- matrix(0,mn,1)
  smins <- matrix(0,mn,1)
  lams  <- matrix(0,mn,1)
  ws    <- matrix(0,mn,1)
  r1    <- matrix(0,mn,1)
  r2    <- matrix(0,mn,1)
  t1    <- matrix(0,mn,1)
  t2    <- matrix(0,mn,1)
  rur <- rbind(1,(ks+1))+trend+constant
  indx <- 1:(n)
  pi1 <-.2-.05*trim
  pi2 <-.8+.05*trim
  for (mi in 1:mn){
    q <- qs[,mi]
    qq <- unique(q)
    qq <- as.matrix(sort(qq))
    qq <- as.matrix(qq[(floor(n*pi1)+1):(ceiling(n*pi2)-1)])
    qn <- nrow(qq)
    s  <- matrix(0,qn,1)
    wws<- matrix(0,qn,1)
    for (qi in 1:qn){
      d1      <- as.matrix((q<qq[qi]))
      d2      <- 1-d1
      xz      <- cbind((xs*(d1%*%matrix(1,1,ncol(xs)))),(xs*(d2%*%matrix(1,1,ncol(xs)))),xns)
      xxi     <- solve(t(xz)%*%xz, tol=1e-25)
      bthresh <- xxi%*%(t(xz)%*%y)
      e       <- y-xz%*%bthresh
      s[qi]   <- t(e)%*%e
      v       <- xxi*as.vector((t(e)%*%e)/(n-kx-ks))
      vd      <- diag(v)
      ts      <- as.matrix(bthresh[rur]/sqrt(vd[rur]))
      wws[qi] <- t(ts)%*%ts
    }
    qi         <- which.max(wws)
    lam        <- qq[qi]
    smin       <- s[qi]
    wwsmax     <- wws[qi]
    ws[mi]     <- (n-kx-ks)*(sols-smin)/smin
    smins[mi]  <- smin
    lams[mi]   <- lam
    wwss[mi]   <- wwsmax
    d1         <- as.matrix((q<lam))
    d2         <- 1-d1
    xz         <- cbind((xs*(d1%*%matrix(1,1,ncol(xs)))),(xs*(d2%*%matrix(1,1,ncol(xs)))),xns)
    mmi        <- solve(t(xz)%*%xz, tol=1e-25)
    bthresh    <- mmi%*%(t(xz)%*%y)
    e          <- y - xz%*%bthresh
    v          <- mmi*as.vector((t(e)%*%e)/(n-kx-ks))
    vd         <- diag(v)
    ts         <- as.matrix(bthresh[rur]/sqrt(vd[rur]))
    r1[mi]     <- t(ts^2)%*%(ts<0)
    r2[mi]     <- t(ts)%*%ts
    t1[mi]     <- -ts[1]
    t2[mi]     <- -ts[2]
  }
  if (m != 0) {mi <- m-mmin+1}else{mi<- which.max(wwss)}
  mhat     <- ms[mi]
  w        <- ws[mi]
  lam      <- lams[mi]
  q        <- qs[,mi]
  d1       <- as.matrix((q<lam))
  d2       <- 1-d1
  xz       <- cbind((xs*(d1%*%matrix(1,1,ncol(xs)))),(xs*(d2%*%matrix(1,1,ncol(xs)))),xns)
  mmi      <- solve(t(xz)%*%xz, tol=1e-25)
  bthresh  <- mmi%*%(t(xz)%*%y)
  e        <- y - xz%*%bthresh
  ee       <- t(e)%*%e
  v        <- mmi*as.vector((ee)/(n-kx-ks))
  vd       <- diag(v)
  v1       <- vd[1:ks]
  v2       <- vd[(ks+1):(2*ks)]
  b1       <- bthresh[1:ks]
  b2       <- bthresh[(ks+1):(2*ks)]
  ts       <- as.matrix(((b1-b2)^2)/(v1+v2))
  bs_s     <- cbind(b1,sqrt(v1),matrix(0,ks,1),b2,sqrt(v2))
  bs_ns    <- cbind(bthresh[(1+2*ks):(kx+ks)],sqrt(vd[(1+2*ks):(kx+ks)]))
  ar01     <-bthresh[(2+constant+trend):(ks)]
  ar02     <-bthresh[(2+constant+trend+ks):(ks*2)]
  leng     <-sum(x[,ncol(x)]>lam)
list(mhat=mhat,lam=lam,e=e,bs_s=bs_s,ar01=ar01,ar02=ar02,b1=b1,b2=b2,r1=r1,r2=r2,t1=t1,t2=t2,ts=ts,ws=ws,w=w,
wws=wws, wwss=wwss,leng=leng,vd=vd)
}
# Caner & Hansen (2001) Threshold Effect Wald Test Bootstrap p-values
pvWald<-function(dat,p,ar0,eols,rho,boot,w){
t <- nrow(dat)
n <- t - 1 - p
y0 <- dat-mean(dat)
y0 <- as.matrix(y0[1:(1+p)])
aa <- matrix(0,p+1,1)
aa[1] <- 1 + rho
aa[1:p] <- aa[1:p] + ar0
aa[2:(p+1)] <- aa[2:(p+1)] - ar0
bootw <- matrix(0,boot,1)
for (ib in 1:boot){
    eols_c <- as.matrix(eols[ceiling(runif(t)*n)])
    datb <- y0
for (i in (nrow(y0)+1):(nrow(eols_c))){
        datbb <- eols_c[i]
        for (j in 1:nrow(y0)) datbb <- datbb + aa[j]*datb[(i-j)]
        datb <- rbind(datb,datbb)
    }
out       <- tur_est2(datb,p,1,p,0,0,0)
bootw[ib] <- out$w
}
pw <- mean(bootw > w)
cbind(w,pw)
}

#########################################################################################################
# 5% Criticals T=200
R1A <- 20.82907
R2A <- 21.07073
R1B <- 26.67934
R2B <- 26.80033
R1C <- 29.65022
R2C <- 29.69269
LNVa<- -4.161
LNVb<- -4.629
LNVc<- -4.867
ADFm<- -2.8759
ADFt<- -3.4326 # MacKinnon (1991) based Critical value

#########################################################################################################
# PART - 2
#########################################################################################################
# Aplication
# select working directory file.
# setwd("your folder directory")
# read data
D   <- read.table("data.txt")
tri <- D[,1]
usi <- D[,2]
# logarithms
tri <-as.matrix(log(tri))
usi <-as.matrix(log(usi))
# estimation parameter of LNV smooth transition functions
tr    <-as.matrix(c(1:length(tri)))
cc    <-as.matrix(rep(1,length(tri)))
X     <-as.matrix(cbind(cc,tr))
SLNVtr<- startLNV(tri)
SLNVus<- startLNV(usi)
b0atr <- SLNVtr$betasA; b0btr  <- SLNVtr$betasB; b0ctr  <- SLNVtr$betasC
b0aus <- SLNVus$betasA; b0bus  <- SLNVus$betasB; b0cus  <- SLNVus$betasC

ELNVtr<- estLNV(tri, X, b0atr, b0btr, b0ctr)
ELNVus<- estLNV(usi, X, b0aus, b0bus, b0cus)
Ytr   <- as.matrix(ELNVtr$yhat)
Yus   <- as.matrix(ELNVus$yhat)
Dtr   <- as.matrix(ELNVtr$ehat)
Dus   <- as.matrix(ELNVus$ehat)
# plots
# TR
par(mfrow=c(3,1))
plot(ts(Ytr[,1], start=c(2004,1),frequency=12),lty=2,axes=FALSE,lwd=2,col="black",ylab=NA,xlab="Years",main="Model A",ylim=c(min(tri),max(tri)))
mtext(side=3,text=paste("industrial production and fitted smooth transition for Turkey"),line=2.5,lwd=2,cex=1)
lines(ts(tri, start=c(2004,1), frequency=12),lty=1, lwd=2, col="gray42")
axis(1, at=c(2004:2020), labels=c(2004:2020),las=3, gap.axis=0.1)
axis(2, at = seq(round(min(tri),1),round(max(tri),1),0.1),lwd=1.5)
abline(v=(seq(2004,2020,1)), col="lightgray", lty="dotted")
abline(h=seq(round(min(tri),1),round(max(tri),1),0.1), col="lightgray", lty="dotted")
plot(ts(Ytr[,2], start=c(2004,1),frequency=12),lty=2,axes=FALSE,lwd=2,col="black",ylab=NA,xlab="Years",main="Model B",ylim=c(min(tri),max(tri)))
lines(ts(tri, start=c(2004,1), frequency=12),lty=1, lwd=2, col="gray42")
axis(1, at=c(2004:2020), labels=c(2004:2020),las=3, gap.axis=0.1)
axis(2, at = seq(round(min(tri),1),round(max(tri),1),0.1),lwd=1.5)
abline(v=(seq(2004,2020,1)), col="lightgray", lty="dotted")
abline(h=seq(round(min(tri),1),round(max(tri),1),0.1), col="lightgray", lty="dotted")
plot(ts(Ytr[,3], start=c(2004,1),frequency=12),lty=2,axes=FALSE,lwd=2,col="black",ylab=NA,xlab="Years",main="Model C",ylim=c(min(tri),max(tri)))
lines(ts(tri, start=c(2004,1), frequency=12),lty=1, lwd=2, col="gray42")
axis(1, at=c(2004:2020), labels=c(2004:2020),las=3, gap.axis=0.1)
axis(2, at = seq(round(min(tri),1),round(max(tri),1),0.1),lwd=1.5)
abline(v=(seq(2004,2020,1)), col="lightgray", lty="dotted")
abline(h=seq(round(min(tri),1),round(max(tri),1),0.1), col="lightgray", lty="dotted")

# US
par(mfrow=c(3,1))
plot(ts(Yus[,1], start=c(2004,1),frequency=12),lty=2,axes=FALSE,lwd=2,col="black",ylab=NA,xlab="Years",main="Model A",ylim=c(min(usi),max(usi)))
mtext(side=3,text=paste("industrial production and fitted smooth transition for USA"),line=2.5,lwd=2,cex=1)
lines(ts(usi, start=c(2004,1), frequency=12),lty=1, lwd=2, col="gray42")
axis(1, at=c(2004:2020), labels=c(2004:2020),las=3, gap.axis=0.1)
axis(2, at = seq(round(min(usi),1),round(max(usi),1),0.1),lwd=1.5)
abline(v=(seq(2004,2020,1)), col="lightgray", lty="dotted")
abline(h=seq(round(min(usi),1),round(max(usi),1),0.1), col="lightgray", lty="dotted")
plot(ts(Yus[,2], start=c(2004,1),frequency=12),lty=2,axes=FALSE,lwd=2,col="black",ylab=NA,xlab="Years",main="Model B",ylim=c(min(usi),max(usi)))
lines(ts(usi, start=c(2004,1), frequency=12),lty=1, lwd=2, col="gray42")
axis(1, at=c(2004:2020), labels=c(2004:2020),las=3, gap.axis=0.1)
axis(2, at = seq(round(min(usi),1),round(max(usi),1),0.1),lwd=1.5)
abline(v=(seq(2004,2020,1)), col="lightgray", lty="dotted")
abline(h=seq(round(min(usi),1),round(max(usi),1),0.1), col="lightgray", lty="dotted")
plot(ts(Yus[,3], start=c(2004,1),frequency=12),lty=2,axes=FALSE,lwd=2,col="black",ylab=NA,xlab="Years",main="Model C",ylim=c(min(usi),max(usi)))
lines(ts(usi, start=c(2004,1), frequency=12),lty=1, lwd=2, col="gray42")
axis(1, at=c(2004:2020), labels=c(2004:2020),las=3, gap.axis=0.1)
axis(2, at = seq(round(min(usi),1),round(max(usi),1),0.1),lwd=1.5)
abline(v=(seq(2004,2020,1)), col="lightgray", lty="dotted")
abline(h=seq(round(min(usi),1),round(max(usi),1),0.1), col="lightgray", lty="dotted")

# Extraction of Estimated Data
# write.table(as.matrix(cbind(tri,Ytr[,1],Ytr[,2],Ytr[,3])),"TRest.txt",row.names=FALSE,col.names=FALSE)
# write.table(as.matrix(cbind(usi,Yus[,1],Yus[,2],Yus[,3])),"USest.txt",row.names=FALSE,col.names=FALSE)

# ADF Test
maxp<- 10
BIC <- matrix(0,maxp,2)
for(i in 1:maxp){
adftr <- linear(as.matrix(tri),i,1,1)
adfus <- linear(as.matrix(usi),i,1,1)
BIC[i,1]<-adftr$bic
BIC[i,2]<-adfus$bic
}
ptr <- which.min(BIC[,1])
pus <- which.min(BIC[,2])

adftr0 <- linear(as.matrix(tri),ptr,1,1)
adfus0 <- linear(as.matrix(usi),pus,1,1)

# LNV Test
BICL <- matrix(0,maxp,6)
for(i in 1:maxp){
adftra <- linear(as.matrix(Dtr[,1]),i,1,1)
adftrb <- linear(as.matrix(Dtr[,2]),i,1,1)
adftrc <- linear(as.matrix(Dtr[,3]),i,1,1)

adfusa <- linear(as.matrix(Dus[,1]),i,1,1)
adfusb <- linear(as.matrix(Dus[,2]),i,1,1)
adfusc <- linear(as.matrix(Dus[,3]),i,1,1)

BICL[i,1]<-adftra$bic; BICL[i,2]<-adftrb$bic; BICL[i,3]<-adftrc$bic;
BICL[i,4]<-adfusa$bic; BICL[i,5]<-adfusb$bic; BICL[i,6]<-adfusc$bic
}
ptra <- which.min(BICL[,1]); ptrb <- which.min(BICL[,2]); ptrc <- which.min(BICL[,3]);
pusa <- which.min(BICL[,4]); pusb <- which.min(BICL[,5]); pusc <- which.min(BICL[,6]);
PLNV <-cbind(ptra,ptrb,ptrc,pusa,pusb,pusc)

adftrA <- linear(as.matrix(Dtr[,1]),ptra,1,1)
adftrB <- linear(as.matrix(Dtr[,2]),ptrb,1,1)
adftrC <- linear(as.matrix(Dtr[,3]),ptrc,1,1)

adfusA <- linear(as.matrix(Dus[,1]),pusa,1,1)
adfusB <- linear(as.matrix(Dus[,2]),pusb,1,1)
adfusC <- linear(as.matrix(Dus[,3]),pusc,1,1)

# Caner & Hansen (2001) Test with Smooth Transition
# Caner & Hansen (2001) TAR Model Estimation Settings
thresh   <- 2
trim     <- 1
#
MAXR <- matrix(0,maxp,6)
for(i in 1:maxp){
coef   <- matrix(c(1:i),i,1)
tarAtr <-tur_est2(as.matrix(Dtr[,1]),i,1,i,0,0,0)
tarBtr <-tur_est2(as.matrix(Dtr[,2]),i,1,i,0,0,0)
tarCtr <-tur_est2(as.matrix(Dtr[,3]),i,1,i,0,0,0)

tarAus <-tur_est2(as.matrix(Dus[,1]),i,1,i,0,0,0)
tarBus <-tur_est2(as.matrix(Dus[,2]),i,1,i,0,0,0)
tarCus <-tur_est2(as.matrix(Dus[,3]),i,1,i,0,0,0)

MAXR[i,1]<-tarAtr$r1[tarAtr$mhat]; MAXR[i,2]<-tarBtr$r1[tarBtr$mhat]; MAXR[i,3]<-tarCtr$r1[tarCtr$mhat];
MAXR[i,4]<-tarAus$r1[tarAus$mhat]; MAXR[i,5]<-tarBus$r1[tarBus$mhat]; MAXR[i,6]<-tarCus$r1[tarCus$mhat]
}
ptrA <- which.max(MAXR[,1]); ptrB <- which.max(MAXR[,2]); ptrC <- which.max(MAXR[,3]);
pusA <- which.max(MAXR[,4]); pusB <- which.max(MAXR[,5]); pusC <- which.max(MAXR[,6]);
PLCH <- cbind(ptrA,ptrB,ptrC,pusA,pusB,pusC)

coef   <- matrix(c(1:ptrA),ptrA,1)
tartrA <- tur_est2(as.matrix(Dtr[,1]),ptrA,1,ptrA,0,0,0)
coef   <- matrix(c(1:ptrB),ptrB,1)
tartrB <- tur_est2(as.matrix(Dtr[,2]),ptrB,1,ptrB,0,0,0)
coef   <- matrix(c(1:ptrC),ptrC,1)
tartrC <- tur_est2(as.matrix(Dtr[,3]),ptrC,1,ptrC,0,0,0)

coef   <- matrix(c(1:pusA),pusA,1)
tarusA <- tur_est2(as.matrix(Dus[,1]),pusA,1,pusA,0,0,0)
coef   <- matrix(c(1:pusB),pusB,1)
tarusB <- tur_est2(as.matrix(Dus[,2]),pusB,1,pusB,0,0,0)
coef   <- matrix(c(1:pusC),pusC,1)
tarusC <- tur_est2(as.matrix(Dus[,3]),pusC,1,pusC,0,0,0)

# Caner & Hansen (2001) Threshold Effect test statistics and p-values #
set.seed(12345)
boot<-1000
# Turkey
coef    <- matrix(c(1:ptrA),ptrA,1)
lnWAtr  <- linear(as.matrix(Dtr[,1]),ptrA,0,0)
pvalAtr <- pvWald(as.matrix(Dtr[,1]),ptrA,lnWAtr$ar0,lnWAtr$eols,lnWAtr$rho,boot,tartrA$w)
coef    <- matrix(c(1:ptrB),ptrB,1)
lnWBtr  <- linear(as.matrix(Dtr[,2]),ptrB,0,0)
pvalBtr <- pvWald(as.matrix(Dtr[,2]),ptrB,lnWBtr$ar0,lnWBtr$eols,lnWBtr$rho,boot,tartrB$w)
coef    <- matrix(c(1:ptrC),ptrC,1)
lnWCtr  <- linear(as.matrix(Dtr[,3]),ptrC,0,0)
pvalCtr <- pvWald(as.matrix(Dtr[,3]),ptrC,lnWCtr$ar0,lnWCtr$eols,lnWCtr$rho,boot,tartrC$w)
# USA
coef    <- matrix(c(1:pusA),pusA,1)
lnWAus  <- linear(as.matrix(Dus[,1]),pusA,0,0)
pvalAus <- pvWald(as.matrix(Dus[,1]),pusA,lnWAus$ar0,lnWAus$eols,lnWAus$rho,boot,tarusA$w)
coef    <- matrix(c(1:pusB),pusB,1)
lnWBus  <- linear(as.matrix(Dus[,2]),pusB,0,0)
pvalBus <- pvWald(as.matrix(Dus[,2]),pusB,lnWBus$ar0,lnWBus$eols,lnWBus$rho,boot,tarusB$w)
coef    <- matrix(c(1:pusC),pusC,1)
lnWCus  <- linear(as.matrix(Dus[,3]),pusC,0,0)
pvalCus <- pvWald(as.matrix(Dus[,3]),pusC,lnWCus$ar0,lnWCus$eols,lnWCus$rho,boot,tarusC$w)

# Tables
trit<-ts(diff(tri,1),start<-c(2004,2),frequency=12)
usit<-ts(diff(usi,1),start<-c(2004,2),frequency=12)
ntr <-length(tri)
nus <-length(usi)
printlog<-function(tri,usi){
cat ("\n")
cat ("Parameter Estimation Result of Smooth Transition for Industrial Production Index of Turkey" , "\n")
cat ("Number of Observations:", ntr                                                               , "\n")
cat ("Optimization          : Sequential Quadratic Programming"                                   , "\n")
cat ("\n")
cat ("Model A"                                                                                , "\n")
cat ("Mid Point Date"                                                                             , "\n")
cat ("--------------"                                                                             , "\n")
print(as.yearmon(time(trit))[round((ELNVtr$BetaA[4]*ntr))])
cat ("Mid Point Tau               :", ELNVtr$BetaA[4]                                             , "\n")
cat ("Speed of Transition Gamma   :", ELNVtr$BetaA[3]                                             , "\n")
cat ("\n")
cat ("Model B"                                                                                , "\n")
cat ("Mid Point Date"                                                                             , "\n")
cat ("--------------"                                                                             , "\n")
print(as.yearmon(time(trit))[round((ELNVtr$BetaB[5]*ntr))])
cat ("Mid Point Tau               :", ELNVtr$BetaB[5]                                             , "\n")
cat ("Speed of Transition Gamma   :", ELNVtr$BetaB[4]                                             , "\n")
cat ("\n")
cat ("Model C"                                                                                , "\n")
cat ("Mid Point Date"                                                                             , "\n")
cat ("--------------"                                                                             , "\n")
print(as.yearmon(time(trit))[round((ELNVtr$BetaC[6]*ntr))])
cat ("Mid Point Tau               :", ELNVtr$BetaC[6]                                             , "\n")
cat ("Speed of Transition Gamma   :", ELNVtr$BetaC[5]                                             , "\n")
cat ("\n")
cat ("*******************************************************************************************", "\n")
cat ("\n")
cat ("Parameter Estimation Result of Smooth Transition for Industrial Production Index of USA"    , "\n")
cat ("Number of Observations:", nus                                                               , "\n")
cat ("Optimization          : Sequential Quadratic Programming"                                   , "\n")
cat ("\n")
cat ("Model A"                                                                                , "\n")
cat ("Mid Point Date"                                                                             , "\n")
cat ("--------------"                                                                             , "\n")
print(as.yearmon(time(usit))[round((ELNVus$BetaA[4]*nus))])
cat ("Mid Point Tau               :", ELNVus$BetaA[4]                                             , "\n")
cat ("Speed of Transition Gamma   :", ELNVus$BetaA[3]                                             , "\n")
cat ("\n")
cat ("Model B"                                                                                , "\n")
cat ("Mid Point Date"                                                                             , "\n")
cat ("--------------"                                                                             , "\n")
print(as.yearmon(time(usit))[round((ELNVus$BetaB[5]*nus))])
cat ("Mid Point Tau               :", ELNVus$BetaB[5]                                             , "\n")
cat ("Speed of Transition Gamma   :", ELNVus$BetaB[4]                                             , "\n")
cat ("\n")
cat ("Model C"                                                                                , "\n")
cat ("Mid Point Date"                                                                             , "\n")
cat ("--------------"                                                                             , "\n")
print(as.yearmon(time(usit))[round((ELNVus$BetaC[6]*nus))])
cat ("Mid Point Tau               :", ELNVus$BetaC[6]                                             , "\n")
cat ("Speed of Transition Gamma   :", ELNVus$BetaC[5]                                             , "\n")
cat ("\n")
cat ("*******************************************************************************************", "\n")
cat ("\n")
}

printadf<-function(tri,usi,ptr,pus){
cat ("\n")
cat ("ADF Results for Industrial Production Index of Turkey" , "\n")
cat ("Number of Observations:", length(tri)                  , "\n")
cat ("Selected Optimal Lag  :", ptr, "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Model Type            : Constant & Trend"              , "\n")
cat ("Test Statistics       :", adftr0$tadf                  , "\n")
cat ("5% Critical Value     :",ADFt                          , "\n")
cat ("\n")
cat ("ADF Results for Industrial Production Index of USA"    , "\n")
cat ("Number of Observations:", length(usi)                  , "\n")
cat ("Selected Optimal Lag  :", pus, "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Model Type            : Constant & Trend"              , "\n")
cat ("Test Statistics       :", adfus0$tadf                  , "\n")
cat ("5% Critical Value     :",ADFt                          , "\n")
}

printlnv<-function(tri,usi,PLNV){
cat ("\n")
cat ("LNV Results for Industrial Production Index of Turkey" , "\n")
cat ("Number of Observations:", length(tri)                  , "\n")
cat ("\n")
cat ("Model A"                                               , "\n")
cat ("Selected Optimal Lag  :", PLNV[1]                      , "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Test Statistics       :", adftrA$tadf                  , "\n")
cat ("5% Critical Value     :", LNVa                         , "\n")
cat ("\n")
cat ("Model B"                                               , "\n")
cat ("Selected Optimal Lag  :", PLNV[2]                      , "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Test Statistics       :", adftrB$tadf                  , "\n")
cat ("5% Critical Value     :", LNVb                         , "\n")
cat ("\n")
cat ("Model C"                                               , "\n")
cat ("Selected Optimal Lag  :", PLNV[3]                      , "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Test Statistics       :", adftrC$tadf                  , "\n")
cat ("5% Critical Value     :", LNVc                         , "\n")
cat ("\n")
cat ("******************************************************", "\n")
cat ("\n")
cat ("LNV Results for Industrial Production Index of USA" , "\n")
cat ("Number of Observations:", length(usi)                  , "\n")
cat ("\n")
cat ("Model A"                                               , "\n")
cat ("Selected Optimal Lag  :", PLNV[4]                      , "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Test Statistics       :", adfusA$tadf                  , "\n")
cat ("5% Critical Value     :", LNVa                         , "\n")
cat ("\n")
cat ("Model B"                                               , "\n")
cat ("Selected Optimal Lag  :", PLNV[5]                      , "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Test Statistics       :", adfusB$tadf                  , "\n")
cat ("5% Critical Value     :", LNVb                         , "\n")
cat ("\n")
cat ("Model C"                                               , "\n")
cat ("Selected Optimal Lag  :", PLNV[6]                      , "\n")
cat ("Information Criteria  : BIC"                           , "\n")
cat ("Test Statistics       :", adfusC$tadf                  , "\n")
cat ("5% Critical Value     :", LNVc                         , "\n")
cat ("\n")
}

printlch<-function(tri,usi,PLCH){
cat ("\n")
cat ("New Combined Caner & Hansen (2001) Results for Industrial Production Index of Turkey"            , "\n")
cat ("Number of Observations:", length(tri)                                                            , "\n")
cat ("\n")
cat ("Model A"                                                                                , "\n")
cat ("Selected Optimal Lag :",PLCH[1]                                                                  , "\n")
cat ("Information Criteria : Superme RT"                                                               , "\n")
cat ("R1 Test Statistics   :",tartrA$r1[tartrA$mhat],"  / R2 Test Statistics   :",tartrA$r2[tartrA$mhat] , "\n")
cat ("R1 5% Critical Value :",R1A                   ,"/ R2 5% Critical Value :",R2A                    , "\n")
cat ("++++++++++++++++++++++"                                                                          , "\n")
cat ("Caner & Hansen (2001) Threshold Effect Wald Test"                                                , "\n")
cat ("Test Statistics      :",pvalAtr[1]                                                               , "\n")
cat ("Bootstrap p-value    :",pvalAtr[2]                                                               , "\n")
cat ("\n")
cat ("Model B"                                                                                , "\n")
cat ("Selected Optimal Lag :",PLCH[2]                                                                  , "\n")
cat ("Information Criteria : Superme RT"                                                               , "\n")
cat ("R1 Test Statistics   :",tartrB$r1[tartrB$mhat],"/ R2 Test Statistics   :",tartrB$r2[tartrB$mhat] , "\n")
cat ("R1 5% Critical Value :",R1B                   ,"/ R2 5% Critical Value :",R2B                    , "\n")
cat ("++++++++++++++++++++++"                                                                          , "\n")
cat ("Caner & Hansen (2001) Threshold Effect Wald Test"                                                , "\n")
cat ("Test Statistics      :",pvalBtr[1]                                                               , "\n")
cat ("Bootstrap p-value    :",pvalBtr[2]                                                               , "\n")
cat ("\n")
cat ("Model C"                                                                                , "\n")
cat ("Selected Optimal Lag :",PLCH[3]                                                                  , "\n")
cat ("Information Criteria : Superme RT"                                                               , "\n")
cat ("R1 Test Statistics   :",tartrC$r1[tartrC$mhat],"/ R2 Test Statistics   :",tartrC$r2[tartrC$mhat] , "\n")
cat ("R1 5% Critical Value :",R1C                   ,"/ R2 5% Critical Value :",R2C                    , "\n")
cat ("++++++++++++++++++++++"                                                                          , "\n")
cat ("Caner & Hansen (2001) Threshold Effect Wald Test"                                                , "\n")
cat ("Test Statistics      :",pvalCtr[1]                                                               , "\n")
cat ("Bootstrap p-value    :",pvalCtr[2]                                                               , "\n")
cat ("\n")
cat ("************************************************************************************************", "\n")
cat ("\n")
cat ("New Combined Caner & Hansen (2001) Results for Industrial Production Index of USA"               , "\n")
cat ("Number of Observations:", length(usi)                                                            , "\n")
cat ("\n")
cat ("Model A"                                                                                , "\n")
cat ("Selected Optimal Lag :",PLCH[4]                                                                  , "\n")
cat ("Information Criteria : Superme RT"                                                               , "\n")
cat ("R1 Test Statistics   :",tarusA$r1[tarusA$mhat],"/ R2 Test Statistics   :",tarusA$r2[tarusA$mhat] , "\n")
cat ("R1 5% Critical Value :",R1A                   ,"/ R2 5% Critical Value :",R2A                    , "\n")
cat ("++++++++++++++++++++++"                                                                          , "\n")
cat ("Caner & Hansen (2001) Threshold Effect Wald Test"                                                , "\n")
cat ("Test Statistics      :",pvalAus[1]                                                               , "\n")
cat ("Bootstrap p-value    :",pvalAus[2]                                                               , "\n")
cat ("\n")
cat ("Model B"                                                                                , "\n")
cat ("Selected Optimal Lag :",PLCH[5]                                                                  , "\n")
cat ("Information Criteria : Superme RT"                                                               , "\n")
cat ("R1 Test Statistics   :",tarusB$r1[tarusB$mhat],"/ R2 Test Statistics   :",tarusB$r2[tarusB$mhat] , "\n")
cat ("R1 5% Critical Value :",R1B                   ,"/ R2 5% Critical Value :",R2B                    , "\n")
cat ("++++++++++++++++++++++"                                                                          , "\n")
cat ("Caner & Hansen (2001) Threshold Effect Wald Test"                                                , "\n")
cat ("Test Statistics      :",pvalBus[1]                                                               , "\n")
cat ("Bootstrap p-value    :",pvalBus[2]                                                               , "\n")
cat ("\n")
cat ("Model C"                                                                                , "\n")
cat ("Selected Optimal Lag :",PLCH[6]                                                                  , "\n")
cat ("Information Criteria : Superme RT"                                                               , "\n")
cat ("R1 Test Statistics   :",tarusC$r1[tarusC$mhat],"/ R2 Test Statistics   :",tarusC$r2[tarusC$mhat] , "\n")
cat ("R1 5% Critical Value :",R1C                   ,"/ R2 5% Critical Value :",R2C                    , "\n")
cat ("++++++++++++++++++++++"                                                                          , "\n")
cat ("Caner & Hansen (2001) Threshold Effect Wald Test"                                                , "\n")
cat ("Test Statistics      :",pvalCus[1]                                                               , "\n")
cat ("Bootstrap p-value    :",pvalCus[2]                                                               , "\n")
cat ("\n")
}

printlog(tri,usi)
printadf(tri,usi,ptr,pus)
printlnv(tri,usi,PLNV)
printlch(tri,usi,PLCH)

# END


#' Title
#'
#' @param observed   observed values of dependent variable.
#' @param predicted  predicted values of dependent variable.
#' @param norm       Normalize RMSE score to the mean abundance of the observed values? Default is FALSE.
#'
#' @return           returns RMSE score.
#' @export
#'
#' @examples
rmse <- function(observed, predicted, norm = F){
  #compatability tests.
  if(sum(is.na(observed )) > 0){stop('Error: NAs in observed vector.' )}
  if(sum(is.na(predicted)) > 0){stop('Error: NAs in predicted vector.')}
  if(length(observed) != length(predicted)){stop('Error: predicted and observed vectors must be the same length.')}

  #get sample size.
  N <- length(observed)

  #calculate residual sums of squares relative to actual prediction (i.e. "1:1 line")
  SS.res <- sum((observed - predicted)^2)

  #divide by sample size, take square root.
  obs.rmse <- sqrt(SS.res / N)

  #Normalize RMSE score, if desired.
  if(norm == T){
    obs.rmse <- obs.rmse / mean(observed)
  }

  #return RMSE.
  return(obs.rmse)
}


rares = c(
  "8217" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "38" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "7544" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "2605" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "313" = list(x=   quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "7599" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "2285" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "7848" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "6662" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "1382" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "4531" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "4975" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "2591" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "7880" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "7458" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "1893" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^2))),
  "7459" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^2))),
  "6288" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^2))),
  "2543" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^2))),
  "2313" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^2))),
  "1104" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "392" = list(x=   quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "7958" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "7252" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "8032" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "2787" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "1176" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "3073" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "9309" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "7535" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "7423" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "8356" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "3255" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "9228" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "1759" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "8994" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "469" = list(x=   quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "4182" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "2638" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "3403" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "1820" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "5139" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "6208" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "4849" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "8951" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "7168" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "6167" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "2096" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "9571" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "6417" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "7942" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "9727" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "4396" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "3159" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "5099" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "5420" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "8572" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "3513" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "1053" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "16" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "4502" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^4))),
  "2295" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^4))),
  "8634" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^4))),
  "3112" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^4))),
  "744" = list(x=   quote(runif(1, -1, 1) * x_i^2 - sin(y_i^4)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^4))),
  "6564" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "6593" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "985" = list(x=   quote(runif(1, -1, 1) * x_i^4 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "3605" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "7061" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "5753" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "6278" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "4745" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "6726" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "5013" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "5531" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "2513" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "8872" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "5594" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "9891" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "4158" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "5870" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "7910" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "2500" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "5711" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "1677" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "904" = list(x=   quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "3897" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "6660" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "2345" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "7087" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "345" = list(x=   quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "3900" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "6557" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "4358" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "8033" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "3856" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "396" = list(x=   quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "8482" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "5702" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "1516" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "8762" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "3576" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "6987" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "4397" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "5975" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "1042" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "5225" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "2794" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "2589" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "8392" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "8715" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "4401" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "1384" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "894" = list(x=   quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "5738" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "3951" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "5193" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^1 - cos(x_i^4))),
  "3257" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^2))),
  "7350" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^2))),
  "759" = list(x=   quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^2))),
  "6342" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^4))),
  "8926" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^3))),
  "3148" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^1))),
  "2913" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^1))),
  "998" = list(x=   quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "371" = list(x=   quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "3500" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "7312" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "2376" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^2))),
  "8324" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^2))),
  "2169" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "5834" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^0)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^0))),
  "6292" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^0)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^0))),
  "5984" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^0)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^0))),
  "2939" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^1))),
  "173" = list(x=   quote(runif(1, -1, 1) * x_i^3 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^1))),
  "3378" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^1))),
  "1505" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^3))),
  "9728" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^3)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^3))),
  "7116" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^5)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^5))),
  "1757" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - sin(x_i^2))),
  "9907" = list(x=  quote(runif(1, -1, 1) * x_i^4 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^4 - cos(x_i^2))),
  "7238" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^2))),
  "9484" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "2338" = list(x=  quote(runif(1, -1, 1) * x_i^3 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^3 - cos(x_i^2))),
  "2338" = list(x=  quote(runif(1, -1, 1) * x_i^1 - sin(y_i^1)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^2))),
  "2338" = list(x=  quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)), y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^2))))


#  James Rekow

partition = function(n, numPartitions){

  #  ARGS: n - number to be partitioned
  #        numPartitions - number of pieces into which n is to be partitioned
  #
  #  RETURNS: partitionSizeVec - numeric vector of the unique set of numPartitions numbers with the
  #                              property that the sum of the numbers is n and any two numbers in
  #                              partitionSizeVec differ by at most 1

  #  if the number of partitions is greater than n, set it to n
  numPartitions = min(numPartitions, n)

  #  compute the size of the partitions, ignoring the remainder
  basePartitionSize = floor(n / numPartitions)

  #  compute the number of partition elements that will be one larger than the base partition size
  #  in order to account for the remainder
  remainder = n %% numPartitions

  #  create base partition, ignoring remainder
  partitionSizeVec = rep(basePartitionSize, numPartitions)

  #  increase the size of some elements of the partition by 1 to account for the remainder
  if(remainder > 0){
    partitionSizeVec[1:remainder] = sapply(partitionSizeVec[1:remainder], function(z) z + 1)
  } #  end if

  return(partitionSizeVec)

} #  end partition function


# Chart 1

#p_0 are 0.2, 0.8, 0.4, 0.6, 0.7
#p_0 <- c(1,2,3,4,5) # C(x,y) is a vector to store values. A List that we can iterate over.

# Matrix, values converted to characters
#naming <- c("a", "a", "a", "a", "a")
#cbind(p_0, naming)

#frequencia(geracoes) = (p_0 - p')(1-m)^geracoes

m <- 0.1

p_constant <- 0.5

p_0 <- c(0.1,0.3,0.5,0.7,0.9) # C(x,y) is a vector to store values. A List that we can iterate over.

t <- c(10,20,30,40,50)

#valores <- 1
#b <- c(b, 2)

for (geracao in t) {
	message("Inicio")
	message(t)
	for (i in p_0) {
		message("inner loop")
		message(i)
		resultado <- ( i - p_constant ) * (1 - m) ^ geracao
		valores <- c(valores, resultado)
	}
}
unlist(valores)


## Salidas de funciones

# En esta lección vamos a explorar las diferentes opciones de salida que podemos
# darle a una función, desde un valor sencillo sin ningún detalle hasta salidas
# listadas más complejas.

v <- 15:25  # Vamos a necesitar un objeto 'v' para los ejemplos.

# Salidas simples
# Si recordamos la lección anterior, los objetos definidos dentro del cuerpo de
# una función sólo existen en el instante que dura el ambiente creado durante la
# ejecución de la misma. En la medida en que nos interesa obtener una salida de
# la evaluación de una función, hay que definir qué objetos van a salir de este
# ambiente a la consola, y para ello debemos definir salidas en el cuerpo de la
# función.
# Por defecto, la salida de una función es el resultado de la última evaluación
# contenida en el cuerpo de la misma. Si tomamos como ejemplo la siguiente
# función

f <- function(v) {
  v <- v[!is.na(v)]
  p <- sum(v) / length(v)
  p
}
f(v)

# la salida va a ser el valor de 'p', en este caso el promedio de 'v'.
# El último comando no necesita ser la llamada a un objeto, puede ser una
# operación. Intentemos ver qué pasa si suprimimos la llamada a 'p', y nos que-
# damos sólo con la operación anterior pero sin asignar el resultado.

f <- function(v) {
  v <- v[!is.na(v)]
  sum(v) / length(v)
}
f(v)

# El resultado final es el mismo.
# Veamos ahora qué sucede si asignamos el objeto 'p', pero no lo llamamos al
# final del cuerpo de 'f'.

f <- function(v) {
  v <- v[!is.na(v)]
  p <- sum(v) / length(v)
}
f(v)

# En este caso no hay una salida visible a la consola. Esto no implica que no
# exista una salida, ya que si asignamos la evaluación de la función a un objeto
# en la consola, éste va a ser asignado con esta salida invisible.

a <- f(v)
a

# Una opción que podemos adoptar es interrumpir la ejecución de la función y
# definir con precisión una salida de la misma. Para ello podemos utilizar el
# comando 'return', utilizando como argumento el objeto que queremos en la
# salida.

f <- function(v) {
  v <- v[!is.na(v)]
  p <- sum(v) / length(v)
  if (p > 15) return(15)
  p
}
f(v + 20)

# En este caso, cuando el condicional 'if' es verdadero, la función devuelve el
# valor indicado en este comando, y todo lo que se encuentra posterior al mismo
# no es ejecutado. (El uso de condicionales lo veremos detalladamente en la
# unidad siguiente)

# Otro comando que se puede utilizar es 'invisible', que hace que la salida de
# nuestra función no sea impresa en la consola.

f <- function(v) {
  v <- v[!is.na(v)]
  p <- sum(v) / length(v)
  invisible(p)
}
f(v)

# Esto produce el mismo resultado que la situación en la que el resultado sólo
# era visible si asignábamos la evaluación de la función a un nuevo objeto.

a <- f(v)
a

## Salidas más elaboradas

# A veces las salidas que queremos no se limitan a un vector o matriz, sino que
# necesitamos obtener más de un resultado de nuestra función. La solución más
# sencilla y frecuente es usar listas.

f <- function(v) {
  v <- v[!is.na(v)]
  p <- sum(v) / length(v)
  m <- matrix(rnorm(9, mean = p), 3, 3)
  list(prom = p, matriz = m)
}
f(v)

# Si recordamos de unidades anteriores, en funciones como 'lm', 'summary', etc.,
# se utiliza exactamente este método.

# A modo de cierre y resumen de la presente lección, nos quedan 3 puntos:
# - Definir las salidas es necesario ya que los objetos del ambiente de
#   ejecución de una función no son accesibles desde los ambientes parentales
#   (i.e.: el área de trabajo).
# - En general la salida de una función es la última evaluación del cuerpo de
#   instrucciones, pero esto cambia al usar 'return'.
# - El uso de listas (generalmente nombradas) suele ser una solución útil para
#   obtener salidas elaboradas cuando no nos alcanza con un objeto sencillo.


#' Mean difference test (t-test) for local random approach
#'
#' @param basemod baseline formula. `outcome ~ running variable`.
#' @param data data.frame which you want to use.
#' @param bootse numeric.
#'   Generate N averages of bootstrap samples and
#'   use the standard deviation as the standard error of the average.
#'   If missing, standard error of mean is calculated by
#'   sqrt(v / e) where v is unbiased variance of outcome,
#'   and e is effective sample size: e = sum(w) ^ 2 / sum(w ^ 2).
#'   If w is missing, we set w = 1, and obtain e = 1 / n.
#'   standard error of mean difference is obtained by
#'   sqrt((v1 / e1) + (v0 / e0))
#' @param bootp numeric.
#'   Perform a permutation test with N re-randomizations.
#'   The p-value is obtained at a rate
#'   where the absolute value of the mean difference
#'   due to rerandomization is greater than
#'   the absolute value of the observed mean difference.
#'   If missing, standard t-test is performed.
#'
#' @importFrom rlang f_lhs
#' @importFrom rlang eval_tidy
#' @importFrom stats var
#' @importFrom stats pt
#' @examples
#' \dontrun{
#' running <- sample(1:100, size = 1000, replace = TRUE)
#' cov1 <- rnorm(1000, sd = 2); cov2 <- rnorm(1000, mean = -1)
#' y0 <- running + cov1 + cov2 + rnorm(1000, sd = 10)
#' y1 <- 2 + 1.5 * running + cov1 + cov2 + rnorm(1000, sd = 10)
#' y <- ifelse(running <= 50, y1, y0)
#' bin <- ifelse(y > mean(y), 1, 0)
#' w <- sample(c(1, 0.5), size = 1000, replace = TRUE)
#' raw <- data.frame(y, bin, running, cov1, cov2, w)
#'
#' set_optDiscRD(discRD.cutoff = 50, discRD.assign = "smaller")
#' useit <- clean_rd_data(y ~ running, data = raw)
#' str(local_random_test_int(y ~ running, useit$data))
#' str(local_random_test_int(y ~ running, useit$data, bootse = 100))
#' str(local_random_test_int(y ~ running, useit$data, bootp = 100))
#' }
#'
local_random_test_int <- function(basemod,
                                  data,
                                  bootse,
                                  bootp) {
  # create weights if null
  if (is.null(data$"(weights)")) data$"(weights)" <- 1

  # treated and control data
  d1 <- data$d == 1
  n1 <- sum(d1)
  n0 <- sum(!d1)

  yvar <- rlang::f_lhs(basemod)
  y1 <- rlang::eval_tidy(yvar, data[d1, ])
  y0 <- rlang::eval_tidy(yvar, data[!d1, ])

  w1 <- data[d1, "(weights)"]
  w0 <- data[!d1, "(weights)"]

  # average and mean difference
  ymu1 <- mean(y1 * w1) / mean(w1)
  ymu0 <- mean(y0 * w0) / mean(w0)
  diff_mu <- ymu1 - ymu0

  # create output list
  out <- list()
  out$outcome <- as.character(yvar)
  out$observe$treat$N <- n1
  out$observe$treat$mean <- ymu1
  out$observe$control$N <- n0
  out$observe$control$mean <- ymu0
  out$local.ate$estimate <- diff_mu

  # standard errors
  if (missing(bootse)) {
    effective_size_1 <- sum(w1)^2 / sum(w1^2)
    effective_size_0 <- sum(w0)^2 / sum(w0^2)

    yse1 <- var(y1) / effective_size_1
    yse0 <- var(y0) / effective_size_0
    mean_se <- sqrt(yse1 + yse0)
  } else {
    yse1 <- bootstrap(y1, w1, bootse)$boot$se
    yse0 <- bootstrap(y0, w0, bootse)$boot$se
    mean_se <- sqrt(yse1 + yse0)
  }

  out$observe$treat$se <- yse1
  out$observe$control$se <- yse0
  out$local.ate$se <- mean_se

  # two-sided test or permutation test
  if (missing(bootp)) {
    dfval <- n1 + n0 - 2
    tval <- abs(diff_mu) / mean_se
    pval <- 2 * pt(tval, df = dfval, lower.tail = FALSE)

    out$local.ate$df <- dfval
    out$local.ate$t <- tval
    out$local.ate$p.value <- pval
    out$local.ate$method <- "Two-sided t-test"
  } else {
    y <- rlang::eval_tidy(yvar, data)
    d <- data$d
    w <- data$"(weights)"

    perm <- permutation(y, d, w, bootp)

    out$local.ate$p.value <- perm$ate$p.value
    out$local.ate$method <- perm$ate$method
  }

  out
}

#'
#' Perform Local Randomization Approach
#'
#' @description An analysis of the difference between
#'   the means of the two groups is performed
#'   under the assumption that
#'   the treatment assignments are random near the cutoff (local random).
#'   Statistical inference has a permutation test for small sample sizes
#'   in addition to the standard t-test.
#'
#' @param basemod baseline formula. `outcome ~ running variable`.
#' @param data data.frame which you want to use.
#' @param weights weight variable.
#' @param submod numeric vector.
#'   Which baseline model you want to use.
#' @param subset subset condition.
#' @param bw numeric vector of bandwidth.
#'   If specified, use data
#'   whose running variables are within this range will be used.
#'   If missing, use data from treatment and control groups
#'   where the running variable is closest to the cutoff
#' @param global logical (default is FALSE).
#'   Whether to use all observations.
#' @param bootse numeric.
#'   Generate N averages of bootstrap samples and
#'   use the standard deviation as the standard error of the average.
#'   If missing, standard error of mean is calculated by
#'   sqrt(v / e) where v is unbiased variance of outcome,
#'   and e is effective sample size: e = sum(w) ^ 2 / sum(w ^ 2).
#'   If w is missing, we set w = 1, and obtain e = 1 / n.
#'   standard error of mean difference is obtained by
#'   sqrt((v1 / e1) + (v0 / e0))
#' @param bootp numeric.
#'   Perform a permutation test with N re-randomization.
#'   The p-value is obtained at a rate
#'   where the absolute value of the mean difference
#'   due to re-randomization is greater than
#'   the absolute value of the observed mean difference.
#'   If missing, standard t-test is performed.
#' @param cutoff numeric of cutoff points
#'   If missing, try to find `getOption("discRD.cutoff")`.
#' @param assign assignment rule of treatment.
#'   If "greater",
#'   treated whose running variable is greater than or equal to cutoff.
#'   If "smaller",
#'   treated whose running variable is less than or equal to cutoff.
#'   If missing, try to find `getOption("discRD.assign")`.
#'
#' @export
#' @examples
#' running <- sample(1:100, size = 1000, replace = TRUE)
#' cov1 <- rnorm(1000, sd = 2); cov2 <- rnorm(1000, mean = -1)
#' y0 <- running + cov1 + cov2 + rnorm(1000, sd = 10)
#' y1 <- 2 + 1.5 * running + cov1 + cov2 + rnorm(1000, sd = 10)
#' y <- ifelse(running <= 50, y1, y0)
#' bin <- ifelse(y > mean(y), 1, 0)
#' w <- sample(c(1, 0.5), size = 1000, replace = TRUE)
#' raw <- data.frame(y, bin, running, cov1, cov2, w)
#'
#' set_optDiscRD(
#'   y + bin ~ running,
#'   discRD.cutoff = 50,
#'   discRD.assign = "smaller"
#' )
#'
#' est1 <- local_random_test(data = raw, weights = w, global = TRUE)
#' str(est1)
#' est2 <- local_random_test(data = raw, bootp = 1000, submod = 1)
#' str(est2)
#'
local_random_test <- function(basemod,
                              data,
                              weights,
                              submod,
                              subset,
                              bw,
                              global = FALSE,
                              bootse,
                              bootp,
                              cutoff,
                              assign) {
  # check basemod
  if (missing(basemod)) basemod <- getOption("discRD.basemod")
  if (!is.list(basemod)) basemod <- list(basemod)
  if (length(basemod) == 0) stop("Baseline model not found")
  if (missing(submod)) submod <- seq_len(length(basemod))
  usemod <- basemod[submod]

  # check arguments for cleaning data
  dtarg <- rlang::enquos(
    weights = weights,
    subset = subset
  )
  dtarg <- Filter(Negate(rlang::quo_is_missing), dtarg)
  dtarg$data <- data
  if (!missing(cutoff)) dtarg$cutoff <- cutoff
  if (!missing(assign)) dtarg$assign <- assign
  if (!missing(global)) dtarg$global <- global
  if (!missing(bw)) dtarg$bw <- bw

  # check arguments for test
  estarg <- list()
  if (!missing(bootse)) estarg$bootse <- bootse
  if (!missing(bootp)) estarg$bootp <- bootp

  # run test
  est <- lapply(usemod, function(m) {
    # cleaning data
    dtarg$basemod <- m
    clean <- do.call("clean_rd_data", dtarg)

    # temporal output
    temp <- list()
    temp$RD.info <- clean$RD.info
    temp$bandwidth <- clean$bw.subset

    # run t-test / permutation test
    estarg$basemod <- m
    estarg$data <- clean$data
    temp$estimate <- do.call("local_random_test_int", estarg)

    # output
    class(temp) <- "local_random"
    temp
  })

  # final output
  class(est) <- append("list_local_random", class(est))
  est
}