.packageName <- "sandwich"
kweights <- function(x, kernel = c("Truncated", "Bartlett", "Parzen",
                     "Tukey-Hanning", "Quadratic Spectral"), normalize = FALSE)
{
  kernel <- match.arg(kernel)
  if(normalize) {
    ca <- switch(kernel,  
      "Truncated" = 2,
      "Bartlett" = 2/3,
      "Parzen" = .539285,
      "Tukey-Hanning" = 3/4,
      "Quadratic Spectral" = 1)
  } else ca <- 1

  switch(kernel,  
  "Truncated" = { ifelse(ca * x > 1, 0, 1) },
  "Bartlett" = { ifelse(ca * x > 1, 0, 1 - abs(ca * x)) },
  "Parzen" = { 
    ifelse(ca * x > 1, 0, ifelse(ca * x < 0.5,
      1 - 6 * (ca * x)^2 + 6 * abs(ca * x)^3, 2 * (1 - abs(ca * x))^3))
  },
  "Tukey-Hanning" = {
    ifelse(ca * x > 1, 0, (1 + cos(pi * ca * x))/2)
  },
  "Quadratic Spectral" = {
    y <- 6 * pi * x/5
    ifelse(x < 1e-4, 1, 3 * (1/y)^2 * (sin(y)/y - cos(y)))
  })
}

isoacf <- function(x, lagmax = NULL, weave1 = FALSE)
{
  acfWeave <- function(x, lag = trunc(5*sqrt(length(x))))
  {
    x <- x - mean(x)
    n <- length(x)
    autocov <- function(ii, xx)
      cov(xx[1:(length(xx)-ii+1)],xx[ii:length(xx)])
    covs <- sapply(2:lag, autocov, xx = x)
    covs/var(x)
  }

  if(weave1) {
    lagmax <- trunc(5*sqrt(length(x)))
    lagmax <- min(length(x) - 1, lagmax)
    covs <- acfWeave(x, lag = lagmax)
    isocovs <- pava.blocks(c(covs,0), c((length(x)-1):(length(x)-length(covs)),
      .Machine$double.xmax), up = FALSE)
    rval <- c(1, rep(isocovs$x, isocovs$blocks))    
  } else {
    lagmax <- length(x) - 1
    lagmax <- min(length(x) - 1, lagmax)
    covs <- as.vector(acf(x, lag = lagmax -1, plot = FALSE)$acf)[-1]
    rval <- c(1, -isoreg(1:(length(covs)+1), c(-covs, 0))$yf)
  }
  return(rval)
}

pava.blocks <- function(x, w = rep(1, length(x)),
  b = rep(1, length(x)), up = TRUE)
{
  lasti <- 1
  if(length(x) == 1) rval <- list(x = x, blocks = b,increasing = up)
  else {
    for(i in 2:length(x)) {
      if(x[i] <= x[lasti] & up){
        wtotal <- w[lasti]+w[i]
        x[lasti] <- (x[lasti]*w[lasti]+x[i]*w[i])/wtotal
        w[lasti] <- wtotal
        b[lasti] <- b[i]+b[lasti]
        b[i] <- 0
      } else if(x[i] <= x[lasti] & !up) {
        lasti <- i
      } else if(x[i] > x[lasti] & !up) {
        wtotal <- w[lasti]+w[i]
        x[lasti] <- (x[lasti]*w[lasti]+x[i]*w[i])/wtotal
        w[lasti] <- wtotal
        b[lasti] <- b[i]+b[lasti]
        b[i] <- 0
      } else if(x[i] > x[lasti] & up) {
        lasti <- i
      }
    }
  
    if(any(b == 0)) {
      subset <- (b > 0)
      rval <- pava.blocks(x[subset],w[subset],b[subset],up)
    } else
      rval <- list(x = x,blocks = b,increasing = up)
  }
  return(rval)  
}
estfun <- function(x, ...)
{
  UseMethod("estfun")
}

estfun.lm <- function(x, ...)
{
  if (is.matrix(x$x))
    xmat <- x$x
  else {
    mf <- model.frame(x)
    xmat <- model.matrix(terms(x), mf)    
  }
  if(!is.null(x$weights)) wts <- x$weights
    else wts <- 1
  res <- residuals(x)
  rval <- as.vector(res) * wts * xmat
  attr(rval, "assign") <- NULL
  if(is.zoo(res)) rval <- zoo(rval, time(res))
  if(is.ts(res)) rval <- ts(rval, start = start(res), frequency = frequency(res))
  return(rval)
}

estfun.glm <- function(x, ...)
{
  if (is.matrix(x$x))
    xmat <- x$x
  else {
    mf <- model.frame(x)
    xmat <- model.matrix(terms(x), mf)    
  }
  rval <- as.vector(residuals(x, "working")) * x$weights * xmat
  attr(rval, "assign") <- NULL
  res <- residuals(x, "pearson")
  if(is.ts(res)) rval <- ts(rval, start = start(res), frequency = frequency(res))
  if(is.zoo(res)) rval <- zoo(rval, time(res))
  return(rval)
}

estfun.rlm <- function(x, ...)
{
  if (is.matrix(x$x)) 
      xmat <- x$x
  else {
      mf <- model.frame(x)
      xmat <- model.matrix(terms(x), mf)
  }
  if (!is.null(x$weights)) 
      wts <- x$weights
  else wts <- 1
  res <- residuals(x)
  psi <- function(z) x$psi(z) * z
  rval <- as.vector(psi(res/x$s)) * wts * xmat
  attr(rval, "assign") <- NULL
  if(is.ts(res)) rval <- ts(rval, start = start(res), frequency = frequency(res))
  if(is.zoo(res)) rval <- zoo(rval, time(res))
  return(rval)
}

# estfun.coxph and estfun.survreg would be nice.
# This one seems pretty close: note, however, that the
# intercept score is missing.
#
# estfun.coxph <- function(x, ...)
# {
#   stopifnot(require(survival))
#   res <- residuals(x)
#   rval <- residuals(x, type = "score", ...)
#   if(is.ts(res)) rval <- ts(rval, start = start(res), frequency = frequency(res))
#   if(is.zoo(res)) rval <- zoo(rval, time(res))
#   return(rval)
# }
## vcovHAC() is the general workhorse for HAC estimation

vcovHAC <- function(x, order.by = NULL, prewhite = FALSE,
  weights = weightsAndrews, adjust = TRUE, diagnostics = FALSE,
  sandwich = TRUE, ar.method = "ols", data = list())
{
  prewhite <- as.integer(prewhite)

  umat <- estfun(x)[, , drop = FALSE]
  n.orig <- n <- nrow(umat)
  k <- ncol(umat)

  if(!is.null(order.by))
  {
    if(inherits(order.by, "formula")) {
      z <- model.matrix(order.by, data = data)
      z <- as.vector(z[,ncol(z)])
    } else {
      z <- order.by
    }
    index <- order(z)
  } else {
    index <- 1:n
  }
  umat <- umat[index, , drop = FALSE]

  if(prewhite > 0) {
    var.fit <- ar(umat, order.max = prewhite, demean = FALSE, aic = FALSE, method = ar.method)
    if(k > 1) D <- solve(diag(ncol(umat)) - apply(var.fit$ar, 2:3, sum))
      else D <- as.matrix(1/(1 - sum(var.fit$ar)))
    umat <- as.matrix(na.omit(var.fit$resid))
    n <- n - prewhite
  }

  if(is.function(weights))
    weights <- weights(x, order.by = order.by, prewhite = prewhite, ar.method = ar.method, data = data)

  if(length(weights) > n) {
    warning("more weights than observations, only first n used")
    weights <- weights[1:n]
  }
 
  utu <- 0.5 * crossprod(umat) * weights[1]
  wsum<-n*weights[1]/2
  w2sum<-n*weights[1]^2/2

  if(length(weights) > 1) {
    for (ii in 2:length(weights)) {
      utu <- utu + weights[ii] * crossprod(umat[1:(n-ii+1),,drop=FALSE], umat[ii:n,,drop=FALSE])
      wsum <- wsum + (n-ii+1) * weights[ii]
      w2sum <- w2sum + (n-ii+1) * weights[ii]^2
    }
  }

  utu <- utu + t(utu)

  ## Andrews: multiply with df n/(n-k)
  if(adjust) utu <- n.orig/(n.orig-k) * utu
  
  if(prewhite > 0) {
    utu <- crossprod(t(D), utu) %*% t(D)
  }
  
  
  wsum <- 2*wsum
  w2sum <- 2*w2sum
  bc <- n^2/(n^2 - wsum)
  df <- n^2/w2sum

  if(sandwich) {
    modelv <- summary(x)$cov.unscaled
    rval <- modelv %*% utu %*% modelv
  } else rval <- utu/n.orig

  if(diagnostics)  attr(rval, "diagnostics") <- list(bias.correction = bc, df = df)
  return(rval)
}



## weightsAndrews() and bwAndrews() implement the HAC estimation
## procedure described in Andrews (1991) and Andrews & Monahan (1992)
## kernHAC() is the convenience interface.
## (Note, that bwNeweyWest() can also be used with weightsAndrews())

weightsAndrews <- function(x, order.by = NULL, bw = bwAndrews,
  kernel = c("Quadratic Spectral", "Truncated", "Bartlett", "Parzen", "Tukey-Hanning"),
  prewhite = 1, ar.method = "ols", tol = 1e-7, data = list(), verbose = FALSE, ...)
{
  kernel <- match.arg(kernel)
  if(is.function(bw))
    bw <- bw(x, order.by = order.by, kernel = kernel,
      prewhite = prewhite, data = data, ar.method = ar.method, ...)
  if(verbose) cat(paste("\nBandwidth chosen:", bw, "\n"))
      
  n <- length(residuals(x)) - as.integer(prewhite)
  
  weights <- kweights(0:(n-1)/bw, kernel = kernel)
  weights <- weights[1:max(which(abs(weights) > tol))]
  return(weights)
}

bwAndrews <- function(x, order.by = NULL, kernel = c("Quadratic Spectral", "Truncated",
  "Bartlett", "Parzen", "Tukey-Hanning"), approx = c("AR(1)", "ARMA(1,1)"),
  weights = NULL, prewhite = 1, ar.method = "ols", data = list(), ...)
{
  kernel <- match.arg(kernel)
  approx <- match.arg(approx)
  prewhite <- as.integer(prewhite)

  umat <- estfun(x)[,, drop = FALSE]
  n <- nrow(umat)
  k <- ncol(umat)

  if(!is.null(order.by))
  {
    if(inherits(order.by, "formula")) {
      z <- model.matrix(order.by, data = data)
      z <- as.vector(z[,ncol(z)])
    } else {
      z <- order.by
    }
    index <- order(z)
  } else {
    index <- 1:n
  }

  umat <- umat[index, , drop = FALSE]

  ## compute weights (try to set the intercept weight to 0)
  #### could be ignored by using: weights = 1
  
  if(is.null(weights)) {
    weights <- rep(1, k)
    unames <- colnames(umat)
    if(!is.null(unames) && "(Intercept)" %in% unames)
      weights[which(unames == "(Intercept)")] <- 0
    else {
      res <- as.vector(residuals(x, "working"))
      weights[which(colSums((umat - res)^2) < 1e-16)] <- 0      
    }
  } else {
    weights <- rep(weights, length.out = k)
  }
  if(length(weights) < 2) weights <- 1

  if(prewhite > 0) {
    umat <- as.matrix(na.omit(ar(umat, order.max = prewhite,
      demean = FALSE, aic = FALSE, method = ar.method)$resid))
    n <- n - prewhite ##??
  }

  if(approx == "AR(1)") {
    fitAR1 <- function(x) {
      rval <-  ar(x, order.max = 1, aic = FALSE, method = "ols")
      rval <- c(rval$ar, sqrt(rval$var.pred))
      names(rval) <- c("rho", "sigma")
      return(rval)
    }

    ar.coef <- apply(umat, 2, fitAR1)

    denum <- sum(weights * (ar.coef["sigma",]/(1-ar.coef["rho",]))^4)
    alpha2 <- sum(weights * 4 * ar.coef["rho",]^2 * ar.coef["sigma",]^4/(1-ar.coef["rho",])^8) / denum
    alpha1 <- sum(weights * 4 * ar.coef["rho",]^2 * ar.coef["sigma",]^4/((1-ar.coef["rho",])^6 * (1+ar.coef["rho",])^2)) / denum

  } else {

    fitARMA11 <- function(x) {
      rval <-  arima(x, order = c(1, 0, 1), include.mean = FALSE)
      rval <- c(rval$coef, sqrt(rval$sigma2))
      names(rval) <- c("rho", "psi", "sigma")
      return(rval)
    }

    arma.coef <- apply(umat, 2, fitARMA11)

    denum <- sum(weights * ((1 + arma.coef["psi",]) * arma.coef["sigma",]/(1-arma.coef["rho",]))^4)
    alpha2 <- sum(weights * 4 * ((1 + arma.coef["rho",] * arma.coef["psi",]) * (
                                  arma.coef["rho",] + arma.coef["psi",]))^2 * arma.coef["sigma",]^4/
				 (1-arma.coef["rho",])^8) / denum
    alpha1 <- sum(weights * 4 * ((1 + arma.coef["rho",] * arma.coef["psi",]) * (
                                  arma.coef["rho",] + arma.coef["psi",]))^2 * arma.coef["sigma",]^4/
                                 ((1-arma.coef["rho",])^6 * (1+arma.coef["rho",])^2)) / denum
  }

  rval <- switch(kernel,
    "Truncated"          = {0.6611 * (n * alpha2)^(1/5)},
    "Bartlett"           = {1.1447 * (n * alpha1)^(1/3)},
    "Parzen"             = {2.6614 * (n * alpha2)^(1/5)},
    "Tukey-Hanning"      = {1.7462 * (n * alpha2)^(1/5)},
    "Quadratic Spectral" = {1.3221 * (n * alpha2)^(1/5)})

  return(rval)  
}

kernHAC <- function(x, order.by = NULL, prewhite = 1, bw = bwAndrews,
  kernel = c("Quadratic Spectral", "Truncated", "Bartlett", "Parzen", "Tukey-Hanning"),
  approx = c("AR(1)", "ARMA(1,1)"), adjust = TRUE, diagnostics = FALSE, sandwich = TRUE,
  ar.method = "ols", tol = 1e-7, data = list(), verbose = FALSE, ...)
{
  myweights <- function(x, order.by = NULL, prewhite = FALSE, ar.method = "ols", data = list())
    weightsAndrews(x, order.by = order.by, prewhite = prewhite, bw = bw,
                   kernel = kernel, approx = approx, ar.method = ar.method, tol = tol,
		   data = data, verbose = verbose, ...)
  vcovHAC(x, order.by = order.by, prewhite = prewhite,
    weights = myweights, adjust = adjust, diagnostics = diagnostics,
    sandwich = sandwich, ar.method = ar.method, data = data)
}



## weightsLumley() implements the WEAVE estimators from 
## Lumley & Heagerty (1999)
## weave() is a convenience interface

weightsLumley <- function(x, order.by = NULL, C = NULL,
  method = c("truncate", "smooth"), acf = isoacf, data = list(), ...)
{
  method <- match.arg(method)
  res <- residuals(x, "response")
  n <- length(res)

  if(!is.null(order.by))
  {
    if(inherits(order.by, "formula")) {
      z <- model.matrix(order.by, data = data)
      z <- as.vector(z[,ncol(z)])
    } else {
      z <- order.by
    }
    index <- order(z)
  } else {
    index <- 1:n
  }
  res <- res[index]

  rhohat <- acf(res)

  switch(method,
  "truncate" = {
    if(is.null(C)) C <- 4
    lag <- max((1:length(rhohat))[rhohat^2*n > C])
    weights <- rep(1, lag)
  },
  "smooth" = {
    if(is.null(C)) C <- 1
    weights <- C * n * rhohat^2
    weights <- ifelse(weights > 1, 1, weights)
    weights <- weights[1:max(which(abs(weights) > 1e-7))]
  })
  
  return(weights)
}



weave <- function(x, order.by = NULL, prewhite = FALSE, C = NULL,
  method = c("truncate", "smooth"), acf = isoacf, adjust = FALSE,
  diagnostics = FALSE, sandwich = TRUE, data = list(), ...)
{
  myweights <- function(x, order.by = NULL, prewhite = FALSE, data = list(), ...)
    weightsLumley(x, order.by = order.by, prewhite = prewhite, C = C,
                   method = method, acf = acf, data = data)
  vcovHAC(x, order.by = order.by, prewhite = prewhite,
    weights = myweights, adjust = adjust, diagnostics = diagnostics,
    sandwich = sandwich, data = data)
}


## bwNeweyWest() implements the procedure from Newey & West (1994)
## It works for Bartlett/Parzen/QS kernels and can thus be passed
## to weightsAndrews() and kernHAC() respectively.
## A convenience interface NeweyWest() to only the Bartlett kernel
## is also available.

bwNeweyWest <- function(x, order.by = NULL, kernel = c("Bartlett", "Parzen",
  "Quadratic Spectral", "Truncated", "Tukey-Hanning"), weights = NULL, prewhite = 1,
  ar.method = "ols", data = list(), ...)
{
  kernel <- match.arg(kernel)
  if(kernel %in% c("Truncated", "Tukey-Hanning"))
    stop(paste("Automatic bandwidth selection only available for ", 
      dQuote("Bartlett"), ", ", dQuote("Parzen"), " and ", dQuote("Quadratic Spectral"),
      " kernel. Use ", sQuote("bwAndrews"), " instead.", sep = ""))
  prewhite <- as.integer(prewhite)

  umat <- estfun(x)[,, drop = FALSE]
  n <- nrow(umat)
  k <- ncol(umat)

  if(!is.null(order.by))
  {
    if(inherits(order.by, "formula")) {
      z <- model.matrix(order.by, data = data)
      z <- as.vector(z[,ncol(z)])
    } else {
      z <- order.by
    }
    index <- order(z)
  } else {
    index <- 1:n
  }

  umat <- umat[index, , drop = FALSE]

  ## compute weights (try to set the intercept weight to 0)
  #### could be ignored by using: weights = 1
  
  if(is.null(weights)) {
    weights <- rep(1, k)
    unames <- colnames(umat)
    if(!is.null(unames) && "(Intercept)" %in% unames)
      weights[which(unames == "(Intercept)")] <- 0
    else {
      res <- as.vector(residuals(x, "working"))
      weights[which(colSums((umat - res)^2) < 1e-16)] <- 0      
    }
  } else {
    weights <- rep(weights, length.out = k)
  }
  if(length(weights) < 2) weights <- 1

  ## select lag truncation according to Table II C. from Newey & West (1994)
  mrate <- switch(kernel, 
    "Bartlett"           = 2/9,
    "Parzen"             = 4/25,
    "Quadratic Spectral" = 2/25)
  m <- floor(ifelse(prewhite > 0, 3, 4) * (n/100)^mrate)

  if(prewhite > 0) {
    umat <- as.matrix(na.omit(ar(umat, order.max = prewhite,
      demean = FALSE, aic = FALSE, method = ar.method)$resid))
    n <- n - prewhite
  }

  ## compute weighted variances
  hw <- umat %*% weights
  sigmaj <- function(j) sum(hw[1:(n-j)] * hw[(j+1):n])/n
  sigma <- sapply(0:m, sigmaj)
  s0 <- sigma[1] + 2*sum(sigma[-1])
  s1 <- 2 * sum(1:m * sigma[-1])
  s2 <- 2 * sum((1:m)^2 * sigma[-1])
  
  ## use parameters as in Table I B.
  ## choose 1/(2*q + 1)
  qrate <- 1/(2 * ifelse(kernel == "Bartlett", 1, 2) + 1)
  ## compute gamma
  rval <- switch(kernel,
    "Bartlett"           = { 1.1447 * ((s1/s0)^2)^qrate },
    "Parzen"             = { 2.6614 * ((s2/s0)^2)^qrate },
    "Quadratic Spectral" = { 1.3221 * ((s2/s0)^2)^qrate })
  ## compute bandwidth
  rval <- rval * (n + prewhite)^qrate

  ## rval is not truncated. This is done in NeweyWest(),
  ## but bwNeweyWest() can also be used without truncation.
  
  return(rval)  
}

NeweyWest <- function(x, lag = NULL,
  order.by = NULL, prewhite = TRUE, adjust = FALSE, 
  diagnostics = FALSE, sandwich = TRUE, ar.method = "ols", data = list(),
  verbose = FALSE)
{
  if(is.null(lag)) lag <- floor(bwNeweyWest(x, 
    order.by = order.by, prewhite = prewhite,
    ar.method = ar.method, data = data))
  if(verbose) cat(paste("\nLag truncation parameter chosen:", lag, "\n"))
  
  myweights <- seq(1, 0, by = -(1/(lag + 1)))
  vcovHAC(x, order.by = order.by, prewhite = prewhite,
    weights = myweights, adjust = adjust, diagnostics = diagnostics,
    sandwich = sandwich, ar.method = ar.method, data = data)
}

vcovHC <- function(x, 
  type = c("HC3", "const", "HC", "HC0", "HC1", "HC2", "HC4"),
  omega = NULL, ...)
{
  if(is.matrix(x$x))
    X <- x$x
  else {
    mf <- model.frame(x)
    X <- model.matrix(terms(x), mf)    
  }
  res <- residuals(x)
  n <- nrow(X)
  k <- ncol(X)
  
  x.sum <- summary(x)  
  Q1 <- x.sum$cov.unscaled
  sigma2 <- x.sum$sigma^2
  diaghat <- hat(X)
  type <- match.arg(type)
  if(type == "HC") type <- "HC0"

  V <- NULL
  if(is.null(omega)) {
    switch(type,
      "const" = { omega <- function(residuals, diaghat, df) rep(1, length(residuals)) * sum(residuals^2)/df
                  V <- sigma2 * Q1 },
      "HC0" = { omega <- function(residuals, diaghat, df) residuals^2 },
      "HC1" = { omega <- function(residuals, diaghat, df) residuals^2 * length(residuals)/df },
      "HC2" = { omega <- function(residuals, diaghat, df) residuals^2 / (1 - diaghat) },
      "HC3" = { omega <- function(residuals, diaghat, df) residuals^2 / (1 - diaghat)^2 },
      "HC4" = { omega <- function(residuals, diaghat, df) residuals^2 / (1 - diaghat)^pmin(4, length(residuals) * diaghat/as.integer(round(sum(diaghat), digits = 0))) })
  }
  if(is.null(V)) {
    if(is.function(omega)) omega <- omega(res, diaghat, x$df.residual)
    VX <- sqrt(omega) * X
    V <- crossprod(crossprod(t(VX), Q1))
  }
  return(V)
}
.First.lib <- function(lib, pkg) {
  if(!("package:zoo" %in% search() || require(zoo))) warning("could not load package zoo")
}
