acf <-
    function (x, lag.max = NULL,
              type = c("correlation", "covariance", "partial"),
              plot = TRUE, na.action = na.fail, demean= TRUE, ...)
{
    type <- match.arg(type)
    if(type == "partial") {
        m <- match.call()
        m[[1]] <- as.name("pacf")
        m$type <- NULL
        return(eval(m, sys.frame(sys.parent())))
    }
    series <- deparse(substitute(x))
    x <- na.action(as.ts(x))
    x.freq <- frequency(x)
    x <- as.matrix(x)
    if(any(is.na(x))) stop("NAs in x")
    sampleT <- nrow(x)
    nser <- ncol(x)
    if (is.null(lag.max))
        lag.max <- floor(10 * (log10(sampleT) - log10(nser)))
    lag.max <- min(lag.max, sampleT - 1)
    if (lag.max < 1) stop("lag.max must be at least 1")
    if(demean) x <- sweep(x, 2, apply(x, 2, mean))
    lag <- matrix(1, nser, nser)
    lag[lower.tri(lag)] <- -1
    acf <- array(NA, c(lag.max + 1, nser, nser))
    acf <- array(.C("acf",
                    as.double(x), as.integer(sampleT), as.integer(nser),
                    as.integer(lag.max), as.integer(type=="correlation"),
                    acf=double((lag.max+1) * nser * nser), PACKAGE="ts"
                    )$acf, c(lag.max + 1, nser, nser))
    lag <- outer(0:lag.max, lag/x.freq)
    acf.out <- structure(.Data = list(acf = acf, type = type,
        n.used = sampleT, lag = lag, series = series, snames = colnames(x)),
        class = "acf")
    if (plot) {
        plot.acf(acf.out, ...)
        return(invisible(acf.out))
    } else return(acf.out)
}
pacf <- function(x, lag.max, plot, na.action, ...) UseMethod("pacf")
pacf.default <- function(x, lag.max = NULL, plot = TRUE,
                         na.action = na.fail, ...)
{
    series <- deparse(substitute(x))
    if(is.matrix(x)) {
        m <- match.call()
        m[[1]] <- as.name("pacf.mts")
        return(eval(m, sys.frame(sys.parent())))
    }
    x <- na.action(as.ts(x))
    x.freq <- frequency(x)
    if(any(is.na(x))) stop("NAs in x")
    if(is.matrix(x))
        if(ncol(x) > 1) stop("univariate ts method")
        else x <- drop(x)
    sampleT <- length(x)
    if (is.null(lag.max))
        lag.max <- floor(10 * (log10(sampleT)))
    lag.max <- min(lag.max, sampleT - 1)
    if (lag.max < 1) stop("lag.max must be at least 1")
    x <- scale(x, T, F)
    acf <- drop(acf(x, lag.max = lag.max, plot=F)$acf)
    pacf <- array(.C("uni_pacf",
               as.double(acf),
               pacf = double(lag.max),
               as.integer(lag.max), PACKAGE="ts")$pacf, dim=c(lag.max,1,1))
    acf.out <- structure(.Data = list(acf = pacf, type = "partial",
                         n.used = sampleT,
                         lag = array((1:lag.max)/x.freq, dim=c(lag.max,1,1)),
                         series = series, snames = NULL),
                         class = "acf")
    if (plot) {
        plot.acf(acf.out, ...)
        return(invisible(acf.out))
    } else return(acf.out)
}
pacf.mts <- function(x, lag.max = NULL, plot = TRUE, na.action = na.fail, ...)
{
    series <- deparse(substitute(x))
    x <- na.action(as.ts(x))
    x.freq <- frequency(x)
    x <- as.matrix(x)
    if(any(is.na(x))) stop("NAs in x")
    sampleT <- nrow(x)
    nser <- ncol(x)
    if (is.null(lag.max))
        lag.max <- floor(10 * (log10(sampleT) - log10(nser)))
    lag.max <- min(lag.max, sampleT - 1)
    if (lag.max < 1) stop("lag.max must be at least 1")
    x <- sweep(x, 2, apply(x, 2, mean))
    lag <- matrix(1, nser, nser)
    lag[lower.tri(lag)] <- -1
    acf <- ar.yw(x, order.max = lag.max)$partialacf
    lag <- outer(1:lag.max, lag/x.freq)
    acf.out <- structure(.Data = list(acf = acf, type = "partial",
                         n.used = sampleT, lag = lag, series = series,
                         snames = colnames(x)),
                         class = "acf")
    if (plot) {
        plot.acf(acf.out, ...)
        return(invisible(acf.out))
    } else return(acf.out)
}
plot.acf <-
    function (x, ci = 0.95, type = "h", xlab = "Lag", ylab = NULL,
              ylim = NULL, main = NULL, ci.col="blue",
              ci.type=c("white", "ma"), ...)
{
    ci.type <- match.arg(ci.type)
    nser <- ncol(x$lag)
    if(nser > 1) {
        opar <- par(mfrow = rep(min(nser, 5), 2))
        on.exit(par(opar))
    }
    if (is.null(ylab))
        ylab <- switch(x$type, correlation = "ACF", covariance = "ACF",
            partial = "Partial ACF")
    if (is.null(snames <- x$snames)) {
        snames <- if (nser == 1)
            paste("Series ", x$series)
        else paste("Series ", 1:nser)
    }
    with.ci <- (ci > 0) && (x$type != "covariance")
    with.ci.ma <- with.ci && ci.type == "ma" && x$type == "correlation"
    for (i in 1:nser) for (j in 1:nser) {
        clim <- c(0, 0)
        if (with.ci)
            clim <- qnorm((1 + ci)/2)/sqrt(x$n.used)
        if (with.ci.ma && i == j)
            clim <- clim * sqrt(cumsum(c(1, 2*x$acf[-1, i, j]^2)))
        if (is.null(ylim)) {
            ymin <- min(c(x$acf[, i, j], -clim))
            ymax <- max(c(x$acf[, i, j], clim))
            ylim <- c(ymin, ymax)
        }
        plot(x$lag[, i, j], x$acf[, i, j], type = type, xlab = xlab,
            ylab = if(j==1) ylab else "", ylim = ylim, ...)
        abline(h = 0)
        if (with.ci && ci.type == "white")
            abline(h = c(clim, -clim), col = ci.col, lty = 2)
        if (with.ci.ma && i == j) {
            lines(x$lag[, i, j], clim, col = ci.col, lty = 2)
            lines(x$lag[, i, j], -clim, col = ci.col, lty = 2)
        }
        if (!is.null(main))
            title(main)
        else if (i == j)
            title(snames[i])
        else title(paste(snames[i], "&", snames[j]))
    }
}
ccf <- function(x, y, lag.max = NULL,
                type = c("correlation", "covariance"),
                plot = TRUE, na.action = na.fail, ...)
{
    type <- match.arg(type)
    if(is.matrix(x) || is.matrix(y))
        stop("univariate time series only")
    X <- na.action(ts.union(x, y))
    colnames(X) <- c(deparse(substitute(x)), deparse(substitute(y)))
    acf.out <- acf(X, lag.max = lag.max, plot = F, type = type)
    lag <- c(rev(acf.out$lag[-1,2,1]), 0, acf.out$lag[,1,2])
    y <- c(rev(acf.out$acf[-1,2,1]), 0, acf.out$acf[,1,2])
    acf.out$acf <- array(y, dim=c(length(y),1,1))
    acf.out$lag <- array(lag, dim=c(length(y),1,1))
    acf.out$snames <- paste(acf.out$snames, collapse = " & ")
    if (plot) {
        plot.acf(acf.out, ...)
        return(invisible(acf.out))
    } else return(acf.out)
}
## based on, especially multivariate case, code by Martyn Plummer
ar <-
    function (x, aic = TRUE, order.max = NULL,
              method=c("yule-walker","burg", "ols", "mle", "yw",),
              na.action = na.fail, series = deparse(substitute(x)), ...)
{
    res <- switch(match.arg(method),
        "yule-walker" = ar.yw(x, aic=aic, order.max=order.max,
                  na.action = na.action, series=series, ...),
	"burg" = ar.burg(x, aic=aic, order.max=order.max,
                              na.action = na.action, series=series, ...),
	"ols" = ar.ols(x, aic=aic, order.max=order.max,
                              na.action = na.action, series=series, ...),
 	"mle" = ar.mle(x, aic=aic, order.max=order.max,
                              na.action = na.action, series=series, ...),
        "yw" = ar.yw(x, aic=aic, order.max=order.max,
                  na.action = na.action, series=series, ...)
   )
    res$call <- match.call()
    res
}
ar.yw <- function(x, ...) UseMethod("ar.yw")
ar.yw.default <-
    function (x, aic = TRUE, order.max = NULL, na.action = na.fail,
              demean = TRUE, series = NULL, ...)
{
    if(is.null(series)) series <- deparse(substitute(x))
    ists <- is.ts(x)
    x <- na.action(as.ts(x))
    if(ists)  xtsp <- tsp(x)
    xfreq <- frequency(x)
    x <- as.matrix(x)
    if(any(is.na(x))) stop("NAs in x")
    nser <- ncol(x)
    if (demean) {
        xm <- apply(x, 2, mean)
        x <- sweep(x, 2, xm)
    } else xm <- rep(0, nser)
    n.used <- nrow(x)
    order.max <- if (is.null(order.max)) floor(10 * log10(n.used))
                 else round(order.max)
    if (order.max < 1) stop("order.max must be >= 1")
    xacf <- acf(x, type = "covariance", lag.max = order.max, plot = FALSE,
                demean = demean)$acf
    if(nser > 1) {
        ## multivariate case
        snames <- colnames(x)
        A <- B <- array(0, dim = c(order.max + 1, nser, nser))
        A[1, , ] <- B[1, , ] <- diag(nser)
        EA <- EB <- xacf[1, , , drop = TRUE]
        partialacf <- array(dim = c(order.max, nser, nser))
        xaic <- numeric(order.max + 1)
        solve.yw <- function(m) {
            # Solve Yule-Walker equations with Whittle's
            # generalization of the Levinson(-Durbin) algorithm
            betaA <- betaB <- 0
            for (i in 0:m) {
                betaA <- betaA + A[i + 1, , ] %*% xacf[m + 2 - i, , ]
                betaB <- betaB + B[i + 1, , ] %*% t(xacf[m + 2 - i, , ])
            }
            KA <- -t(qr.solve(t(EB), t(betaA)))
            KB <- -t(qr.solve(t(EA), t(betaB)))
            EB <<- (diag(nser) - KB %*% KA) %*% EB
            EA <<- (diag(nser) - KA %*% KB) %*% EA
            Aold <- A
            Bold <- B
            for (i in 1:(m + 1)) {
                A[i + 1, , ] <<- Aold[i + 1, , ] + KA %*% Bold[m + 2 - i, , ]
                B[i + 1, , ] <<- Bold[i + 1, , ] + KB %*% Aold[m + 2 - i, , ]
            }
        }
        cal.aic <- function() { # omits mean params, that is constant adj
            det <- abs(prod(diag(qr(EA)$qr)))
            return(n.used * log(det) + 2 * m * nser * nser)
        }
        cal.resid <- function() {
            resid <- array(0, dim = c(n.used - order, nser))
            for (i in 0:order) {
                resid <- resid + x[(order - i + 1):(n.used - i),
                                   , drop = FALSE] %*% t(ar[i + 1, , ])
            }
            return(rbind(matrix(NA, order, nser), resid))
        }
        order <- 0
        for (m in 0:order.max) {
            xaic[m + 1] <- cal.aic()
            if (!aic || xaic[m + 1] == min(xaic[1:(m + 1)])) {
                ar <- A
                order <- m
                var.pred <- EA * n.used/(n.used - nser * (m + 1))
            }
            if (m < order.max) {
                solve.yw(m)
                partialacf[m + 1, , ] <- -A[m + 2, , ]
            }
        }
        xaic <- xaic - min(xaic)
        names(xaic) <- 0:order.max
        resid <- cal.resid()
        if(order > 0 ) {
            ar <- -ar[2:(order + 1), , , drop = FALSE]
            dimnames(ar) <- list(1:order, snames, snames)
        } else ar <- array(0, dim=c(0, nser, nser),
                           dimnames=list(NULL, snames, snames))
        dimnames(var.pred) <- list(snames, snames)
        dimnames(partialacf) <- list(1:order.max, snames, snames)
        colnames(resid) <- colnames(x)
    } else {
        ## univariate case
        r <- as.double(drop(xacf))
        z <- .Fortran("eureka",
                      as.integer(order.max),
                      r, r,
                      coefs=double(order.max^2),
                      vars=double(order.max),
                      double(order.max), PACKAGE="ts")
        coefs <- matrix(z$coefs, order.max, order.max)
        partialacf <- array(diag(coefs), dim=c(order.max, 1, 1))
        var.pred <- c(r[1], z$vars)
        xaic <- n.used * log(var.pred) + 2 * (0:order.max) + 2 * demean
        xaic <- xaic - min(xaic)
        names(xaic) <- 0:order.max
        order <- if (aic) (0:order.max)[xaic == 0] else order.max
        ar <- if (order > 0) coefs[order, 1:order] else numeric(0)
        var.pred <- var.pred[order+1]
        ## Splus compatibility fix
        var.pred <- var.pred * n.used/(n.used - (order + 1))
        if(order > 0)
            resid <- c(rep(NA, order), embed(x, order+1) %*% c(1, -ar))
        else resid <- as.vector(x)
        if(ists) {
            attr(resid, "tsp") <- xtsp
            attr(resid, "class") <- "ts"
        }
    }
    res <- list(order=order, ar=ar, var.pred=var.pred, x.mean = drop(xm),
                aic = xaic, n.used=n.used, order.max=order.max,
                partialacf=partialacf, resid=resid, method = "Yule-Walker",
                series=series, frequency=xfreq, call=match.call())
    if(nser == 1 && order > 0)
        res$asy.var.coef <-
            solve(toeplitz(drop(xacf)[seq(length=order)]))*var.pred/n.used
    class(res) <- "ar"
    res
}
print.ar <- function(x, digits = max(3, getOption("digits") - 3), ...)
{
    cat("\nCall:\n", deparse(x$call), "\n\n", sep = "")
    nser <- NCOL(x$var.pred)
    if(nser > 1) {
        if(!is.null(x$x.intercept))
            res <- x[c("ar", "x.intercept", "var.pred")]
        else res <- x[c("ar", "var.pred")]
        res$ar <- aperm(res$ar, c(2,3,1))
        print(res, digits=digits)
    } else {
        if(x$order > 0) {
            cat("Coefficients:\n")
            coef <- drop(round(x$ar, digits = digits))
            names(coef) <- seq(length=x$order)
            print.default(coef, print.gap = 2)
        }
        if(!is.null(xint <- x$x.intercept) && !is.na(xint))
            cat("\nIntercept: ", format(xint, digits = digits),
                " (", format(x$asy.se.coef$x.mean, digits = digits),
                ") ", "\n", sep="")
        cat("\nOrder selected", x$order, " sigma^2 estimated as ",
            format(x$var.pred, digits = digits),"\n")
    }
    invisible(x)
}
predict.ar <- function(object, newdata, n.ahead = 1, se.fit=TRUE, ...)
{
    if(missing(newdata)) {
        newdata <- eval(parse(text=object$series))
        if (!is.null(nas <- object$call$na.action))
            newdata <- eval(call(nas, newdata))
    }
    nser <- NCOL(newdata)
    ar <- object$ar
    p <- object$order
    st <- tsp(as.ts(newdata))[2]
    dt <- deltat(newdata)
    xfreq <- frequency(newdata)
    tsp(newdata) <- NULL
    class(newdata) <- NULL
    if(NCOL(ar) != nser)
        stop("number of series in fit and newdata do not match")
    n <- NROW(newdata)
    if(nser > 1) {
        if(is.null(object$x.intercept)) xint <- rep(0, nser)
        else xint <- object$x.intercept
        x <- rbind(sweep(newdata, 2, object$x.mean),
                   matrix(rep(0, nser), n.ahead, nser, byrow=TRUE))
        if(p > 0) {
            for(i in 1:n.ahead) {
                x[n+i,] <- ar[1,,] %*% x[n+i-1,] + xint
                if(p > 1) for(j in 2:p)
                    x[n+i,] <- x[n+i,] + ar[j,,] %*% x[n+i-j,]
            }
            pred <- x[n+(1:n.ahead), ]
        } else {
            pred <- matrix(xint, n.ahead, nser, byrow=TRUE)
        }
        pred <- pred + matrix(object$x.mean, n.ahead, nser, byrow=TRUE)
        colnames(pred) <- colnames(object$var.pred)
        if(se.fit) {
            warning("se.fit not yet implemented for multivariate models")
            se <- matrix(NA, n.ahead, nser)
        }
    } else {
        if(is.null(object$x.intercept)) xint <- 0
        else xint <- object$x.intercept
        x <- c(newdata - object$x.mean, rep(0, n.ahead))
        if(p > 0) {
            for(i in 1:n.ahead) {
                x[n+i] <- sum(ar * x[n+i - (1:p)]) + xint
            }
            pred <- x[n+(1:n.ahead)]
            if(se.fit) {
                npsi <- n.ahead - 1
                psi <- .C("artoma",
                        as.integer(object$order), as.double(ar),
                        psi = double(npsi+object$order+1),
                        as.integer(npsi), PACKAGE="ts")$psi[1:npsi]
                vars <- cumsum(c(1, psi^2))
                se <- sqrt(object$var.pred*vars)[1:n.ahead]
            }
        } else {
            pred <- rep(xint, n.ahead)
            if (se.fit) se <- rep(sqrt(object$var.pred), n.ahead)
        }
        pred <- pred + rep(object$x.mean, n.ahead)
    }
    pred <- ts(pred, start = st + dt, frequency=xfreq)
    if(se.fit) se <- ts(se, start = st + dt, frequency=xfreq)
    if(se.fit) return(pred, se) else return(pred)
}
## ar.burg by B.D. Ripley based on R version by Martyn Plummer
ar.burg <- function(x, ...) UseMethod("ar.burg")
ar.burg.default <-
    function (x, aic = TRUE, order.max = NULL, na.action = na.fail,
                   demean = TRUE, series = NULL, var.method = 1, ...)
{
    if(is.null(series)) series <- deparse(substitute(x))
    if (!is.null(dim(x)))
        stop("Burg's algorithm only implemented for univariate series")
    if (ists <- is.ts(x)) xtsp <- tsp(x)
    x <- na.action(as.ts(x))
    if(any(is.na(x))) stop("NAs in x")
    if (ists)  xtsp <- tsp(x)
    xfreq <- frequency(x)
    x <- as.vector(x)
    if (demean) {
        x.mean <- mean(x)
        x <- x - x.mean
    } else x.mean <- 0
    n.used <- length(x)
    order.max <- if (is.null(order.max)) floor(10 * log10(n.used))
    else floor(order.max)
    if (order.max < 1) stop("order.max must be >= 1")
    xaic <- numeric(order.max + 1)
    z <- .C("burg",
            as.integer(n.used),
            as.double(x),
            as.integer(order.max),
            coefs=double(order.max^2),
            var1=double(1+order.max),
            var2=double(1+order.max), PACKAGE="ts"
            )
    coefs <- matrix(z$coefs, order.max, order.max)
    partialacf <- array(diag(coefs), dim = c(order.max, 1, 1))
    var.pred <- if(var.method == 1) z$var1 else z$var2
    xaic <- n.used * log(var.pred) + 2 * (0:order.max) + 2 * demean
    xaic <- xaic - min(xaic)
    names(xaic) <- 0:order.max
    order <- if (aic) (0:order.max)[xaic == 0] else order.max
    ar <- if (order > 0) coefs[order, 1:order] else numeric(0)
    var.pred <- var.pred[order+1]
    if(order > 0)
        resid <- c(rep(NA, order), embed(x, order+1) %*% c(1, -ar))
    else resid <- as.vector(x)
    if(ists) {
        attr(resid, "tsp") <- xtsp
        attr(resid, "class") <- "ts"
    }
    res <- list(order = order, ar = ar, var.pred = var.pred, x.mean = x.mean,
                aic = xaic, n.used = n.used, order.max = order.max,
                partialacf = partialacf, resid = resid,
                method = ifelse(var.method==1,"Burg","Burg2"),
                series = series, frequency = xfreq, call = match.call())
    xacf <- acf(x, type = "covariance", lag.max = order, plot=FALSE)$acf
    if(order > 0) res$asy.var.coef <- solve(toeplitz(drop(xacf)[seq(length=order)]))*var.pred/n.used
    class(res) <- "ar"
    return(res)
}
"ar.burg.mts" <-
function (x, aic = TRUE, order.max = NULL, na.action = na.fail,
    demean = TRUE, series = NULL, var.method = 1, ...)
{
    if (is.null(series))
        series <- deparse(substitute(x))
    if (ists <- is.ts(x))
        xtsp <- tsp(x)
    x <- na.action(as.ts(x))
    if (any(is.na(x)))
        stop("NAs in x")
    if (ists)
        xtsp <- tsp(x)
    xfreq <- frequency(x)
    x <- as.matrix(x)
    nser <- ncol(x)
    n.used <- nrow(x)
    if (demean) {
        x.mean <- apply(x, 2, mean)
        x <- sweep(x, 2, x.mean)
    }
    else x.mean <- rep(0, nser)
    order.max <- if (is.null(order.max))
        floor(10 * log10(n.used))
    else floor(order.max)
    xaic <- numeric(order.max + 1)
    z <- .C("multi_burg", as.integer(n.used), resid = as.double(x),
        as.integer(order.max), as.integer(nser), coefs = double((1 +
            order.max) * nser * nser), pacf = double((1 + order.max) *
            nser * nser), var = double((1 + order.max) * nser *
            nser), aic = double(1 + order.max), order = integer(1),
        as.integer(aic), as.integer(var.method))
    partialacf <- aperm(array(z$pacf, dim = c(nser, nser, order.max +
        1)), c(3, 2, 1))[-1, , , drop = FALSE]
    var.pred <- aperm(array(z$var, dim = c(nser, nser, order.max +
        1)), c(3, 2, 1))
    xaic <- z$aic - min(z$aic)
    names(xaic) <- 0:order.max
    order <- z$order
    ar <- if (order > 0)
        coefs <- -aperm(array(z$coefs, dim = c(nser, nser, order.max +
            1)), c(3, 2, 1))[2:(order + 1), , , drop = FALSE]
    else array(dim = c(0, nser, nser))
    var.pred <- var.pred[order + 1, , , drop = TRUE]
    resid <- matrix(z$resid, nrow = n.used, ncol = nser)
    if (order > 0)
        resid[1:order, ] <- NA
    if (ists) {
        attr(resid, "tsp") <- xtsp
        attr(resid, "class") <- "mts"
    }
    snames <- colnames(x)
    colnames(resid) <- snames
    dimnames(ar) <- list(seq(length=order), snames, snames)
    dimnames(var.pred) <- list(snames, snames)
    dimnames(partialacf) <- list(1:order.max, snames, snames)
    res <- list(order = order, ar = ar, var.pred = var.pred,
        x.mean = x.mean, aic = xaic, n.used = n.used, order.max = order.max,
        partialacf = partialacf, resid = resid, method = ifelse(var.method ==
            1, "Burg", "Burg2"), series = series, frequency = xfreq,
        call = match.call())
    class(res) <- "ar"
    return(res)
}
ar.mle <- function (x, aic = TRUE, order.max = NULL, na.action = na.fail,
                    demean = TRUE, series = NULL, ...)
{
    if(is.null(series)) series <- deparse(substitute(x))
    ists <- is.ts(x)
    if (!is.null(dim(x)))
        stop("MLE only implemented for univariate series")
    if(aic && !demean) stop("AIC selection not implemented for demean=FALSE")
    x <- na.action(as.ts(x))
    if(any(is.na(x))) stop("NAs in x")
    if(ists)  xtsp <- tsp(x)
    xfreq <- frequency(x)
    x <- as.vector(x)
    n.used <- length(x)
    order.max <- if (is.null(order.max)) min(12, floor(10 * log10(n.used)))
    else round(order.max)
    if (order.max < 0) stop ("order.max must be >= 0")
    if (aic) {
        coefs <- matrix(NA, order.max+1, order.max+1)
        var.pred <- numeric(order.max+1)
        xaic <- numeric(order.max+1)
        for(i in 0:order.max) {
            fit <- arima0(x, order=c(i, 0, 0), include.mean=demean)
            coefs[i+1, 1:(i+1)] <- fit$coef
            xaic[i+1] <- fit$aic
            var.pred[i+1] <- fit$sigma2
        }
        xaic <- xaic - min(xaic)
        names(xaic) <- 0:order.max
        order <- (0:order.max)[xaic == 0]
        ar <- coefs[order+1, 1:order]
        x.mean <- coefs[order+1, order+1]
        var.pred <- var.pred[order+1]
    } else {
        order <- order.max
        fit <- arima0(x, order=c(order, 0, 0), include.mean=demean)
        coefs <- fit$coef
        if(demean) {
            ar <- coefs[-length(coefs)]
            x.mean <- coefs[length(coefs)]
        } else {
            ar <- coefs
            x.mean <- 0
        }
        var.pred <- fit$sigma2
        xaic <- structure(0, names=order)
    }
    if(order > 0)
        resid <- c(rep(NA, order), embed(x - x.mean, order+1) %*% c(1, -ar))
    else resid <- as.vector(x) - x.mean
    if(ists) {
        attr(resid, "tsp") <- xtsp
        attr(resid, "class") <- "ts"
    }
    res <- list(order = order, ar = ar, var.pred = var.pred,
                x.mean = x.mean, aic = xaic,
                n.used = n.used, order.max = order.max,
                partialacf=NULL, resid=resid, method = "MLE",
                series = series, frequency = xfreq, call = match.call())
    xacf <- acf(x, type = "covariance", lag.max = order, plot=FALSE)$acf
    if(order > 0)
        res$asy.var.coef <- solve(toeplitz(drop(xacf)[seq(length=order)])) *
            var.pred/n.used
    class(res) <- "ar"
    res
}
## code by Adrian Trapletti
ar.ols <- function (x, aic = TRUE, order.max = NULL, na.action = na.fail,
                    demean = TRUE, intercept = demean, series = NULL, ...)
{
    if(is.null(series)) series <- deparse(substitute(x))
    rescale <- TRUE
    ists <- is.ts(x)
    x <- na.action(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.used <- nrow(x)
    nser <- ncol(x)
    if(rescale) {
        sc <- sqrt(drop(apply(x, 2, var)))
        x <- x/rep(sc, rep(n.used, nser))
    } else sc <- rep(1, nser)
    order.max <- if (is.null(order.max)) floor(10 * log10(n.used))
    else round(order.max)
    if (order.max < 0) stop ("order.max must be >= 0")
    if (aic) order.min <- 0
    else order.min <- order.max
    A <- vector("list", order.max - order.min + 1)
    varE <- vector("list", order.max - order.min + 1)
    seA <- vector("list", order.max - order.min + 1)
    aic <- rep(Inf, order.max - order.min + 1)
    det <- function(x) { prod(diag(qr(x)$qr))*(-1)^(ncol(x)-1) }
    ## remove means for conditioning
    if(demean) {
        xm <- apply(x, 2, mean)
        x <- sweep(x, 2, xm)
    } else xm <- rep(0, nser)
    ## Fit models of increasing order
    for (m in order.min:order.max)
    {
        y <- embed(x, m+1)
        if(intercept) {
            if (m > 0) X <- cbind(rep(1,nrow(y)), y[, (nser+1):ncol(y)])
            else X <- as.matrix(rep(1, nrow(y)))
        } else {
            if (m > 0) X <- y[, (nser+1):ncol(y)]
            else X <- matrix(0, nrow(y), 0)
        }
        Y <- t(y[, 1:nser])
        N <- ncol(Y)
        XX <- t(X)%*%X
        rank <- qr(XX)$rank
        if (rank != nrow(XX))
        {
            warning (paste("Model order", m))
            warning ("Singularities in the computation of the projection matrix")
            warning (paste("Results are only valid up to model order", m - 1))
            break
        }
        P <- if(ncol(XX) > 0) solve(XX) else XX
        A[[m - order.min + 1]] <- Y %*% X %*% P
        YH <- A[[m - order.min + 1]] %*% t(X)
        E <- (Y - YH)
        varE[[m - order.min + 1]] <- E %*% t(E)/N
        varA <- P %x% (varE[[m - order.min + 1]])
        seA[[m - order.min+1]] <- if(ncol(varA) > 0) sqrt(diag(varA))
        else numeric(0)
        aic[m - order.min+1] <-
            n.used*log(det(varE[[m-order.min+1]]))+2*nser*(nser*m+intercept)
    }
    m <- which(aic==min(aic)) + order.min - 1 # Determine best model
    ## Recalculate residuals of best model
    y <- embed(x, m+1)
    AA <- A[[m - order.min + 1]]
    if(intercept) {
        xint <- AA[, 1]
        ar <- AA[, -1]
        if (m > 0) X <- cbind(rep(1,nrow(y)), y[, (nser+1):ncol(y)])
        else X <- as.matrix(rep(1, nrow(y)))
    } else {
        if (m > 0) X <- y[, (nser+1):ncol(y)]
        else X <- matrix(0, nrow(y), 0)
        xint <- NULL
        ar <- AA
    }
    Y <- t(y[, 1:nser, drop=FALSE])
    YH <- AA %*% t(X)
    E <- drop(rbind(matrix(NA, m, nser), t(Y - YH)))
    aic <- aic - min(aic)
    names(aic) <- order.min:order.max
    dim(ar) <- c(nser, nser, m)
    ar <- aperm(ar, c(3,1,2))
    ses <- seA[[m - order.min + 1]]
    if(intercept) {
        sem <- ses[1:nser]
        ses <- ses[-(1:nser)]
    } else sem <- rep(0, nser)
    dim(ses) <- c(nser, nser, m)
    ses <- aperm(ses, c(3,1,2))
    var.pred <- varE[[m - order.min + 1]]
    if(nser > 1) {
        snames <- colnames(x)
        dimnames(ses) <- dimnames(ar) <- list(seq(length=m), snames, snames)
        dimnames(var.pred) <- list(snames, snames)
        names(sem) <- colnames(E) <- snames
    }
    if(ists) {
        attr(E, "tsp") <- xtsp
        attr(E, "class") <- "ts"
    }
    if(rescale) {
        xm <- xm * sc
        if(!is.null(xint)) xint <- xint * sc
        aa <- outer(sc, 1/sc)
        if(nser > 1 && m > 0)
            for(i in 1:m) ar[i,,] <- ar[i,,]*aa
        var.pred <- var.pred * outer(sc, sc)
        E <- E * rep(sc, rep(NROW(E), nser))
        sem <- sem*sc
        if(m > 0)
            for(i in 1:m) ses[i,,] <- ses[i,,]*aa
    }
    res <- list(order = m, ar = ar, var.pred = var.pred,
                x.mean = xm, x.intercept = xint, aic = aic,
                n.used = n.used, order.max = order.max,
                partialacf = NULL, resid = E, method = "Unconstrained LS",
                series = series, frequency = xfreq, call = match.call(),
                asy.se.coef = list(x.mean = sem, ar=drop(ses)))
    class(res) <- "ar"
    res
}
"ar.yw.mts" <-
function (x, aic = TRUE, order.max = NULL, na.action = na.fail,
    demean = TRUE, series = NULL, var.method = 1, ...)
{
    if (is.null(series))
        series <- deparse(substitute(x))
    if (ists <- is.ts(x))
        xtsp <- tsp(x)
    x <- na.action(as.ts(x))
    if (any(is.na(x)))
        stop("NAs in x")
    if (ists)
        xtsp <- tsp(x)
    xfreq <- frequency(x)
    x <- as.matrix(x)
    nser <- ncol(x)
    n.used <- nrow(x)
    if (demean) {
        x.mean <- apply(x, 2, mean)
        x <- sweep(x, 2, x.mean)
    }
    else x.mean <- rep(0, nser)
    order.max <- if (is.null(order.max))
        floor(10 * log10(n.used))
    else floor(order.max)
    if (order.max < 1)
        stop("order.max must be >= 1")
    xacf <- acf(x, type = "cov", plot = FALSE, lag.max = order.max)$acf
    z <- .C("multi_yw", aperm(xacf, c(3, 2, 1)), as.integer(n.used),
        as.integer(order.max), as.integer(nser), coefs = double((1 +
            order.max) * nser * nser), pacf = double((1 + order.max) *
            nser * nser), var = double((1 + order.max) * nser *
            nser), aic = double(1 + order.max), order = integer(1),
        as.integer(aic), as.integer(var.method))
    partialacf <- aperm(array(z$pacf, dim = c(nser, nser, order.max +
        1)), c(3, 2, 1))[-1, , , drop = FALSE]
    var.pred <- aperm(array(z$var, dim = c(nser, nser, order.max +
        1)), c(3, 2, 1))
    xaic <- z$aic - min(z$aic)
    names(xaic) <- 0:order.max
    order <- z$order
    resid <- x
    if (order > 0) {
        ar <- -aperm(array(z$coefs, dim = c(nser, nser, order.max +
            1)), c(3, 2, 1))[2:(order + 1), , , drop = FALSE]
        for (i in 1:order) resid[-(1:order), ] <- resid[-(1:order),
            ] - x[(order - i + 1):(n.used - i), ] %*% t(ar[i,
            , ])
        resid[1:order, ] <- NA
    }
    else ar <- array(dim = c(0, nser, nser))
    var.pred <- var.pred[order + 1, , , drop = TRUE] * n.used/(n.used -
        nser * (demean + order))
    if (ists) {
        attr(resid, "tsp") <- xtsp
        attr(resid, "class") <- c("mts", "ts")
    }
    snames <- colnames(x)
    colnames(resid) <- snames
    dimnames(ar) <- list(seq(length=order), snames, snames)
    dimnames(var.pred) <- list(snames, snames)
    dimnames(partialacf) <- list(1:order.max, snames, snames)
    res <- list(order = order, ar = ar, var.pred = var.pred,
        x.mean = x.mean, aic = xaic, n.used = n.used, order.max = order.max,
        partialacf = partialacf, resid = resid, method = "Yule-Walker",
        series = series, frequency = xfreq, call = match.call())
    class(res) <- "ar"
    return(res)
}
arima0 <- function(x, order=c(0,0,0),
                   seasonal=list(order=c(0,0,0), period=NA), xreg=NULL,
                   include.mean=TRUE, na.action=na.fail, delta=0.01,
                   transform.pars=2)
{
    series <- deparse(substitute(x))
    if(NCOL(x) > 1)
        stop("only implemented for univariate time series")
    x <- na.action(as.ts(x))
    dim(x) <- NULL
    n <- length(x)
    if(is.null(seasonal$period) || is.na(seasonal$period)
       || seasonal$period == 0) seasonal$period <- frequency(x)
    arma <- c(order[-2], seasonal$order[-2], seasonal$period,
              order[2], seasonal$order[2])
    if(d <- order[2]) x <- diff(x, 1, d)
    if(d <- seasonal$order[2]) x <- diff(x, seasonal$period, d)
    xtsp <- tsp(x)
    tsp(x) <- NULL
    nd <- order[2] + seasonal$order[2]
    n.used <- length(x)
    if(is.null(xreg)) {
        ncxreg <- 0
    } else {
        if(NROW(xreg) != n) stop("lengths of x and xreg do not match")
        ncxreg <- NCOL(xreg)
    }
    class(xreg) <- NULL
    if(include.mean && (nd==0)) {
        if(is.matrix(xreg) && is.null(colnames(xreg)))
            colnames(x) <- paste("xreg", 1:ncxreg, sep="")
        xreg <- cbind(intercept=rep(1, n), xreg=xreg)
        ncxreg <- ncxreg+1
    }
    if(ncxreg) {
        if(d <- order[2]) xreg <- diff(xreg, 1, d)
        if(d <- seasonal$order[2]) xreg <- diff(xreg, seasonal$period, d)
        xreg <- as.matrix(xreg)
        if(qr(xreg)$rank < ncol(xreg)) stop("xreg is collinear")
    }
    .C("setup_starma",
       as.integer(arma), as.double(x), as.integer(n.used),
       as.double(xreg), as.integer(ncxreg), as.double(delta),
       as.integer(transform.pars > 0), PACKAGE="ts")
    init <- rep(0, sum(arma[1:4]))
    if(ncxreg > 0)
        init <- c(init, coef(lm(x ~ xreg+0)))
    res <- optim(init, arma0f, method="BFGS", hessian=transform.pars < 2)
    if(res$convergence > 0)
        warning(paste("possible convergence problem: optim gave code=",
                      res$convergence))
    coef <- res$par
    if(transform.pars)
        coef <- .C("Dotrans", coef, new=coef, PACKAGE="ts")$new
    .C("free_starma", PACKAGE="ts")
    if(transform.pars == 2) {
        .C("setup_starma",
           as.integer(arma), as.double(x), as.integer(n.used),
           as.double(xreg), as.integer(ncxreg), as.double(delta),
           as.integer(0), PACKAGE="ts")
        res <- optim(coef, arma0f, method="BFGS", hessian=TRUE)
        coef <- res$par
    }
    sigma2 <- .C("get_s2", res=double(1), PACKAGE="ts")$res
    resid <- .C("get_resid", res=double(n.used), PACKAGE="ts")$res
    tsp(resid) <- xtsp
    class(resid) <- "ts"
    nm <- NULL
    if(arma[1] > 0) nm <- c(nm, paste("ar", 1:arma[1], sep=""))
    if(arma[2] > 0) nm <- c(nm, paste("ma", 1:arma[2], sep=""))
    if(arma[3] > 0) nm <- c(nm, paste("sar", 1:arma[3], sep=""))
    if(arma[4] > 0) nm <- c(nm, paste("sma", 1:arma[4], sep=""))
    if(ncxreg > 0)
        if(!is.null(cn <- colnames(xreg))) nm <- c(nm, cn)
        else nm <- c(nm, paste("xreg", 1:ncxreg, sep=""))
    names(coef) <- nm
    names(arma) <- c("ar", "ma", "sar", "sma", "period", "diff", "sdiff")
    var <- solve(res$hessian*length(x))
    dimnames(var) <- list(nm, nm)
    if(transform.pars == 1) {
        if(ncxreg > 0) {
            ind <- sum(arma[1:4]) + 1:ncxreg
            var <- var[ind, ind, drop=FALSE]
        } else var <- matrix(NA, 0, 0)
    }
    value <- 2 * n.used * res$value + n.used + n.used*log(2*pi)
    aic <- value + 2*length(coef)
    res <- list(coef = coef, sigma2 = sigma2, var.coef = var,
                loglik = -0.5*value, aic = aic, arma = arma, resid = resid,
                call = match.call(), series = series, code = res$convergence)
    class(res) <- "arima0"
    res
}
arma0f <- function(p)
{
    if(!length(p)) stop("argument has length 0")
    .C("arma0fa", as.double(p), res=double(1), PACKAGE="ts")$res
}
print.arima0 <- function(x, digits = max(3, getOption("digits") - 3),
                         se=TRUE, ...)
{
    cat("\nCall:\n", deparse(x$call), "\n\n", sep = "")
    cat("Coefficients:\n")
    coef <- round(x$coef, digits = digits)
    print.default(coef, print.gap = 2)
    if(se && nrow(x$var.coef)) {
        ses <- round(sqrt(diag(x$var.coef)), digits = digits)
        names(ses) <- rownames(x$var.coef)
        cat("\nApprox standard errors:\n")
        print.default(ses, print.gap = 2)
    }
    cat("\nsigma^2 estimated as ",
        format(x$sigma2, digits = digits),
        ":  log likelihood = ", format(round(x$loglik,2)),
        ",  aic = ", format(round(x$aic,2)),
        "\n", sep="")
    invisible(x)
}
predict.arima0 <- function(object, n.ahead=1, newxreg=NULL, se.fit=TRUE)
{
    myNCOL <- function(x) if(is.null(x)) 0 else NCOL(x)
    data <- eval.parent(parse(text=object$series))
    xr <- object$call$xreg
    xreg <- if(!is.null(xr)) eval.parent(xr) else NULL
    ncxreg <- myNCOL(xreg)
    if(myNCOL(newxreg) != ncxreg)
        stop("xreg and newxreg have different numbers of columns")
    class(xreg) <- NULL
    xtsp <- tsp(data)
    n <- length(data)
    arma <- object$arma
    coefs <- object$coef
    narma <- sum(arma[1:4])
    if(length(coefs) > narma) {
        if(names(coefs)[narma+1] == "intercept") {
            xreg <- cbind(intercept=rep(1, n), xreg)
            newxreg <- cbind(intercept=rep(1, n.ahead), newxreg)
            ncxreg <- ncxreg+1
        }
        data <- data - xreg %*% coefs[-(1:narma)]
        xm <- drop(newxreg %*% coefs[-(1:narma)])
    } else xm <- 0
    ## check invertibility of MA part(s)
    if(arma[2] > 0) {
        ma <- coefs[arma[1]+1:arma[2]]
        if(any(Mod(polyroot(c(1, ma)))) < 1)
            warning("ma part of model is not invertible")
    }
    if(arma[4] > 0) {
        ma <- coefs[sum(arma[1:3])+1:arma[4]]
        if(any(Mod(polyroot(c(1, ma)))) < 1)
            warning("seasonal ma part of model is not invertible")
    }
    .C("setup_starma",
       as.integer(arma), as.double(data),
       as.integer(n),
       as.double(rep(0, n)), as.integer(0), as.double(-1), as.integer(0),
       PACKAGE="ts")
    arma0f(coefs)
    z <- .C("arma0_kfore", as.integer(arma[6]), as.integer(arma[7]),
            as.integer(n.ahead), x=double(n.ahead), var=double(n.ahead),
            PACKAGE="ts")
    .C("free_starma", PACKAGE="ts")
    pred <- ts(z$x + xm, start = xtsp[2] + deltat(data), frequency=xtsp[3])
    if(se.fit) {
        se <- ts(sqrt(z$var),
                 start = xtsp[2] + deltat(data), frequency=xtsp[3])
        return(pred, se)
    } else return(pred)
}
arima0.diag <- function(fit, gof.lag=10)
{
    ## plot standarized residuals, acf of residuals, Box-Pierce p-values
    oldpar<- par(mfrow=c(3,1))
    on.exit(par(oldpar))
    stdres <- fit$resid/sqrt(fit$sigma2)
    plot(stdres, type="h", main="Standardized Residuals", ylab="")
    abline(h=0)
    acf(fit$resid, plot=TRUE, main="ACF of Residuals")
    nlag <- gof.lag
    pval <- numeric(nlag)
    for(i in 1:nlag) pval[i] <- Box.test(fit$resid, i)$p.value
    plot(1:nlag, pval, xlab="lag", ylab="p value", ylim=c(0,1),
         main="p values for Box-Pierce statistic")
    abline(h=0.05, lty=2, col="blue")
}
# from MASS library: (C) 1994-9 W. N. Venables and B. D. Ripley
#
cpgram <- function(ts, taper=0.1,
   main=paste("Series: ", deparse(substitute(ts))), ci.col="blue")
{
    eval(main)
    if(NCOL(ts) > 1)
        stop("only implemented for univariate time series")
    x <- as.vector(ts)
    x <- x[!is.na(x)]
    x <- spec.taper(scale(x, TRUE, FALSE), p=taper)
    y <- Mod(fft(x))^2/length(x)
    y[1] <- 0
    n <- length(x)
    x <- (0:(n/2))*frequency(ts)/n
    if(length(x)%%2==0) {
        n <- length(x)-1
        y <- y[1:n]
        x <- x[1:n]
    } else y <- y[seq(along=x)]
    xm <- frequency(ts)/2
    mp <- length(x)-1
    crit <- 1.358/(sqrt(mp)+0.12+0.11/sqrt(mp))
    oldpty <- par(pty ="s")
    on.exit(par(oldpty))
    plot(x, cumsum(y)/sum(y), type="s", xlim=c(0, xm),
         ylim=c(0, 1), xaxs="i", yaxs="i", xlab="frequency",
         ylab="")
    lines(c(0, xm*(1-crit)), c(crit, 1), col = ci.col, lty = 2)
    lines(c(xm*crit, xm), c(0, 1-crit), col = ci.col, lty = 2)
    title(main = main)
    invisible()
}
# Copyright (C) 1997-1999  Adrian Trapletti
#
diffinv <- function (obj, ...) { UseMethod("diffinv") }
diffinv.vec <- function (x, lag = 1, differences = 1,
                         xi = rep(0.0,lag*differences))
{
    if (!is.vector(x)) stop ("x is not a vector")
    if (lag < 1 | differences < 1) stop ("Bad value for lag or differences")
    if (length(xi) != lag*differences) stop ("xi has not the right length")
    if (differences == 1) {
        n <- length(x)
        x <- as.vector(x,mode="double")
        y <- as.vector(numeric(n+lag))
        xi <- as.vector(xi,mode="double")
        for (i in 1:lag) y[i] <- xi[i]
        res <- .C("R_intgrt_vec", x, y=y, as.integer(lag), as.integer(n),
                  PACKAGE="ts")
        res$y
    }
    else
        diffinv.vec(diffinv.vec(x, lag, differences-1,
                                xi[(lag+1):(lag*differences)]),
                    lag, 1, xi[1:lag])
}
diffinv.default <- function (x, lag = 1, differences = 1,
                            xi = rep(0.0,lag*differences*dim(as.matrix(x))[2]))
{
    if (is.matrix(x)) {
        n <- nrow(x)
        m <- ncol(x)
        y <- matrix(0, nr=n+lag*differences, nc=m)
        dim(xi) <- c(lag*differences, m)
        for (i in 1:m)
            y[,i] <- diffinv.vec(as.vector(x[,i]), lag, differences,
                                 as.vector(xi[,i]))
    }
    else if (is.vector(x))
        y <- diffinv.vec(x, lag, differences, xi)
    else
        stop ("x is not a vector or matrix")
    y
}
diffinv.ts <- function (x, lag = 1, differences = 1,
                       xi = rep(0.0, lag*differences*NCOL(x)))
{
    if (is.ts(x) & is.null(dim(x)))
        y <- diffinv.default(as.vector(x), lag, differences, xi)
    else
        y <- diffinv.default(as.matrix(x), lag, differences, xi)
    ts(y, frequency = frequency(x), start = start(x))
}
toeplitz <- function (x)
{
    if (!is.vector(x)) stop ("x is not a vector")
    n <- length (x)
    A <- matrix (0, n, n)
    matrix (x[abs(col(A) - row(A)) + 1], n, n)
}
# Copyright (C) 1997-1999  Adrian Trapletti
#
# Rewritten to use R indexing (C) 1999 R Core Development Team
#
# 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
embed <- function (x, dimension = 1)
{
    if (is.matrix(x)) {
        n <- nrow(x)
        m <- ncol(x)
        if ((dimension < 1) | (dimension > n))
            stop ("wrong embedding dimension")
        y <- matrix(0.0, n - dimension + 1, dimension * m)
        for (i in (1:m))
            y[, seq(i, by = m,length = dimension)] <-
                Recall (as.vector(x[,i]), dimension)
        return (y)
    } else if (is.vector(x) || is.ts(x)) {
        n <- length (x)
        if ((dimension < 1) | (dimension > n))
            stop ("wrong embedding dimension")
        m <- n - dimension + 1
        return(matrix(x[1:m + rep(dimension:1, rep(m, dimension)) - 1], m))
    } else
        stop ("x is not a vector or matrix")
}
filter <- function(x, filter, method = c("convolution", "recursive"),
                   sides = 2, circular = FALSE, init=NULL)
{
    method <- match.arg(method)
    x <- as.ts(x)
    xtsp <- tsp(x)
    x <- as.matrix(x)
    n <- nrow(x)
    nser <- ncol(x)
    series <- colnames(x)
    nfilt <- length(filter)
    if(any(is.na(filter))) stop("missing values in filter")
    if(nfilt > n) stop("filter is longer than time series")
    y <- matrix(NA, n, nser)
    if(method == "convolution") {
        if(sides != 1 && sides != 2)
            stop("argument sides must be 1 or 2")
        for (i in 1:nser)
            y[, i] <- .C("filter1",
                         as.double(x[,i]),
                         as.integer(n),
                         as.double(filter),
                         as.integer(nfilt),
                         as.integer(sides),
                         as.integer(circular),
                         out=double(n), NAOK=TRUE, PACKAGE="ts")$out
    } else {
        if(missing(init)) {
            init <- matrix(0, nfilt, nser)
        } else {
            ni <- NROW(init)
            if(ni != nfilt)
                stop("length of init must equal length of filter")
            if(NCOL(init) != 1 && NCOL(init) != nser)
                stop(paste("init must have 1 or", nser, "cols"))
            if(!is.matrix(init)) init <- matrix(init, nfilt, nser)
        }
        for (i in 1:nser)
            y[, i] <- .C("filter2",
                         as.double(x[,i]),
                         as.integer(n),
                         as.double(filter),
                         as.integer(nfilt),
                         out=as.double(c(init[, i], double(n))),
                         NAOK=TRUE, PACKAGE="ts")$out[-(1:nfilt)]
    }
    y <- drop(y)
    tsp(y) <- xtsp
    class(y) <- if(nser > 1) c("mts", "ts") else "ts"
    y
}
# Copyright (C) 1997-1999  Adrian Trapletti
#
kernel <- function (coef, m = length(coef)+1, r, name="unknown")
{
    modified.daniell.kernel <- function (m)
    {
        if (any(m) < 0) stop ("m is negative")
        if(length(m) == 1)
            return (kernel(c(rep(1, m), 0.5)/(2*m), m,
                           name=paste("mDaniell(",m,")",sep="")))
        else {
            k <- Recall(m[1])
            for(i in 2:length(m)) k <- kernapply(k,  Recall(m[i]))
        }
        k
    }
    daniell.kernel <- function (m)
    {
        if (any(m) < 0) stop ("m is negative")
        if(length(m) == 1)
            return (kernel(rep(1/(2*m+1),m+1),m,
                           name=paste("Daniell(",m,")",sep="")))
        else {
            k <- Recall(m[1])
            for(i in 2:length(m)) k <- kernapply(k,  Recall(m[i]))
        }
        k
    }
    fejer.kernel <- function (m, r)
    {
        if (r < 1) stop ("r is less than 1")
        if (m < 1) stop ("m is less than 1")
        n <- 2*m+1
        wn <- double(m+1)
        for (j in (1:m))
        {
            wj <- 2*pi*j/n
            wn[j+1] <- sin(r*wj/2)^2/sin(wj/2)^2
        }
        wn <- wn/(n*r)
        wn[1] <- r/n
        wn <- wn/sum(c(rev(wn[2:(m+1)]),wn))
        kernel(wn, m, name=paste("Fejer(",m,",",r,")", sep=""))
    }
    dirichlet.kernel <- function (m, r)
    {
        if (r < 0) stop ("r is less than 0")
        if (m < 1) stop ("m is less than 1")
        n <- 2*m+1
        wn <- double(m+1)
        for (j in (1:m))
        {
            wj <- 2*pi*j/n
            wn[j+1] <- sin((r+0.5)*wj)/sin(wj/2)
        }
        wn <- wn/n
        wn[1] <- (2*r+1)/n
        wn <- wn/sum(c(rev(wn[2:(m+1)]),wn))
        return (kernel(wn, m, name=paste("Dirichlet(",m,",",r,")",sep="")))
    }
    if(is.character(coef)) {
        switch(coef,
               daniell = daniell.kernel(m),
               dirichlet = dirichlet.kernel(m),
               fejer = fejer.kernel(m, r),
               modified.daniell = modified.daniell.kernel(m),
               stop("unknown named kernel"))
    } else {
        if (!is.vector(coef))
            stop ("coef must be a vector")
        if ((length(coef) != m+1) | (length(coef) <= 0))
            stop ("coef has not the correct length")
        kernel <- list (coef=coef, m=m)
        attr(kernel, "name") <- name
        class(kernel) <- "tskernel"
        eps <- getOption("ts.eps")
        if ((sum(kernel[-m:m]) > 1.0+eps) || (sum(kernel[-m:m]) < 1.0-eps))
            stop ("coefficients do not add to 1")
        kernel
    }
}
print.tskernel <- function (k, digits = max(3,getOption("digits")-3))
{
    cat (attr(k,"name"),"\n")
    i <- -k$m:k$m
    cat(paste("coef[", format(i), "] = ",
              format(k$coef, digits=digits), sep=""), sep="\n")
}
plot.tskernel <- function (k)
{
    y <- c(rev(k$coef[2:(k$m+1)]),k$coef)
    plot ((-k$m:k$m), y, xlab="k", ylab="W[k]", type="h", main=attr(k,"name"))
}
df.kernel <- function (k)
{
    2/sum(k[-k$m:k$m]^2)
}
bandwidth.kernel <- function (k)
{
    sqrt(sum((1/12 + (-k$m:k$m)^2) * k[-k$m:k$m]))
}
"[.tskernel" <- function (k, i)
{
    y <- c(rev(k$coef[2:(k$m+1)]), k$coef)
    y[i+k$m+1]
}
is.tskernel <- function (k)
{
    inherits(k, "tskernel")
}
kernapply <- function (x, ...)
{
    UseMethod("kernapply")
}
kernapply.vector <- function (x, k, circular = FALSE)
{
    if (!is.vector(x)) stop ("x is not a vector")
    if (!is.tskernel(k)) stop ("k is not a kernel")
    if (length(x) <= 2*k$m)
        stop ("x is shorter than kernel k")
    if (k$m == 0)
        return (x)
    else
    {
        n <- length(x)
        w <- c(k[0:k$m], rep(0,n-2*k$m-1), k[-k$m:-1])
        y <- fft(fft(x)*fft(w), inverse=T)/n
        if (is.numeric(x)) y <- Re(y)
        if (circular)
            return (y)
        else
            return (y[(1+k$m):(n-k$m)])
    }
}
kernapply.default <- function (x, k, circular = FALSE)
{
    if (is.vector(x))
        return (kernapply.vector(x, k, circular=circular))
    else if (is.matrix(x))
        return (apply(x, MARGIN=2, FUN=kernapply, k, circular=circular))
    else
        stop ("kernapply is not available for object x")
}
kernapply.ts <- function (x, k, circular = FALSE)
{
    if (!is.matrix(x))
        y <- kernapply.vector(as.vector(x), k, circular=circular)
    else
        y <- apply(x, MARGIN=2, FUN=kernapply, k, circular=circular)
    ts (y, end=end(x), frequency=frequency(x))
}
kernapply.tskernel <- function (k1, k2)
{
    if (!is.tskernel(k1))
        stop ("k1 is not a kernel")
    if (!is.tskernel(k2))
        stop ("k2 is not a kernel")
    n <- k2$m
    x <- c(rep(0,n),k1[-k1$m:k1$m],rep(0,n))
    coef <- kernapply(x,k2,circular=T)
    m <- length(coef)%/%2
    kernel(coef[(m+1):length(coef)],m,
           paste("Composite(", attr(k1, "name"),",",attr(k2, "name"),")",sep=""))
}
lag <- function(x, ...) UseMethod("lag")
lag.default <- function(x, k = 1)
{
    if(k != round(k)) {
        k <- round(k)
        warning("k is not an integer")
    }
    x <- hasTsp(x)
    p <- tsp(x)
    tsp(x) <- p - (k/p[3]) * c(1, 1, 0)
    x
}
diff.ts <- function (x, lag = 1, differences = 1)
{
    if (lag < 1 | differences < 1)
        stop("Bad value for lag or differences")
    if (lag * differences >= NROW(x)) return(x[0])
    r <- x
    for (i in 1:differences) {
        r <- r - lag(r, -lag)
    }
    xtsp <- attr(x, "tsp")
    if(is.matrix(x)) colnames(r) <- colnames(x)
    ts(r, end = xtsp[2], freq = xtsp[3])
}
na.omit.ts <- function(frame)
{
    tm <- time(frame)
    xfreq <- frequency(frame)
    ## drop initial and final NAs
    if(is.matrix(frame))
        good <- which(apply(!is.na(frame), 1, all))
    else  good <- which(!is.na(frame))
    if(!length(good)) stop("all times contain an NA")
    omit <- integer(0)
    n <- NROW(frame)
    st <- min(good)
    if(st > 1) omit <- c(omit, 1:(st-1))
    en <- max(good)
    if(en < n) omit <- c(omit, (en+1):n)
    cl <- class(frame)
    if(length(omit)) {
        frame <- if(is.matrix(frame)) frame[st:en,] else frame[st:en]
        attr(omit, "class") <- "omit"
        attr(frame, "na.action") <- omit
        tsp(frame) <- c(tm[st], tm[en], xfreq)
        if(!is.null(cl)) class(frame) <- cl
    }
    if(any(is.na(frame))) stop("time series contains internal NAs")
    frame
}
na.contiguous <- function(frame)
{
    tm <- time(frame)
    xfreq <- frequency(frame)
    ## use (first) maximal contiguous length of non-NAs
    if(is.matrix(frame))
        good <- apply(!is.na(frame), 1, all)
    else  good <- !is.na(frame)
    if(!sum(good)) stop("all times contain an NA")
    tt <- cumsum(!good)
    ln <- sapply(0:max(tt), function(i) sum(tt==i))
    seg <- (seq(along=ln)[ln==max(ln)])[1] - 1
    keep <- (tt == seg)
    st <- min(which(keep))
    if(!good[st]) st <- st + 1
    en <- max(which(keep))
    omit <- integer(0)
    n <- NROW(frame)
    if(st > 1) omit <- c(omit, 1:(st-1))
    if(en < n) omit <- c(omit, (en+1):n)
    cl <- class(frame)
    if(length(omit)) {
        frame <- if(is.matrix(frame)) frame[st:en,] else frame[st:en]
        attr(omit, "class") <- "omit"
        attr(frame, "na.action") <- omit
        tsp(frame) <- c(tm[st], tm[en], xfreq)
        if(!is.null(cl)) class(frame) <- cl
    }
    frame
}
## based on code by Martyn Plummer, plus kernel code by Adrian Trapletti
spectrum <- function (..., method = c("pgram", "ar"))
{
    switch(match.arg(method),
           pgram = spec.pgram(...),
           ar = spec.ar(...)
           )
}
## spec.taper based on code by Kurt Hornik
spec.taper <- function (x, p = 0.1)
{
    if (any(p < 0) || any(p > 0.5))
        stop("p must be between 0 and 0.5")
    a <- attributes(x)
    x <- as.matrix(x)
    nc <- ncol(x)
    if (length(p) == 1)
        p <- rep(p, nc)
    else if (length(p) != nc)
        stop("length of p must be 1 or equal the number of columns of x")
    nr <- nrow(x)
    for (i in 1:nc) {
        m <- floor(nr * p[i])
        if(m == 0) next
        w <- 0.5 * (1 - cos(pi * seq(1, 2 * m - 1, by = 2)/(2 * m)))
        x[, i] <- c(w, rep(1, nr - 2 * m), rev(w)) * x[, i]
    }
    attributes(x) <- a
    x
}
spec.ar <- function(x, n.freq, order = NULL, plot = TRUE,
                    na.action = na.fail, method = "yule-walker", ...)
{
    ## can be called with a ts or a result of an AR fit.
    if(!is.list(x)) {
        series <- deparse(substitute(x))
        x <- na.action(as.ts(x))
        xfreq <- frequency(x)
        n <- NROW(x)
        nser <- NCOL(x)
        x <- ar(x, is.null(order), order, na.action=na.action, method=method)
    } else {
        cn <- match(c("ar", "var.pred", "order"), names(x))
        if(any(is.na(cn)))
            stop("x must be a time series or an ar() fit")
        series <- x$series
        xfreq <- x$frequency
        if(is.array(x$ar)) nser <- dim(x$ar)[2] else nser <- 1
    }
    n <- x$n.used
    order <- x$order
    if(missing(n.freq)) n.freq <- 500
    freq <- seq(0, 0.5, length = n.freq)
    if (nser == 1) {
        coh <- phase <- NULL
        if(order > 1) {
            cs <- outer(freq, 1:order, function(x, y) cos(2*pi*x*y)) %*% x$ar
            sn <- outer(freq, 1:order, function(x, y) sin(2*pi*x*y)) %*% x$ar
            spec <- x$var.pred/(xfreq*((1 - cs)^2 + sn^2))
        } else
            spec <- rep(x$var.pred/(xfreq), length(freq))
    } else .NotYetImplemented()
    spg.out <- list(freq = freq, spec = spec, coh = coh, phase = phase,
                    n.used = nrow(x), series = series,
                    method = paste("AR (", order, ") spectrum ", sep="")
                    )
    class(spg.out) <- "spec"
    if(plot) {
	plot(spg.out, ci = 0, ...)
        return(invisible(spg.out))
    } else return(spg.out)
}
spec.pgram <-
    function (x, spans = NULL, kernel = NULL, taper = 0.1,
              pad = 0, fast = TRUE,
              demean = FALSE, detrend = TRUE,
              plot = TRUE, na.action = na.fail, ...)
{
    ## Estimate spectral density from (smoothed) periodogram.
    series <- deparse(substitute(x))
    x <- na.action(as.ts(x))
    xfreq <- frequency(x)
    x <- as.matrix(x)
    N <- nrow(x)
    nser <- ncol(x)
    if(!is.null(spans)) # allow user to mistake order of args
        if(is.tskernel(spans)) kernel <- spans
        else kernel <- kernel("modified.daniell", spans %/% 2)
    if(!is.null(kernel) && !is.tskernel(kernel))
        stop("must specify spans or a valid kernel")
    if (detrend) {
        t <- 1:N - (N + 1)/2
        sumt2 <- N * (N^2 - 1)/12
        for (i in 1:ncol(x))
            x[, i] <- x[, i] - mean(x[, i]) - sum(x[, i] * t) * t/sumt2
    }
    else if (demean) {
        x <- sweep(x, 2, apply(x, 2, mean))
    }
    x <- spec.taper(x, taper)
    ## to correct for tapering: Bloomfield (1976, p. 194)
    ## Total taper is taper*2
    u2 <- (1 - (5/8)*taper*2)
    u4 <- (1 - (93/128)*taper*2)
    if (pad > 0) {
        x <- rbind(x, matrix(0, nrow = N * pad, ncol = ncol(x)))
        N <- nrow(x)
    }
    NewN <- if(fast) nextn(N) else N
    x <- rbind(x, matrix(0, nrow = (NewN - N), ncol = ncol(x)))
    N <- nrow(x)
    Nspec <- floor(N/2)
    freq <- seq(from = xfreq/N, by = xfreq/N, length = Nspec)
    xfft <- mvfft(x)
    pgram <- array(NA, dim = c(N, ncol(x), ncol(x)))
    for (i in 1:ncol(x)) {
        for (j in 1:ncol(x)) {
            pgram[, i, j] <- xfft[, i] * Conj(xfft[, j])/(N*xfreq)
        }
    }
    ## value at zero is invalid as mean has been removed, so interpolate
    pgram[1, i, j] <- 0.5*(pgram[2, i, j] + pgram[N, i, j])
    if(!is.null(kernel)) {
        for (i in 1:ncol(x)) for (j in 1:ncol(x))
                pgram[, i, j] <- kernapply(pgram[, i, j], kernel,
                                           circular = TRUE)
        df <- df.kernel(kernel)/(u4/u2^2)
        bandwidth <- bandwidth.kernel(kernel) * xfreq/N
    } else {
        df <- 2/(u4/u2^2)
        bandwidth <- sqrt(1/12) * xfreq/N
    }
    pgram <- pgram[1+(1:Nspec),,, drop=FALSE]
    spec <- matrix(NA, nrow = Nspec, ncol = nser)
    for (i in 1:nser) spec[, i] <- Re(pgram[1:Nspec, i, i])
    if (nser == 1) {
        coh <- phase <- NULL
    } else {
        coh <- phase <- matrix(NA, nrow = Nspec, ncol = nser * (nser - 1)/2)
        for (i in 1:(nser - 1)) {
            for (j in (i + 1):nser) {
                coh[, i + (j - 1) * (j - 2)/2] <-
                    Mod(pgram[, i, j])^2/(spec[, i] * spec[, j])
                phase[, i + (j - 1) * (j - 2)/2] <- Arg(pgram[, i, j])
            }
        }
    }
    ## correct for tapering
    for (i in 1:nser) spec[, i] <- spec[, i]/u2
    spec <- drop(spec)
    spg.out <-
        list(freq = freq, spec = spec, coh = coh, phase = phase,
             kernel = kernel, df = df,
             bandwidth = bandwidth, n.used = nrow(x),
             series = series, snames = colnames(x),
             method = ifelse(!is.null(kernel), "Smoothed Periodogram",
                             "Raw Periodogram"),
             taper = taper, pad = pad, detrend = detrend, demean = demean)
    class(spg.out) <- "spec"
    if(plot) {
	plot(spg.out, ...)
        return(invisible(spg.out))
    } else return(spg.out)
}
plot.spec <-
    function (x, add = FALSE, ci = 0.95, log = c("yes", "dB", "no"),
              xlab = "frequency", ylab = NULL,
              type = "l", ci.col="blue", main = NULL, sub = NULL,
              plot.type = c("marginal", "coherency", "phase"), ...)
{
    spec.ci <- function (spec.obj, coverage = 0.95)
    {
        ## A utility function for plot.spec which calculates the confidence
        ## interval (centred around zero). We use a conditional argument to
        ## ensure that the ci always contains zero.
        if (coverage < 0 || coverage >= 1)
            stop("coverage probability out of range [0,1)")
        tail <- (1 - coverage)
        df <- spec.obj$df
        upper.quantile <- 1 - tail * (1 - pchisq(df, df))
        lower.quantile <- tail * pchisq(df, df)
        1/(qchisq(c(upper.quantile, lower.quantile), df)/df)
    }
    plot.type <- match.arg(plot.type)
    m <- match.call()
    if(plot.type == "coherency") {
        m[[1]] <- as.name("plot.spec.coherency")
        m$plot.type <- m$log <- m$add <- NULL
        return(eval(m, sys.frame(sys.parent())))
    }
    if(plot.type == "phase") {
        m[[1]] <- as.name("plot.spec.phase")
        m$plot.type <- m$log <- m$add <- NULL
        return(eval(m, sys.frame(sys.parent())))
    }
    if(is.null(ylab))
        ylab <- if(log == "dB") "spectrum (dB)" else "spectrum"
    if(is.logical(log))
        log <- if(log) "yes" else "no"
    if(missing(log) && getOption("ts.S.compat")) log <- "dB"
    log <- match.arg(log)
    ylog <- ""
    if(log=="dB") x$spec <- 10 * log10(x$spec)
    if(log=="yes") ylog <- "y"
    if(add) {
        matplot(x$freq, x$spec, type = type, add=TRUE, ...)
    } else {
        matplot(x$freq, x$spec, xlab = xlab, ylab = ylab, type = type,
                log = ylog, ...)
        is.ar <- !is.na(pmatch("AR", x$method))
        if (ci <= 0 || log == "no" || is.ar) {
            ## No confidence limits
            ci.text <- ""
        } else {
            ## The position of the error bar has no meaning: only the width
            ## and height. It is positioned in the top right hand corner.
            ##
            conf.lim <- spec.ci(x, coverage = ci)
            if(log=="dB") {
                conf.lim <- 10*log10(conf.lim)
                conf.y <- max(x$spec) - conf.lim[2]
                conf.x <- max(x$freq) - x$bandwidth
                lines(rep(conf.x, 2), conf.y + conf.lim, col=ci.col)
                lines(conf.x + c(-0.5, 0.5) * x$bandwidth, rep(conf.y, 2),
                      col=ci.col)
                ci.text <- paste(", ", round(100*ci, 2),  "% C.I. is (",
                                 paste(format(conf.lim, digits = 3),
                                       collapse = ","), ")dB", sep="")
            } else {
                ci.text <- ""
                conf.y <- max(x$spec) / conf.lim[2]
                conf.x <- max(x$freq) - x$bandwidth
                lines(rep(conf.x, 2), conf.y * conf.lim, col=ci.col)
                lines(conf.x + c(-0.5, 0.5) * x$bandwidth, rep(conf.y, 2),
                      col=ci.col)
            }
        }
        if (is.null(main))
            main <- paste(paste("Series:", x$series), x$method, sep = "\n")
        if (is.null(sub) && !is.ar)
             sub <- paste("bandwidth = ", format(x$bandwidth, digits = 3),
                         ci.text, sep="")
        title(main = main, sub = sub)
    }
    invisible(x)
}
## based on code in Venables & Ripley
plot.spec.coherency <-
    function(x, ci = 0.95,
             xlab = "frequency", ylab = "squared coherency", ylim=c(0,1),
             type = "l", main = NULL, ci.lty = 3, ci.col="blue", ...)
{
    nser <- NCOL(x$spec)
    ## Formulae from Bloomfield (1976, p.225)
    gg <- 2/x$df
    se <- sqrt(gg/2)
    z <- -qnorm((1-ci)/2)
    if (is.null(main))
        main <- paste(paste("Series:", x$series),
                      "Squared Coherency", sep = " --  ")
    if(nser == 2) {
        plot(x$freq, x$coh, type=type, xlab=xlab, ylab=ylab, ylim=ylim, ...)
        coh <- pmin(0.99999, sqrt(x$coh))
        lines(x$freq, (tanh(atanh(coh) + z*se))^2, lty=ci.lty, col=ci.col)
        lines(x$freq, (pmax(0, tanh(atanh(coh) - z*se)))^2,
              lty=ci.lty, col=ci.col)
        title(main)
    } else {
        opar <- par(mfrow = c(nser-1, nser-1), mar = c(1.5, 1.5, 0.5, 0.5),
                    oma = c(4, 4, 6, 4))
        on.exit(par(opar))
        frame()
        for (j in 2:nser) for (i in 1:(j-1)) {
            par(mfg=c(j-1,i, nser-1, nser-1))
            ind <- i + (j - 1) * (j - 2)/2
            plot(x$freq, x$coh[, ind], type=type, ylim=ylim, axes=FALSE,
                 xlab="", ylab="", ...)
            coh <- pmin(0.99999, sqrt(x$coh[, ind]))
            lines(x$freq, (tanh(atanh(coh) + z*se))^2, lty=ci.lty, col=ci.col)
            lines(x$freq, (pmax(0, tanh(atanh(coh) - z*se)))^2,
                  lty=ci.lty, col=ci.col)
            box()
            if (i == 1) {
                axis(2, xpd = NA)
                title(ylab=x$snames[j], xpd = NA)
            }
            if (j == nser) {
                axis(1, xpd = NA)
                title(xlab=x$snames[i], xpd = NA)
            }
            mtext(main, 3, 3, TRUE, 0.5,
                  cex = par("cex.main"), font = par("font.main"))
        }
    }
}
plot.spec.phase <-
    function(x, ci = 0.95,
             xlab = "frequency", ylab = "phase", ylim=c(-pi, pi),
             type = "l", main = NULL, ci.lty = 3, ci.col="blue", ...)
{
    nser <- NCOL(x$spec)
    ## Formulae from Bloomfield (1976, p.225)
    gg <- 2/x$df
    if (is.null(main))
        main <- paste(paste("Series:", x$series),
                      "Phase spectrum", sep = "  -- ")
    if(nser == 2) {
        plot(x$freq, x$phase, type=type, xlab=xlab, ylab=ylab, ylim=ylim, ...)
        coh <- sqrt(x$coh)
        cl <- asin( pmin( 0.9999, qt(ci, 2/gg-2)*
                         sqrt(gg*(coh^{-2} - 1)/(2*(1-gg)) ) ) )
        lines(x$freq, x$phase + cl, lty=ci.lty, col=ci.col)
        lines(x$freq, x$phase - cl, lty=ci.lty, col=ci.col)
        title(main)
    } else {
        opar <- par(mfrow = c(nser-1, nser-1), mar = c(1.5, 1.5, 0.5, 0.5),
                    oma = c(4, 4, 6, 4))
        on.exit(par(opar))
        frame()
        for (j in 2:nser) for (i in 1:(j-1)) {
            par(mfg=c(j-1,i, nser-1, nser-1))
            ind <- i + (j - 1) * (j - 2)/2
            plot(x$freq, x$phase[, ind], type=type, ylim=ylim, axes=FALSE,
                 xlab="", ylab="", ...)
            coh <- sqrt(x$coh[, ind])
            cl <- asin( pmin( 0.9999, qt(ci, 2/gg-2)*
                             sqrt(gg*(coh^{-2} - 1)/(2*(1-gg)) ) ) )
            lines(x$freq, x$phase[, ind] + cl, lty=ci.lty, col=ci.col)
            lines(x$freq, x$phase[, ind] - cl, lty=ci.lty, col=ci.col)
            box()
            if (i == 1) {
                axis(2, xpd = NA)
                title(ylab=x$snames[j], xpd = NA)
            }
            if (j == nser) {
                axis(1, xpd = NA)
                title(xlab=x$snames[i], xpd = NA)
            }
            mtext(main, 3, 3, TRUE, 0.5,
                  cex = par("cex.main"), font = par("font.main"))
        }
    }
}
stl <- function(x, s.window = NULL, s.degree = 0, t.window = NULL,
                t.degree = 1, robust = FALSE, na.action = na.fail)
{
    nextodd <- function(x){
        x <- round(x)
        if(x%%2==0) x <- x+1
        as.integer(x)
    }
    x <- na.action(as.ts(x))
    if(is.matrix(x)) stop("only univariate series are allowed")
    n <- length(x)
    period <- frequency(x)
    if(is.null(s.window)) stop("s.window is missing with no default")
    if(period < 2 || n <= 2 * period)
        stop("series is not periodic or has less than two periods")
    periodic <- FALSE
    if(is.character(s.window))
        if(is.na(pmatch(s.window, "periodic")))
            stop("unknown value for s.window")
        else {
            periodic <- TRUE
            s.window <- 10 * n + 1
            s.degree <- 0
        }
    s.degree <- as.integer(s.degree)
    if(s.degree < 0 || s.degree > 1) stop("s.degree must be 0 or 1")
    t.degree <- as.integer(t.degree)
    if(t.degree < 0 || t.degree > 1) stop("t.degree must be 0 or 1")
    if(robust) {
        ni <- 1
        niter <- 15
    } else {
        ni <- 2
        niter <- 0
    }
    l.degree <- t.degree
    if(is.null(t.window))
        t.window <- nextodd(ceiling((1.5*period) / (1-(1.5/s.window))))
    l.window <- nextodd(period)
    z <- .Fortran("stl",
                  as.double(x),
                  as.integer(n),
                  as.integer(period),
                  as.integer(s.window),
                  as.integer(t.window),
                  as.integer(l.window),
                  s.degree, t.degree, l.degree,
                  nsjump = as.integer(ceiling(s.window/10)),
                  ntjump = as.integer(ceiling(t.window/10)),
                  nljump = as.integer(ceiling(l.window/10)),
                  as.integer(ni),
                  niter = as.integer(niter), weights = double(n),
                  seasonal = double(n),
                  trend = double(n),
                  double((n+2*period)*5), PACKAGE="ts")
    if(periodic) {
        ## make seasonal part exactly periodic
        which.cycle <- cycle(x)
        z$seasonal <- tapply(z$seasonal, which.cycle, mean)[which.cycle]
    }
    remainder <- as.vector(x) - z$seasonal - z$trend
    y <- cbind(seasonal=z$seasonal, trend=z$trend, remainder=remainder)
    res <- list(time.series = ts(y, start=start(x), frequency = period),
                weights=z$weights, call=match.call())
    class(res) <- "stl"
    res
}
print.stl <- function(x, ...)
{
    cat(" Call:\n")
    cat(" ")
    dput(x$call)
    cat("\nComponents\n")
    print(x$time.series)
    invisible(x)
}
plot.stl <- function(x, labels = colnames(X), ...)
{
    sers <- unclass(x$time.series)
    ncomp <- ncol(sers)
    data <- drop(sers %*% rep(1, ncomp))
    X <- cbind(data=data, sers)
    nplot <- ncomp + 1
    oldpar <- par("mar", "oma", "mfrow", "tck")
    on.exit(par(oldpar))
    par(mar = c(0, 6, 0, 6), oma = c(6, 0, 4, 0), tck = -0.01)
    par(mfrow = c(nplot, 1))
    for(i in 1:nplot) {
        plot(X[, i], type = if(i < nplot) "l" else "h",
             xlab = "", ylab = "", axes = F, ...)
        if(i == nplot) abline(h=0)
        box()
        right <- i %% 2 == 0
        axis(2, labels = !right)
        axis(4, labels = right)
        mtext(labels[i], 2, 3)
    }
    axis(1, labels = TRUE)
    axis(3, labels = FALSE)
    mtext("time", 1, 3)
    invisible()
}
Box.test <- function (x, lag = 1, type=c("Box-Pierce", "Ljung-Box"))
{
    if (NCOL(x) > 1)
        stop ("x is not a vector or univariate time series")
    DNAME <- deparse(substitute(x))
    type <- match.arg(type)
    cor <- acf (x, lag.max = lag, plot = FALSE)
    n <- length(x)
    PARAMETER <- lag
    obs <- cor$acf[2:(lag+1)]
    if (type=="Box-Pierce")
    {
        METHOD <- "Box-Pierce test"
        STATISTIC <- n*sum(obs^2)
        PVAL <- 1-pchisq(STATISTIC,lag)
    }
    else
    {
        METHOD <- "Box-Ljung test"
        STATISTIC <- n*(n+2)*sum(1/seq(n-1,n-lag)*obs^2)
        PVAL <- 1-pchisq(STATISTIC,lag)
    }
    names(STATISTIC) <- "X-squared"
    names(PARAMETER) <- "df"
    structure(list(statistic = STATISTIC,
                   parameter = PARAMETER,
                   p.value = PVAL,
                   method = METHOD,
                   data.name = DNAME),
              class = "htest")
}
PP.test <- function (x, lshort = TRUE)
{
    if (NCOL(x) > 1)
        stop ("x is not a vector or univariate time series")
    DNAME <- deparse(substitute(x))
    z <- embed (x, 2)
    yt <- z[,1]
    yt1 <- z[,2]
    n <- length (yt)
    tt <- (1:n)-n/2
    res <- lm (yt~1+tt+yt1)
    if (res$rank < 3)
        stop ("Singularities in regression")
    res.sum <- summary (res)
    tstat <- (res.sum$coefficients[3,1]-1)/res.sum$coefficients[3,2]
    u <- residuals (res)
    ssqru <- sum(u^2)/n
    if (lshort)
        l <- trunc(4*(n/100)^0.25)
    else
        l <- trunc(12*(n/100)^0.25)
    ssqrtl <- .C ("R_pp_sum", as.vector(u,mode="double"), as.integer(n),
                  as.integer(l), trm=as.double(ssqru), PACKAGE="ts")
    ssqrtl <- ssqrtl$trm
    n2 <- n^2
    trm1 <- n2*(n2-1)*sum(yt1^2)/12
    trm2 <- n*sum(yt1*(1:n))^2
    trm3 <- n*(n+1)*sum(yt1*(1:n))*sum(yt1)
    trm4 <- (n*(n+1)*(2*n+1)*sum(yt1)^2)/6
    Dx <- trm1-trm2+trm3-trm4
    STAT <- sqrt(ssqru)/sqrt(ssqrtl)*tstat-(n^3)/(4*sqrt(3)*sqrt(Dx)*sqrt(ssqrtl))*(ssqrtl-ssqru)
    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 <- l
    METHOD <- "Phillips-Perron Unit Root Test"
    names(STAT) <- "Dickey-Fuller"
    names(PARAMETER) <- "Truncation lag parameter"
    structure(list(statistic = STAT, parameter = PARAMETER,
                   p.value = PVAL, method = METHOD, data.name = DNAME),
              class = "htest")
}
is.mts <- function (x) inherits(x, "mts")
ts.plot <- function(..., gpars=list())
{
    sers <- ts.union(...)
    if(is.null(gpars$ylab))
        gpars$ylab <- if(NCOL(sers) > 1) "" else deparse(substitute(...))
    do.call("plot.ts", c(list(sers, plot.type="single"), gpars))
}
Ops.ts <- function(e1, e2)
{
    if(missing(e2)) {
        ## univariate operator
        NextMethod(.Generic)
    } else if(any(nchar(.Method) == 0)) {
        ## one operand is not a ts
        NextMethod(.Generic)
    } else {
        ## use ts.intersect to align e1 and e2
        nc1 <- NCOL(e1)
        nc2 <- NCOL(e2)
        e12 <- ts.intersect(e1, e2)
        e1 <- if(is.matrix(e1)) e12[, 1:nc1, drop = FALSE] else e12[, 1]
        e2 <- if(is.matrix(e2)) e12[, nc1 + (1:nc2), drop = FALSE]
        else e12[, nc1 + 1]
        NextMethod(.Generic)
    }
}
cbind.ts <- function(..., dframe = FALSE, union = TRUE)
{
    names.dots <- function(...)
    {
        l <- as.list(substitute(list(...)))[-1]
        nm <- names(l)
        fixup <- if (is.null(nm)) seq(along = l) else nm == ""
        dep <- sapply(l[fixup], function(x) deparse(x)[1])
        if (is.null(nm)) dep
        else {
            nm[fixup] <- dep
            nm
        }
    }
    sers <- list(...)
    nulls <- sapply(sers, is.null)
    sers <- sers[!nulls]
    nser <- length(sers)
    if(nser == 0) return(NULL)
    if(nser == 1)
        if(dframe) return(as.data.frame(sers[[1]])) else return(sers[[1]])
    nmsers <- names.dots(...)
    tsser <-  sapply(sers, function(x) length(tsp(x)) > 0)
    if(!any(tsser))
        stop("no time series supplied")
    sers <- lapply(sers, as.ts)
    nsers <- sapply(sers, NCOL)
    tsps <- sapply(sers[tsser], tsp)
    freq <- mean(tsps[3,])
    if(max(abs(tsps[3,] - freq)) > getOption("ts.eps")) {
        stop("Not all series have the same frequency")
    }
    if(union) {
        st <- min(tsps[1,])
        en <- max(tsps[2,])
    } else {
        st <- max(tsps[1,])
        en <- min(tsps[2,])
        if(st > en) {
            warning("Non-intersecting series")
            return(NULL)
        }
    }
    p <- c(st, en, freq)
    n <- round(freq * (en - st) + 1)
    if(any(!tsser)) {
        ln <- lapply(sers[!tsser], NROW)
        if(any(ln != 1 && ln != n))
            stop("non-time series not of the correct length")
        for(i in (1:nser)[!tsser]) {
            sers[[i]] <- ts(sers[[i]], start=st, end=en, frequency=freq)
        }
        tsps <- sapply(sers, tsp)
    }
    if(dframe) {
        x <- vector("list", n)
        names(x) <- nmsers
    } else {
        ns <- sum(nsers)
        x <- matrix(, n, ns)
        cs <- c(0, cumsum(nsers))
        nm <- character(ns)
        for(i in 1:nser)
            if(nsers[i] > 1) {
                cn <- colnames(sers[[i]])
                if(is.null(cn)) cn <- 1:nsers[i]
                nm[(1+cs[i]):cs[i+1]] <- paste(nmsers[i], cn, sep=".")
            } else nm[cs[i+1]] <- nmsers[i]
        dimnames(x) <- list(NULL, nm)
    }
    for(i in 1:nser) {
        if(union) {
            xx <-
                if(nsers[i] > 1)
                    rbind(matrix(NA, round(freq * (tsps[1,i] - st)), nsers[i]),
                          sers[[i]],
                          matrix(NA, round(freq * (en - tsps[2,i])), nsers[i]))
                else
                    c(rep(NA, round(freq * (tsps[1,i] - st))), sers[[i]],
                      rep(NA, round(freq * (en - tsps[2,i]))))
        } else {
            xx <- window(sers[[i]], st, en)
        }
        if(dframe) x[[i]] <- structure(xx, tsp=p, class="ts")
        else x[, (1+cs[i]):cs[i+1]] <- xx
    }
    if(dframe) as.data.frame(x)
    else ts(x, start=st, freq=freq)
}
ts.union <- .Alias(cbind.ts)
ts.intersect <- function(...) cbind.ts(..., union=FALSE)
.First.lib <- function(lib, pkg)
{
    library.dynam("ts", pkg, lib)
#    if(interactive() || getOption("verbose"))
#	cat("\n	   This is a preliminary time series package for R\n",
#	    "	   See `library(help=ts)' for details.\n\n")
}
options(ts.S.compat = FALSE)
