# Copyright (C) 1997-1999  Adrian Trapletti
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Library General Public License for more details.
#
# You should have received a copy of the GNU Library General Public
# License along with this library; if not, write to the Free
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

#
# Descriptive time series analysis in the time domain
#


amif <- function (x, lag.max = NULL, maxbit = 20, confidence = 0.2, ci = 0.95, nsurr = 20,
                  fft = FALSE, amplitude = FALSE, normalized = TRUE, trace = FALSE,
                  plot = TRUE, ...)
{
  if (NCOL(x) > 1) stop ("x is not a vector or univariate time series")
  if (lag.max < 1) stop ("number of lags is not positive")
  if ((maxbit < 1) | (maxbit > 25)) stop ("maxbit out of range")
  if ((confidence < 0.01) | (confidence > 0.99)) stop ("confidence out of range")
  if (nsurr < 1) stop ("nsurr is not positive")
  if (ci >= 1) stop ("ci out of range")
  series <- deparse (substitute(x))
  x <- as.ts(x)
  x.freq <- frequency(x)
  x <- as.matrix(x)
  if (any(is.na(x))) stop ("NAs in x")
  sampleT <- nrow(x)
  if (is.null(lag.max))
    lag.max <- floor (10*(log10(sampleT)-log10(1)))
  lag.max <- min (lag.max, sampleT-1)
  lag <- matrix (1, 1, 1)
  lag[lower.tri(lag)] <- -1
  inf <- double (lag.max+1)
  cor <- array(.C ("R_amif", as.vector(x,mode="double"), as.integer(sampleT), inf=as.vector(inf),
                   as.integer(lag.max), as.integer(maxbit), as.double(confidence),
                   as.integer(normalized), as.integer(trace), PACKAGE="tseries")$inf,
               c(lag.max + 1, 1, 1))
  if (ci > 0)
  {
    surrsam <- surrogate (x, ns=nsurr, fft=fft, amplitude=amplitude)
    surrwb <- matrix (0, nrow = nsurr, ncol = lag.max+1)
    for (i in 1:nsurr)
      surrwb[i,] <- .C ("R_amif", as.vector(surrsam[,i],mode="double"), as.integer(sampleT),
                        inf=as.vector(inf), as.integer(lag.max), as.integer(maxbit),
                        as.double(confidence), as.integer(normalized),
                        as.integer(trace), PACKAGE="tseries")$inf
    wb <- apply (surrwb, 2, quantile, ci)
  }
  else
    wb <- NULL
  lag <- outer(0:lag.max, lag/x.freq)
  amif <- structure(.Data = list(acf = cor, type = "covariance", n.used = sampleT, lag = lag,
                      series = series, snames = colnames(x), clim = wb, normalized = normalized),
                    class = c("amif","acf"))
  if (plot)
  {
    plot.amif (amif, ...)
    return (invisible(amif))
  }
  else return (amif)  
}

plot.amif <- function (obj, ci.col = "blue", ...)
{
  if (!inherits(obj, "amif")) stop ("method is only for amif objects")
  plot.acf (x = obj, ylab = "AMIF", ...)
  if (!is.null(obj$clim))
    lines(obj$lag[, 1, 1], obj$clim, col = ci.col, lty = 2)
}
# Copyright (C) 1997-1999  Adrian Trapletti
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Library General Public License for more details.
#
# You should have received a copy of the GNU Library General Public
# License along with this library; if not, write to the Free
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

#
# Financial time series analysis
#


portfolio.optim <- function (obj, ...) { UseMethod ("portfolio.optim") }

portfolio.optim.ts <- function (x, ...)
{
  if (!is.ts(x)) stop ("method is only for time series")
  if (NCOL(x) == 1) stop ("x is not a multivariate time series")
  res <- portfolio.optim.default (as.matrix(x), ...)
  res$px <- ts(res$px,start=start(x),frequency=frequency(x))
  return (res)
}

portfolio.optim.default <- function (x, pm = mean(x), riskless = FALSE, shorts = FALSE, rf = 0.0)
{
  if (!require (quadprog, quietly=TRUE))
    stop ("Package quadprog is needed. Stopping")
  if (NCOL(x) == 1) stop ("x is not a matrix")
  if (any(is.na(x))) stop ("NAs in x")
  k <- dim(x)[2]
  Dmat <- cov(x)
  dvec <- rep(0,k)
  if (riskless)
  {
    a1 <- apply(x,2,mean)-rf
    if (shorts)
    {
      a2 <- NULL
      b2 <- NULL
    }
    else
    {
      a2 <- matrix(0,k,k)
      diag(a2) <- 1
      b2 <- rep(0,k)
    }
    Amat <- t(rbind(a1,a2))
    b0 <- c(pm-rf,b2)
    res <- solve.QP(Dmat,dvec,Amat,bvec=b0,meq=1)
  }
  else
  {
    a1 <- rep(1,k)
    a2 <- apply(x,2,mean)
    if (shorts)
    {
      a3 <- NULL
      b3 <- NULL
    }
    else
    {
      a3 <- matrix(0,k,k)
      diag(a3) <- 1
      b3 <- rep(0,k)
    }  
    Amat <- t(rbind(a1,a2,a3))
    b0 <- c(1,pm,b3)
    res <- solve.QP(Dmat,dvec,Amat,bvec=b0,meq=2)
  }
  y <- t(res$solution%*%t(x))
  ans <- list (pw=res$solution, px=y, pm=mean(y), ps=sd(y))
  return (ans)
}

get.hist.quote <- function (instrument = "^gdax", start, end,
                            quote = c("Open", "High", "Low", "Close"), provider = "yahoo",
                            method = c("auto", "wget", "lynx"))
{
  if (!require (chron, quietly=TRUE))
    stop ("Package chron is needed. Stopping")
  quote <- match.arg(quote)
  provider <- match.arg(provider)
  method <- match.arg(method)
  mm <- c("Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")
  if (missing(start)) start <- "1 2 1991"
  if (missing(end)) end <- paste (pmatch(strsplit(date(), " ")[[1]][2],mm),
                                  as.numeric(strsplit(date(), " ")[[1]][3])-1,
                                  strsplit(date(), " ")[[1]][5])
  start <- c(as.numeric(strsplit(start, " ")[[1]][1]),
             as.numeric(strsplit(start, " ")[[1]][2]),
             as.numeric(strsplit(start, " ")[[1]][3]))
  end <- c(as.numeric(strsplit(end, " ")[[1]][1]),
           as.numeric(strsplit(end, " ")[[1]][2]),
           as.numeric(strsplit(end, " ")[[1]][3]))
  if (provider == "yahoo")
  {
    url <- paste ("http://chart.yahoo.com/table.csv?s=", instrument, sep="")
    url <- paste (url, "&a=", start[1], "&b=", start[2], "&c=", start[3], sep="")
    url <- paste (url, "&d=", end[1], "&e=", end[2], "&f=", end[3], sep="")
    url <- paste (url, "&g=d&q=q&y=0&z=", instrument, "&x=.csv", sep="")
    destfile <- tempfile ()
    status <- download.file (url, destfile, method = method)
    if (status != 0) 
    {
      unlink (destfile)
      stop (paste("download error, status", status))
    }
    status <- scan (destfile, "", n=1, sep="\n", quiet=TRUE)
    if (substring(status,1,2) == "No")
    {
      unlink (destfile)
      stop (paste("No data available for", instrument))
    }
    x <- read.table (destfile, header=T, sep=",")
    unlink (destfile)
    nser <- pmatch (quote, c("Open", "High", "Low", "Close")) + 1
    n <- nrow(x)
    ser <- as.vector(x[n:1,nser])
    dat <- dates(gsub("-", " ", as.character(x[n:1,1])), format="day mon y")
    seqdat <- seq.dates (as.numeric(dat)[1],as.numeric(dat)[n])
    idx <- match(as.numeric(dat),as.numeric(seqdat))
    newser <- rep(NA,length(seqdat))
    newser[idx] <- ser
    if (as.numeric(dat)[1] != dates(paste(start[1],start[2],start[3]), format = "m d y"))
      cat (paste("time series starts ", dat[1], "\n", sep=""))
    if (as.numeric(dat)[n] != dates(paste(end[1],end[2],end[3]), format = "m d y"))
      cat (paste("time series ends   ", dat[n], "\n", sep=""))
    return (ts(newser, start = as.numeric(dat)[1], end = as.numeric(dat)[n]))
  }
  else stop ("provider not implemented")
}

# Copyright (C) 1997-1999  Adrian Trapletti
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Library General Public License for more details.
#
# You should have received a copy of the GNU Library General Public
# License along with this library; if not, write to the Free
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

#
# GARCH class
#


garch <- function (x, order = c(1, 1), coef = NULL, itmax = 200, eps = NULL,
                   grad = c("analytical","numerical"), series = NULL, trace = TRUE, ...)
{
  if (NCOL(x) > 1) stop ("x is not a vector or univariate time series")
  if (!is.vector(order)) stop ("order is not a vector")
  grad <- match.arg (grad)
  switch (grad,
          analytical = (agrad <- TRUE),
          numerical = (agrad <- FALSE))
  if (is.null(series)) series <- deparse(substitute(x))
  ists <- is.ts(x)
  x <- as.ts(x)
  xfreq <- frequency(x)
  if (any(is.na(x))) stop ("NAs in x")
  if (ists) xtsp <- tsp(x)
  x <- as.matrix(x)
  n <- nrow(x)
  e <- double(n)
  ncoef <- order[1]+order[2]+1
  hess <- matrix (0.0, ncoef, ncoef)
  small <- 0.05
  if (is.null(coef)) coef <- c(var(x)*(1.0-small*(ncoef-1)),rep(small,ncoef-1))
  if (!is.vector(coef)) stop ("coef is not a vector")
  if (ncoef != length(coef)) stop ("incorrect length of coef")
  if (is.null(eps)) eps <- Machine()$double.eps
  nlikeli <- 1.0e+10
  fit <- .C ("fit_garch", as.vector(x,mode="double"), as.integer(n),
             coef=as.vector(coef,mode="double"), as.integer(order[1]),
             as.integer(order[2]), as.integer(itmax), as.double(eps),
             nlikeli=as.double(nlikeli), as.integer(agrad), as.integer(trace),
             PACKAGE="tseries")
  pred <- .C ("pred_garch", as.vector(x,mode="double"), e=as.vector(e,mode="double"),
              as.integer(n), as.vector(fit$coef,mode="double"), as.integer(order[1]),
              as.integer(order[2]), PACKAGE="tseries")
  com.hess <- .C ("ophess_garch", as.vector(x,mode="double"), as.integer(n),
                  as.vector(fit$coef,mode="double"), hess=as.matrix(hess),
                  as.integer(order[1]), as.integer(order[2]), PACKAGE="tseries")
  rank <- qr(com.hess$hess,...)$rank
  if (rank != ncoef)
  {
    se.garch <- rep (NA, ncoef)
    cat ("Warning: singular information\n")
  }
  else
    se.garch <- sqrt(diag(solve(com.hess$hess)))
  sigt <- sqrt(pred$e)
  sigt[1:max(order[1],order[2])] <- rep (NA, max(order[1],order[2]))
  f <- cbind(sigt,-sigt)
  e <- as.vector(x)/sigt  
  if (ists)
  {
    attr(e, "tsp") <-  attr(f, "tsp") <- xtsp
    attr(e, "class") <- attr(f, "class") <- "ts"
  }
  names(order) <- c("p","q")
  coef <- fit$coef
  nam.coef <- "a0"
  if (order[2] > 0) nam.coef <- c(nam.coef, paste("a", seq(order[2]), sep = ""))
  if (order[1] > 0) nam.coef <- c(nam.coef, paste("b", seq(order[1]), sep = ""))
  names(coef) <- nam.coef
  names(se.garch) <- nam.coef
  garch <- list (order = order, coef = coef, n.likeli = fit$nlikeli,
                 n.used = n, residuals = e, fitted.values = f, series = series,
                 frequency = xfreq, call = match.call(), asy.se.coef = se.garch)
  class(garch) <- "garch"
  return (garch)
}

coef.garch <- function (obj)
{
  if (!inherits(obj, "garch")) stop ("method is only for garch objects")
  return (obj$coef)
}

residuals.garch <- function (obj)
{
  if (!inherits(obj, "garch")) stop ("method is only for garch objects")
  return (obj$residuals)
}

fitted.garch <- function (obj)
{
  if (!inherits(obj, "garch")) stop ("method is only for garch objects")
  return (obj$fitted.values)
}

print.garch <- function (obj, digits = max(3,.Options$digits-3))
{
  if (!inherits(obj, "garch")) stop ("method is only for garch objects")
  cat ("\nCall:\n", deparse(obj$call), "\n\n", sep = "")
  cat ("Coefficient(s):\n")
  print.default (format(coef(obj), digits = digits), print.gap = 2, quote = FALSE)
  cat ("\n")
  invisible (obj)
}

summary.garch <- function (obj)
{
  if (!inherits(obj, "garch")) stop ("method is only for garch objects")
  ans <- NULL
  ans$residuals <- na.remove(obj$residuals)
  tval <- obj$coef/obj$asy.se.coef
  ans$coef <- cbind (obj$coef, obj$asy.se.coef, tval, 2*(1-pnorm(abs(tval))))
  dimnames(ans$coef) <- list(names(obj$coef), c(" Estimate"," Std. Error"," t value","Pr(>|t|)"))
  ans$call <- obj$call
  ans$order <- obj$order
  Residuals <- ans$residuals
  ans$j.b.test <- jarque.bera.test(Residuals)
  Squared.Residuals <- ans$residuals^2
  ans$l.b.test <- Box.test (Squared.Residuals, type = "Ljung-Box")
  class(ans) <- "summary.garch"
  return (ans)
}

plot.garch <- function (obj, ask = interactive())
{
  if (!inherits(obj, "garch")) stop ("method is only for garch objects")
  op <- par()
  par (ask = ask, mfrow=c(2,1))
  x <- eval (parse(text=obj$series))
  if (any(is.na(x))) stop ("NAs in x")
  plot(x, main = obj$series, ylab = "Series")
  plot(obj$residuals, main = "Residuals", ylab = "Series")
  hist (x, main = paste("Histogram of",obj$series), xlab = "Series")
  hist (obj$residuals, main = "Histogram of Residuals", xlab = "Series")
  qqnorm (x, main = paste("Q-Q Plot of",obj$series), xlab = "Normal Quantiles")
  qqnorm (obj$residuals, main = "Q-Q Plot of Residuals", xlab = "Normal Quantiles")
  acf (x^2, main = paste("ACF of Squared",obj$series))
  acf (obj$residuals^2, main = "ACF of Squared Residuals", na.action=na.remove)
  par (ask = op$ask, mfrow = op$mfrow)
  invisible (obj)
}

print.summary.garch <- function (obj, digits = max(3,.Options$digits-3),
                                 signif.stars = .Options$show.signif.stars, ...)
{
  if (!inherits(obj, "summary.garch")) stop ("method is only for summary.garch objects")
  cat ("\nCall:\n", deparse(obj$call), "\n", sep = "")
  cat ("\nModel:\nGARCH(", obj$order[1], ",", obj$order[2], ")", "\n", sep = "")
  cat ("\nResiduals:\n")
  rq <- structure(quantile(obj$residuals), names = c("Min","1Q","Median","3Q","Max"))
  print (rq, digits=digits, ...)
  cat ("\nCoefficient(s):\n")
  print.coefmat (obj$coef, digits = digits, signif.stars = signif.stars, ...)
  cat ("\nDiagnostic Tests:")
  print (obj$j.b.test)
  print (obj$l.b.test)
  invisible (obj)
}

predict.garch <- function (obj, newdata, genuine = FALSE)
{
  if (!inherits(obj, "garch")) stop ("method is only for garch objects")
  if (missing(newdata))
  {
    newdata <- eval (parse(text=obj$series))
    if (any(is.na(newdata))) stop ("NAs in newdata")
  }
  if (NCOL(newdata) > 1) stop ("newdata is not a vector or univariate time series")
  ists <- is.ts(newdata)
  if (ists) newdata.tsp <- tsp(newdata)
  newdata <- as.matrix(newdata)
  n <- nrow(newdata)
  if (genuine) h <- double(n+1)
  else h <- double(n)
  pred <- .C ("pred_garch", as.vector(newdata,mode="double"), h=as.vector(h,mode="double"),
              as.integer(n), as.vector(obj$coef,mode="double"), as.integer(obj$order[1]),
              as.integer(obj$order[2]), PACKAGE="tseries")
  pred$h <- sqrt(pred$h)
  pred$h[1:max(obj$order[1],obj$order[2])] <- rep (NA, max(obj$order[1],obj$order[2]))
  pred$h <- cbind(pred$h,-pred$h)
  if (ists)
  {
    if (genuine) attr(pred$h, "tsp") <- c(newdata.tsp[1],
                                          newdata.tsp[2]+1/newdata.tsp[3],
                                          newdata.tsp[3])
    else attr(pred$h, "tsp") <- newdata.tsp
    attr(pred$h, "class") <- "ts"
  }
  return (pred$h)
}

# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Library General Public License for more details.
#
# You should have received a copy of the GNU Library General Public
# License along with this library; if not, write to the Free
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

#
# Mostly time series tests
#


runs.test <- function (x)
{
  if (NCOL(x) > 1) stop ("x is not a vector or univariate time series")
  if (any(is.na(x))) stop ("NAs in x")
  DNAME <- deparse (substitute(x))
  if (any (x == 0.0))
  {
    cat ("Removed", length (x[x==0.0]), "zero(es)\n")
    x <- x[x!=0.0]
  }
  d <- diff (sign(x))
  f <- factor (d)
  sp <- split (d, f)
  resS <- sapply (sp, length)
  resL <- lapply (sp, length)
  n <- length (x)
  sum2 <- sum (resS^2)
  sum3 <- sum (resS^3)
  m <- (n*(n+1)-sum2)/n
  s <- (sum2*(sum2+n*(n+1))-2*n*sum3-n^3)/(n^2*(n-1))
  R <- 1
  if (!is.null(resL$"-2"))
    R <- R+resL$"-2"
  if (!is.null(resL$"2"))
    R <- R+resL$"2"
  STATISTIC <- ((R+0.5)-m)/s
  METHOD <- "Runs Test"
  PVAL <- 2 * pnorm (-abs(STATISTIC))
  names(STATISTIC) <- "Standard Normal"
  structure(list(statistic = STATISTIC,
		 p.value = PVAL,
		 method = METHOD,
		 data.name = DNAME),
	    class = "htest")
}

bds.test <- function (x, m = 2, eps = seq(0.5*sd(x),2*sd(x),length=4), trace = FALSE)
{
  if (NCOL(x) > 1) stop ("x is not a vector or univariate time series")
  if (any(is.na(x))) stop ("NAs in x")
  if (m < 2) stop ("m is less than 2")
  if (any(eps<=0)) stop ("invalid eps")
  DNAME <- deparse(substitute(x))
  n <- length(x)
  k <- length(eps)
  cc <- double(m+1)
  cstan <- double(m+1)
  STATISTIC <- matrix(0,m-1,k)
  for (i in (1:k))
  {
    res <- .C("bdstest_main", as.integer(n), as.integer(m), as.vector(x,mode="double"),
              as.vector(cc), cstan=as.vector(cstan), as.double(eps[i]), as.integer(trace),
              PACKAGE="tseries")
    STATISTIC[,i] <- res$cstan[2:m+1]
  }
  colnames(STATISTIC) <- eps
  rownames(STATISTIC) <- 2:m
  PVAL <- 2 * pnorm (-abs(STATISTIC))
  colnames(PVAL) <- eps
  rownames(PVAL) <- 2:m
  METHOD <- "BDS Test"
  PARAMETER <- list (m = 2:m, eps = eps)
  structure(list(statistic = STATISTIC, p.value = PVAL, method = METHOD,
                 data.name = DNAME, parameter = PARAMETER), 
            class = "bdstest")
}

print.bdstest <- function (obj, digits = 4)
{
  if (!inherits(obj, "bdstest")) stop ("method is only for bdstest objects")
  cat("\n\t", obj$method, "\n\n")
  cat("data: ", obj$data.name, "\n\n")
  if (!is.null(obj$parameter))
  {
    cat("Embedding dimension = ", format(round(obj$parameter$m, digits)), sep = " ", "\n\n")
    cat("Epsilon for close points = ", format(round(obj$parameter$eps, digits)), sep = " ", "\n\n")
  }
  if (!is.null(obj$statistic))
  {
    colnames(obj$statistic) <- round (as.numeric(colnames(obj$statistic)), digits)
    colnames(obj$statistic) <- paste("[",colnames(obj$statistic),"]")
    rownames(obj$statistic) <- round (as.numeric(rownames(obj$statistic)), digits)
    rownames(obj$statistic) <- paste("[",rownames(obj$statistic),"]")
    cat("Standard Normal = \n")
    print (round(obj$statistic, digits))
    cat("\n")
  }
  if (!is.null(obj$p.value))
  {
    colnames(obj$p.value) <- round (as.numeric(colnames(obj$p.value)), digits)
    colnames(obj$p.value) <- paste("[",colnames(obj$p.value),"]")
    rownames(obj$p.value) <- round (as.numeric(rownames(obj$p.value)), digits)
    rownames(obj$p.value) <- paste("[",rownames(obj$p.value),"]")
    cat("p-value = \n")
    print (round(obj$p.value, digits))
    cat("\n")
  }
  cat("\n")
  invisible(obj)
}

adf.test <- function (x, k = trunc((length(x)-1)^(1/3)))
{
  if (NCOL(x) > 1) stop ("x is not a vector or univariate time series")
  if (any(is.na(x))) stop ("NAs in x")
  if (k < 0) stop ("k negative")
  DNAME <- deparse(substitute(x))
  k <- k+1
  y <- diff (x)
  n <- length(y)
  z <- embed (y, k)
  yt <- z[,1]
  xt1 <- x[k:n]
  tt <- k:n
  if (k > 1)
  {
    yt1 <- z[,2:k] 
    res <- lm (yt~xt1+1+tt+yt1)
  }
  else
    res <- lm (yt~xt1+1+tt)
  res.sum <- summary (res)
  STAT <- res.sum$coefficients[2,1]/res.sum$coefficients[2,2]
  table <- cbind(c(4.38,4.15,4.04,3.99,3.98,3.96),
                 c(3.95,3.80,3.73,3.69,3.68,3.66),
                 c(3.60,3.50,3.45,3.43,3.42,3.41),
                 c(3.24,3.18,3.15,3.13,3.13,3.12),
                 c(1.14,1.19,1.22,1.23,1.24,1.25),
                 c(0.80,0.87,0.90,0.92,0.93,0.94),
                 c(0.50,0.58,0.62,0.64,0.65,0.66),
                 c(0.15,0.24,0.28,0.31,0.32,0.33))
  table <- -table
  tablen <- dim(table)[2]
  tableT <- c(25,50,100,250,500,100000)
  tablep <- c(0.01,0.025,0.05,0.10,0.90,0.95,0.975,0.99)
  tableipl <- numeric(tablen)
  for (i in (1:tablen))
    tableipl[i] <- approx (tableT,table[,i],n,rule=2)$y
  PVAL <- approx (tableipl,tablep,STAT,rule=2)$y
  PARAMETER <- k-1
  METHOD <- "Augmented Dickey-Fuller Test"
  names(STAT) <- "Dickey-Fuller"
  names(PARAMETER) <- "Lag order"
  structure(list(statistic = STAT, parameter = PARAMETER, 
                 p.value = PVAL, method = METHOD, data.name = DNAME), 
            class = "htest")
}

white.test <- function (obj, ...) { UseMethod("white.test") }

white.test.default <- function (x, y, qstar = 2, q = 10, range = 4,
                                type = c("chisq","F"), scale = TRUE)
{
  DNAME <- paste(deparse(substitute(x)), "and", deparse(substitute(y)))
  x <- as.matrix(x)
  y <- as.matrix(y)
  if (any(is.na(x))) stop ("NAs in x")
  if (any(is.na(y))) stop ("NAs in y")
  nin <- dim(x)[2]
  t <- dim(x)[1]
  if (dim(x)[1] != dim(y)[1]) 
    stop("number of rows of x and y must match")
  if (dim(x)[1] <= 0) 
    stop("no observations in x and y")
  if (dim(y)[2] > 1)
    stop ("handles only univariate outputs")
  if (!require (mva, quietly=TRUE))
    stop ("Package mva is needed. Stopping")
  type <- match.arg (type)
  if (scale)
  {
    x <- scale(x)
    y <- scale(y)
  }
  xnam <- paste ("x[,", 1:nin, "]", sep="")
  fmla <- as.formula (paste ("y~",paste(xnam,collapse= "+")))
  rr <- lm (fmla)
  u <- residuals (rr)
  ssr0 <- sum (u^2)
  max <- range/2
  gamma <- matrix(runif((nin+1)*q,-max,max),nin+1,q)
  phantom <- (1+exp(-(cbind(rep(1,t),x)%*%gamma)))^(-1)
  phantomstar <- as.matrix(prcomp(phantom,scale=TRUE)$x[,2:(qstar+1)])
  xnam2 <- paste ("phantomstar[,", 1:qstar, "]", sep="")
  xnam2 <- paste(xnam2,collapse="+")
  fmla <- as.formula (paste ("u~",paste(paste(xnam,collapse= "+"),xnam2,sep="+")))
  rr <- lm (fmla)
  v <- residuals(rr)
  ssr <- sum(v^2)
  if (type == "chisq")
  {
    STAT <- t*log(ssr0/ssr)
    PVAL <- 1-pchisq(STAT,qstar)
    PARAMETER <- qstar
    names(STAT) <- "X-squared"
    names(PARAMETER) <- "df"
  }
  else if (type == "F")
  {
    STAT <- ((ssr0-ssr)/qstar)/(ssr/(t-qstar-nin))
    PVAL <- 1-pf(STAT,qstar,t-qstar-nin)
    PARAMETER <- c(qstar,t-qstar-nin)
    names(STAT) <- "F"
    names(PARAMETER) <- c("df1","df2")
  }
  else
    stop ("invalid type")
  ARG <- c(qstar,q,range,scale)
  names(ARG) <- c("qstar","q","range","scale")
  METHOD <- "White Neural Network Test"
  structure(list(statistic = STAT, parameter = PARAMETER, p.value = PVAL, 
                 method = METHOD, data.name = DNAME, arguments = ARG), class = "htest")
}

white.test.ts <- function (x, lag = 1, qstar = 2, q = 10, range = 4,
                           type = c("chisq","F"), scale = TRUE)
{
  if (!is.ts(x)) stop ("method is only for time series")
  if (NCOL(x) > 1) stop ("x is not a vector or univariate time series")
  if (any(is.na(x))) stop ("NAs in x")
  if (lag < 1) 
    stop("minimum lag is 1")
  if (!require (mva, quietly=TRUE))
    stop ("Package mva is needed. Stopping")
  type <- match.arg (type)
  DNAME <- deparse(substitute(x))
  t <- length(x)
  if (scale) x <- scale(x)
  y <- embed (x, lag+1)
  xnam <- paste ("y[,", 2:(lag+1), "]", sep="")
  fmla <- as.formula (paste ("y[,1]~",paste(xnam,collapse= "+")))
  rr <- lm (fmla)
  u <- residuals (rr)
  ssr0 <- sum (u^2)
  max <- range/2
  gamma <- matrix(runif((lag+1)*q,-max,max),lag+1,q)
  phantom <- (1+exp(-(cbind(rep(1,t-lag),y[,2:(lag+1)])%*%gamma)))^(-1)
  phantomstar <- as.matrix(prcomp(phantom,scale=TRUE)$x[,2:(qstar+1)])
  xnam2 <- paste ("phantomstar[,", 1:qstar, "]", sep="")
  xnam2 <- paste(xnam2,collapse="+")
  fmla <- as.formula (paste ("u~",paste(paste(xnam,collapse= "+"),xnam2,sep="+")))
  rr <- lm (fmla)
  v <- residuals(rr)
  ssr <- sum(v^2)
  if (type == "chisq")
  {
    STAT <- t*log(ssr0/ssr)
    PVAL <- 1-pchisq(STAT,qstar)
    PARAMETER <- qstar
    names(STAT) <- "X-squared"
    names(PARAMETER) <- "df"
  }
  else if (type == "F")
  {
    STAT <- ((ssr0-ssr)/qstar)/(ssr/(t-lag-qstar))
    PVAL <- 1-pf(STAT,qstar,t-lag-qstar)
    PARAMETER <- c(qstar,t-lag-qstar)
    names(STAT) <- "F"
    names(PARAMETER) <- c("df1","df2")
  }
  else
    stop ("invalid type")
  ARG <- c(lag,qstar,q,range,scale)
  names(ARG) <- c("lag","qstar","q","range","scale")
  METHOD <- "White Neural Network Test"
  structure(list(statistic = STAT, parameter = PARAMETER, p.value = PVAL, 
                 method = METHOD, data.name = DNAME, arguments = ARG), class = "htest")
}

terasvirta.test <- function (obj, ...) { UseMethod("terasvirta.test") }

terasvirta.test.default <- function (x, y, type = c("chisq","F"), scale = TRUE)
{
  DNAME <- paste(deparse(substitute(x)), "and", deparse(substitute(y)))
  x <- as.matrix(x)
  y <- as.matrix(y)
  if (any(is.na(x))) stop ("NAs in x")
  if (any(is.na(y))) stop ("NAs in y")
  nin <- dim(x)[2]
  t <- dim(x)[1]
  if (dim(x)[1] != dim(y)[1]) 
    stop("number of rows of x and y must match")
  if (dim(x)[1] <= 0) 
    stop("no observations in x and y")
  if (dim(y)[2] > 1)
    stop ("handles only univariate outputs")
  type <- match.arg (type)
  if (scale)
  {
    x <- scale(x)
    y <- scale(y)
  }
  xnam <- paste ("x[,", 1:nin, "]", sep="")
  fmla <- as.formula (paste ("y~",paste(xnam,collapse= "+")))
  rr <- lm (fmla)
  u <- residuals (rr)
  ssr0 <- sum (u^2)
  xnam2 <- NULL
  m <- 0
  for (i in (1:nin))
  {
    for (j in (i:nin))
    {
      xnam2 <- c(xnam2,paste("I(x[,",i,"]*x[,",j,"])",sep=""))
      m <- m+1
    }
  }
  xnam2 <- paste(xnam2,collapse="+")
  xnam3 <- NULL
  for (i in (1:nin))
  {
    for (j in (i:nin))
    {
      for (k in (j:nin))
      {
        xnam3 <- c(xnam3,paste("I(x[,",i,"]*x[,",j,"]*x[,",k,"])",sep=""))
        m <- m+1
      }
    }
  }
  xnam3 <- paste(xnam3,collapse="+")
  fmla <- as.formula (paste ("u~",paste(paste(xnam,collapse= "+"),xnam2,xnam3,sep="+")))
  rr <- lm (fmla)
  v <- residuals(rr)
  ssr <- sum(v^2)
  if (type == "chisq")
  {
    STAT <- t*log(ssr0/ssr)
    PVAL <- 1-pchisq(STAT,m)
    PARAMETER <- m
    names(STAT) <- "X-squared"
    names(PARAMETER) <- "df"
  }
  else if (type == "F")
  {
    STAT <- ((ssr0-ssr)/m)/(ssr/(t-nin-m))
    PVAL <- 1-pf(STAT,m,t-nin-m)
    PARAMETER <- c(m,t-nin-m)
    names(STAT) <- "F"
    names(PARAMETER) <- c("df1","df2")
  }
  else
    stop ("invalid type")
  METHOD <- "Teraesvirta Neural Network Test"
  ARG <- scale
  names(ARG) <- "scale"
  structure(list(statistic = STAT, parameter = PARAMETER, p.value = PVAL, 
                 method = METHOD, data.name = DNAME, arguments = ARG), class = "htest")
}

terasvirta.test.ts <- function (x, lag = 1, type = c("chisq","F"), scale = TRUE)
{
  if (!is.ts(x)) stop ("method is only for time series")
  if (NCOL(x) > 1) stop ("x is not a vector or univariate time series")
  if (any(is.na(x))) stop ("NAs in x")
  if (lag < 1) 
    stop("minimum lag is 1")
  type <- match.arg (type)
  DNAME <- deparse(substitute(x))
  t <- length(x)
  if (scale) x <- scale(x)
  y <- embed (x, lag+1)
  xnam <- paste ("y[,", 2:(lag+1), "]", sep="")
  fmla <- as.formula (paste ("y[,1]~",paste(xnam,collapse= "+")))
  rr <- lm (fmla)
  u <- residuals (rr)
  ssr0 <- sum (u^2)
  xnam2 <- NULL
  m <- 0
  for (i in (1:lag))
  {
    for (j in (i:lag))
    {
      xnam2 <- c(xnam2,paste("I(y[,",i+1,"]*y[,",j+1,"])",sep=""))
      m <- m+1
    }
  }
  xnam2 <- paste(xnam2,collapse="+")
  xnam3 <- NULL
  for (i in (1:lag))
  {
    for (j in (i:lag))
    {
      for (k in (j:lag))
      {
        xnam3 <- c(xnam3,paste("I(y[,",i+1,"]*y[,",j+1,"]*y[,",k+1,"])",sep=""))
        m <- m+1
      }
    }
  }
  xnam3 <- paste(xnam3,collapse="+")
  fmla <- as.formula (paste ("u~",paste(paste(xnam,collapse= "+"),xnam2,xnam3,sep="+")))
  rr <- lm (fmla)
  v <- residuals(rr)
  ssr <- sum(v^2)
  if (type == "chisq")
  {
    STAT <- t*log(ssr0/ssr)
    PVAL <- 1-pchisq(STAT,m)
    PARAMETER <- m
    names(STAT) <- "X-squared"
    names(PARAMETER) <- "df"
  }
  else if (type == "F")
  {
    STAT <- ((ssr0-ssr)/m)/(ssr/(t-lag-m))
    PVAL <- 1-pf(STAT,m,t-lag-m)
    PARAMETER <- c(m,t-lag-m)
    names(STAT) <- "F"
    names(PARAMETER) <- c("df1","df2")
  }
  else
    stop ("invalid type")
  METHOD <- "Teraesvirta Neural Network Test"
  ARG <- c(lag,scale)
  names(ARG) <- c("lag","scale")
  structure(list(statistic = STAT, parameter = PARAMETER, p.value = PVAL, 
                 method = METHOD, data.name = DNAME, arguments = ARG), class = "htest")
}

jarque.bera.test <- function (x)
{
  if (NCOL(x) > 1) stop ("x is not a vector or univariate time series")
  if (any(is.na(x))) stop ("NAs in x")
  DNAME <- deparse (substitute(x))
  n <- length (x)
  m1 <- sum(x)/n
  m2 <- sum((x-m1)^2)/n
  m3 <- sum((x-m1)^3)/n
  m4 <- sum((x-m1)^4)/n
  b1 <- (m3/m2^(3/2))^2
  b2 <- (m4/m2^2)
  STATISTIC <- n*b1/6+n*(b2-3)^2/24
  names(STATISTIC) <- "X-squared"
  PARAMETER <- 2
  names(PARAMETER) <- "df"
  PVAL <- 1-pchisq(STATISTIC,df = 2)
  METHOD <- "Jarque Bera Test"
  structure(list(statistic = STATISTIC,
                 parameter = PARAMETER,
		 p.value = PVAL,
		 method = METHOD,
		 data.name = DNAME),
	    class = "htest")
}

# Copyright (C) 1997-1999  Adrian Trapletti
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Library General Public License for more details.
#
# You should have received a copy of the GNU Library General Public
# License along with this library; if not, write to the Free
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

#
# Various time series related routines
#


read.ts <- function (file, header = FALSE, sep = "", skip = 0, ...)
{
  x <- read.matrix (file, header = header, sep = sep, skip = skip)
  x <- ts (x, ...)
  return (x)
}

fftsurr <- function (x)
  # This is algorithm 1, p. 183 from "Theiler et al. (1992): Using
  # Surrogate Data to Detect Nonlinearity in Time Series, in Nonlinear
  # Modelling and Forecasting, Editors Casdagli & Eubank, Santa Fe Institute,
  # Addison Wesley". Note that Step 7. and 8. are only for t = 2,...,N.
{
  z <- fft (x);
  zz <- z*exp(1i*runif(z, max=2*pi));  
  re <- Re(zz[2:length(zz)]+zz[length(zz):2])/2
  im <- Im(zz[2:length(zz)]-zz[length(zz):2])/2
  zzz1 <- Re(zz[1]+zz[1])/2+1i*Im(zz[1]-zz[1])/2 
  zzz <- c(zzz1,re+1i*im)
  return (Re(fft(zzz, inverse=TRUE)))
}

ampsurr <- function (x)
  # This is algorithm 2, pp. 183, 184 from "Theiler et al. (1992): Using
  # Surrogate Data to Detect Nonlinearity in Time Series, in Nonlinear
  # Modelling and Forecasting, Editors Casdagli & Eubank, Santa Fe Institute,
  # Addison Wesley". 
{
  sx <- sort(x)
  rx <- rank(x)
  g <- rnorm(x)
  sg <- sort(g)
  y <- sg[rx]
  yy <- fftsurr(y)
  ryy <- rank(yy)
  return (sx[ryy])
}

surrogate <- function (x, ns = 1, fft = FALSE, amplitude = FALSE)
{
  if (NCOL(x) > 1) stop ("x is not a vector or univariate time series")
  if (any(is.na(x))) stop ("NAs in x")
  if (ns < 1) stop ("ns is not positive")
  n <- length(x)
  surrogate <- matrix (x, nrow=n, ncol=ns)
  if (fft)
  {
    if (amplitude)
      surrogate <- apply(surrogate, 2, ampsurr)
    else
      surrogate <- apply(surrogate, 2, fftsurr)
  }
  else
    surrogate <- apply(surrogate, 2, sample, replace=FALSE)
  return (surrogate)
}

quadmap <- function (xi = 0.0, a = 4.0, n = 1000)
{
  if (n < 1) stop ("n is not positive")
  if ((xi < 0) | (xi > 1)) stop ("xi is not in [0,1]")
  if ((a < 0) | (xi > 4)) stop ("a is not in [0,4]")
  x <- double(n)
  res <- .C ("R_quad_map", x=as.vector(x), as.double(xi), as.double(a), as.integer(n),
             PACKAGE="tseries")
  return (ts(res$x))
}

read.matrix <- function (file, header = FALSE, sep = "", skip = 0)
{
  row.lens <- count.fields (file, sep = sep, skip = skip)
  if (any (row.lens != row.lens[1])) 
    stop ("number of columns is not constant")
  if (header)
  {
    nrows <- length(row.lens) - 1
    ncols <- row.lens[2]
    col.names <- scan (file, what = "", sep = sep, nlines = 1, quiet = TRUE, skip = skip)
    x <- scan (file, sep = sep, skip = skip + 1, quiet = TRUE)
  }
  else
  {
    nrows <- length(row.lens)
    ncols <- row.lens[1]
    x <- scan (file, sep = sep, skip = skip, quiet = TRUE)
    col.names <- NULL
  }
  x <- as.double(x)
  if (ncols > 1)
  {
    dim(x) <- c(ncols,nrows)
    x <- t(x)
    colnames(x) <- col.names
  }
  else if (ncols == 1)
    x <- as.vector(x)
  else stop ("wrong number of columns")
  return (x)
}

na.remove <- function (obj, ...) { UseMethod ("na.remove") }

na.remove.ts <- function (x)
{
  if (!is.ts(x)) stop ("method is only for time series")
  if (any(is.na(x)))
  {
    y <- na.remove.default(x)
    ok <- seq(1,NROW(x))[-attr(y,"na.removed")]
    xfreq <- frequency(x)
    start <- tsp(x)[1]+(ok[1]-1)/xfreq
    end <- tsp(x)[1]+(ok[length(ok)]-1)/xfreq
    yfreq <- (NROW(y)-1)/(end-start)
    attr(y, "tsp") <- c(start,end,yfreq)
    attr(y, "class") <- attr(x, "class")
    return (y)
  }
  else return (x)
}

na.remove.default <- function (x)
{
  if (any(is.na(x)))
  {
    if (is.matrix(x))
    {
      nas <- apply(is.na(x),1,any)
      y <- matrix(as.vector(x)[rep(!nas,ncol(x))],ncol=ncol(x))
      dimnames(y) <- dimnames(x)
      nas <- which(nas)
    }
    else 
    {
      nas <- which (is.na(x))
      y <- x[-nas]
    }
    attr (y, "na.removed") <- nas
    return (y)
  }
  else return (x)
}


.First.lib <- function (lib, pkg)
{
  library.dynam("tseries", pkg, lib)
  provide(tseries)
  require(ts)
}
