#
# 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")) {
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)
width <- as.integer(width)[1]
stopifnot( width > 0, width <= nr )
## 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
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.