#
#   xts: eXtensible time-series
#
#   Copyright (C) 2008  Jeffrey A. Ryan jeff.a.ryan @ gmail.com
#
#   Contributions from Joshua M. Ulrich
#
#   This program is free software: you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation, either version 2 of the License, or
#   (at your option) any later version.
#
#   This program 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 General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program.  If not, see <http://www.gnu.org/licenses/>.

rollapply.xts <- function(data, width, FUN, ..., by=1, by.column=TRUE,
  fill=if(na.pad) NA, na.pad=TRUE, partial=TRUE,
  align=c("right","center","left")) {

  # handle width when it has multiple elements
  if (length(width) > 1) {
      align. <- match.arg(align)
      result <-
          rollapply(as.zoo(data), width, FUN, ..., by = by,
                    by.column = by.column, fill = fill,
                    partial = partial, align = align.)

      result <- as.xts(result)
      return(result)
  } else {
      width <- as.integer(width)
      stopifnot(width > 0, width <= NROW(data))
  }

  if (!missing(na.pad)) {
    warning("na.pad argument is deprecated")
  }
  if (!missing(partial)) {
    warning("partial argument is not currently supported")
  }

  data <- try.xts(data)  # jmu: is this necessary?
  
  # Code taken/adapted from rollapply.zoo from the 'zoo' package

  # xts doesn't currently have these functions
  #  if(by.column && by == 1 && ascending && length(list(...)) < 1)
  #    switch(deparse(substitute(FUN)),
  #    mean = return(rollmean(data, width, na.pad = na.pad, align = align)),
  #    max = return(rollmax(data, width, na.pad = na.pad, align = align)),
  #    median = return(rollmedian(data, width, na.pad = na.pad, align = align)))

  nr <- NROW(data)
  nc <- NCOL(data)

  ## process alignment
  align <- match.arg(align)
  n1 <- switch(align,    
    "left" = { width - 1},
    "center" = { floor(width/2) },
    "right" = { 0 })
  idx <- index(data)
  tt <- index(data)[seq((width-n1), (nr-n1), by)]
  #tt <- idx[seq((width-n1), (nr-n1), 1)]

  ## evaluate FUN only on coredata(data)
  #data <- coredata(data)

  FUN <- match.fun(FUN)

  ind <- as.matrix(seq.int(width,nr,by))
  #e <- embedi(nr, width, by, ascending)

  if( nc==1 ) {
    #xx <- apply(e, 1, function(i) FUN(data[i,],...))
    #xx <- sapply(1:NROW(e), function(i) FUN(data[e[i,],],...))
    ##xx <- sapply(ind, function(i) FUN(data[(i-width+1):i,],...))
    xx <- sapply(ind, function(i) FUN(.subset_xts(data,(i-width+1):i),...))
    if(!is.null(dim(xx))) xx <- t(xx)
    res <- xts(xx, tt, if (by == 1) attr(data, "frequency"))
  } else if( by.column ) {
    res <- xts( sapply( 1:NCOL(data), function(j)
                #apply(e, 1, function(i) FUN(data[i,j],...)) ),
                #apply(ind, 1, function(i) FUN(data[(i-width+1):i,j],...)) ),
                apply(ind, 1, function(i) FUN(.subset_xts(data,(i-width+1):i,j),...)) ),
		        tt, if (by == 1) attr(data, "frequency") )
  } else {
    #xx <- apply(e, 1, function(i) FUN(data[i,],...))
    ##xx <- apply(ind, 1, function(i) FUN(data[(i-width+1):i,],...))
    xx <- apply(ind, 1, function(i) FUN(.subset_xts(data,(i-width+1):i),...))
    if(!is.null(dim(xx))) xx <- t(xx)
    res <- xts(xx, tt, if (by == 1) attr(data, "frequency"))
  }
  
  ix <- index(data) %in% index(res)
  tmp <- merge(res, xts(,idx, attr(data, "frequency")))
  if(is.null(colnames(res))) {
    # remove dimnames (xts objects don't have rownames)
    dimnames(tmp) <- NULL
  }
  res <- na.fill(tmp, fill, ix)

  if( by.column && !is.null(dim(data)) ) {
    colnames(res) <- colnames(data)
  }
  return(res)
} 

rollsum.xts <- function (x, k, fill=if(na.pad) NA, na.pad=TRUE,
  align=c("right", "center", "left"), ...) {
  ## FIXME: align and fill are not respected!

  # from rollapply.xts; is this necessary?
  x <- try.xts(x)

  # from rollmean.zoo
  if (!missing(na.pad))
    warning("na.pad is deprecated. Use fill.")

  # process alignment
  align <- match.arg(align)
  #n1 <- switch(align,
  #  "left" = { k - 1 },
  #  "center" = { floor(k/2) },
  #  "right" = { 0 })
  #ix <- index(x)[seq((k-n1), (nrow(x)-n1), 1)]
  res <- .Call(C_roll_sum, x, k)
  res
}

rollmean.xts <- function (x, k, fill=if(na.pad) NA, na.pad=TRUE,
  align=c("right", "center", "left"), ...) {
  rollsum.xts(x=x, k=k, fill=fill, align=align, ...) / k
}

rollmax.xts <- function (x, k, fill=if(na.pad) NA, na.pad=TRUE,
  align=c("right", "center", "left"), ...) {
  ## FIXME: align and fill are not respected!

  # from rollapply.xts; is this necessary?
  x <- try.xts(x)

  # from rollmean.zoo
  if (!missing(na.pad))
    warning("na.pad is deprecated. Use fill.")

  # process alignment
  align <- match.arg(align)
  #n1 <- switch(align,
  #  "left" = { k - 1 },
  #  "center" = { floor(k/2) },
  #  "right" = { 0 })
  #ix <- index(x)[seq((k-n1), (nrow(x)-n1), 1)]
  res <- .Call(C_roll_max, x, k)
  res
}

rollmin.xts <- function (x, k, fill=if(na.pad) NA, na.pad=TRUE,
  align=c("right", "center", "left"), ...) {
  ## FIXME: align and fill are not respected!

  # from rollapply.xts; is this necessary?
  x <- try.xts(x)

  # from rollmean.zoo
  if (!missing(na.pad))
    warning("na.pad is deprecated. Use fill.")

  # process alignment
  align <- match.arg(align)
  #n1 <- switch(align,
  #  "left" = { k - 1 },
  #  "center" = { floor(k/2) },
  #  "right" = { 0 })
  #ix <- index(x)[seq((k-n1), (nrow(x)-n1), 1)]
  res <- .Call(C_roll_min, x, k)
  res
}

rollcov.xts <- function (x, y, k, fill=if(na.pad) NA, na.pad=TRUE,
  align=c("right", "center", "left"), sample=TRUE, ...) {
  ## FIXME: align and fill are not respected!

  # from rollapply.xts; is this necessary?
  x <- try.xts(x)
  y <- try.xts(y)

  # from rollmean.zoo
  if (!missing(na.pad))
    warning("na.pad is deprecated. Use fill.")

  # process alignment
  align <- match.arg(align)
  #n1 <- switch(align,
  #  "left" = { k - 1 },
  #  "center" = { floor(k/2) },
  #  "right" = { 0 })
  #ix <- index(x)[seq((k-n1), (nrow(x)-n1), 1)]
  res <- .Call(C_roll_cov, x, y, k, sample)
  res
}

