R/rollmean.R

Defines functions rollmedian.ts rollmedian.default rollmedian.zoo rollmedian rollmedianr rollmax.ts rollmax.default rollmax.zoo rollmax rollmaxr rollsum.ts rollsum.default rollsum.zoo rollsum rollsumr rollmean.ts rollmean.default rollmean.zoo rollmean rollmeanr

Documented in rollmax rollmax.default rollmaxr rollmax.ts rollmax.zoo rollmean rollmean.default rollmeanr rollmean.ts rollmean.zoo rollmedian rollmedian.default rollmedianr rollmedian.ts rollmedian.zoo rollsum rollsum.default rollsumr rollsum.ts rollsum.zoo

# rollmean, rollmax, rollmedian (, rollmad) based on code posted by Jarek Tuszynski at
# https://www.stat.math.ethz.ch/pipermail/r-help/2004-October/057363.html
# ToDo: rollmad, currently rollapply() can be used

rollmeanr <- function(..., align = "right") {
	rollmean(..., align = align)
}

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

rollmean.zoo <- function(x, k, fill = if (na.pad) NA, na.pad = FALSE, 
	align = c("center", "left", "right"), ...) {

  if (length(x) < 1L) return(x)

  if (!missing(na.pad)) warning("na.pad is deprecated. Use fill.")

  align <- match.arg(align)

  n <- length(index(x))
  k <- trunc(k)
  if(k > n || anyNA(coredata(x))) return(rollapply(x, k, FUN = (mean), fill = fill, align = align, ...))

  if (length(dim(x)) == 2) {
	  # merge is the only zoo specific part of this method
	  
	  out <- do.call("merge", c(lapply(1:NCOL(x), function(i) {
		rollmean(x[, i, drop = TRUE], k, fill = fill, align = align, ...)
	  }), all = FALSE))
	  if (ncol(x) == 1) dim(out) <- c(length(out), 1)
	  colnames(out) <- colnames(x)
	  return(out)
  }

  ix <- switch(align,
      "left" = { 1:(n-k+1) },
      "center" = { floor((1+k)/2):ceiling(n-k/2) },
      "right" = { k:n })

  xu <- unclass(x)
  y <- xu[k:n] - xu[c(1, seq_len(n-k))] # difference from previous
  y[1] <- sum(xu[1:k])		 # find the first
  # sum precomputed differences
  rval <- cumsum(y)/k

  x[ix] <- rval
  na.fill(x, fill = fill, ix)

}

rollmean.default <- function(x, k, fill = if (na.pad) NA, na.pad = FALSE, 
	align = c("center", "left", "right"), ...)
{		
		if (length(x) < 1L) return(x)

		coredata(rollmean(zoo(x), k, fill = fill, align = align, ...))
}

rollmean.ts <- function(x, k, fill = if (na.pad) NA, na.pad = FALSE, 
	align = c("center", "left", "right"), ...)
{
		if (length(x) < 1L) return(x)
		as.ts(rollmean(as.zoo(x), k, fill = fill, align = align, ...))
}

rollsumr <- function(..., align = "right") {
	rollsum(..., align = align)
}

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

rollsum.zoo <- function(x, k, fill = if (na.pad) NA, na.pad = FALSE, 
	align = c("center", "left", "right"), ...)
{
  if (length(x) < 1L) return(x)

  if (!missing(na.pad)) warning("na.pad is deprecated. Use fill.")

  align <- match.arg(align)

  n <- length(index(x))
  k <- trunc(k)
  if(k > n || anyNA(coredata(x))) return(rollapply(x, k, FUN = (sum), fill = fill, align = align, ...))

  if (length(dim(x)) == 2) {
	  # merge is the only zoo specific part of this method
	  
	  out <- do.call("merge", c(lapply(1:NCOL(x), function(i) {
		rollsum(x[, i, drop = TRUE], k, fill = fill, align = align, ...)
	  }), all = FALSE))
	  if (ncol(x) == 1) dim(out) <- c(length(out), 1)
	  colnames(out) <- colnames(x)
	  return(out)
  }

  ix <- switch(align,
      "left" = { 1:(n-k+1) },
      "center" = { floor((1+k)/2):ceiling(n-k/2) },
      "right" = { k:n })

  xu <- unclass(x)
  y <- xu[k:n] - xu[c(1, seq_len(n-k))] # difference from previous
  y[1] <- sum(xu[1:k])		 # find the first
  # sum precomputed differences
  rval <- cumsum(y)

  x[ix] <- rval
  na.fill(x, fill = fill, ix)

}

rollsum.default <- function(x, k, fill = if (na.pad) NA, na.pad = FALSE, 
	align = c("center", "left", "right"), ...)
{
		if (length(x) < 1L) return(x)
		
		coredata(rollsum(zoo(x), k, fill = fill, align = align, ...))
}

rollsum.ts <- function(x, k, fill = if (na.pad) NA, na.pad = FALSE, 
	align = c("center", "left", "right"), ...)
{
		if (length(x) < 1L) return(x)
		as.ts(rollsum(as.zoo(x), k, fill = fill, align = align, ...))
}

rollmaxr <- function(..., align = "right") {
	rollmax(..., align = align)
}

rollmax <- function(x, k, fill = if (na.pad) NA, na.pad = FALSE, 
	align = c("center", "left", "right"), ...) {
	UseMethod("rollmax")
}

rollmax.zoo <- function(x, k, fill = if (na.pad) NA, na.pad = FALSE, 
	align = c("center", "left", "right"), ...)
{
  if (length(x) < 1L) return(x)

  if (!missing(na.pad)) warning("na.pad is deprecated. Use fill.")

  align <- match.arg(align)

  if (length(dim(x)) == 2) {
	  # merge is the only zoo specific part of this method
	  out <- do.call("merge", c(lapply(1:NCOL(x), function(i) {
		rollmax(x[, i, drop = TRUE], k, fill = fill, align = align, ...)
	  }), all = FALSE))
	  if (ncol(x) == 1) dim(out) <- c(length(out), 1)
	  colnames(out) <- if (ncol(x) == ncol(out)) colnames(x)
	  return(out)
  }

  n <- length(x)
  k <- trunc(k)
  if(k > n) return(rollapply(x, k, FUN = (max), fill = fill, align = align, ...))

  ix <- switch(align,
      "left" = { 1:(n-k+1) },
      "center" = { floor((1+k)/2):ceiling(n-k/2) },
      "right" = { k:n })

  n <- length(x) 
  rval <- rep(0, n) 
  a <- 0
  xc <- coredata(x)
  if(k == 1) {
    rval <- xc
  } else {
    for (i in k:n) {
      rval[i] <- if (is.na(a) || is.na(rval[i-1]) || a==rval[i-1]) 
        max(xc[(i-k+1):i]) # calculate max of window
      else 
        max(rval[i-1], xc[i]); # max of window = rval[i-1] 
      a <- xc[i-k+1] # point that will be removed from window
    }
    rval <- rval[-seq(k-1)]
  }

  x[ix] <- rval
  na.fill(x, fill = fill, ix)

}

rollmax.default <- function(x, k, fill = if (na.pad) NA, na.pad = FALSE, 
	align = c("center", "left", "right"), ...)
{
		if (length(x) < 1L) return(x)
		
		coredata(rollmax(zoo(x), k, fill = fill, align = align, ...))
}

rollmax.ts <- function(x, k, fill = if (na.pad) NA, na.pad = FALSE, 
	align = c("center", "left", "right"), ...)
{
		if (length(x) < 1L) return(x)
		
		as.ts(rollmax(as.zoo(x), k, fill = fill, align = align, ...))
}


rollmedianr <- function(..., align = "right") {
	rollmedian (..., align = align)
}

rollmedian <- function(x, k, fill = if (na.pad) NA, na.pad = FALSE, 
	align = c("center", "left", "right"), ...) {
	UseMethod("rollmedian")
}

rollmedian.zoo <- function(x, k, fill = if (na.pad) NA, na.pad = FALSE, 
	align = c("center", "left", "right"), ...)
{
  if (length(x) < 1L) return(x)

  if (!missing(na.pad)) warning("na.pad is deprecated. Use fill.")

  align <- match.arg(align)

  n <- length(index(x))
  k <- trunc(k)
  if(k > n || anyNA(coredata(x))) return(rollapply(x, k, FUN = (median), fill = fill, align = align, ...))

  if (length(dim(x)) == 2) {
	  # merge is the only zoo specific part of this method
	  out <- do.call("merge", c(lapply(1:NCOL(x), function(i) {
		rollmedian(x[, i, drop = TRUE], k, fill = fill, align = align, ...)
	  }), all = FALSE))
	  if (ncol(x) == 1) dim(out) <- c(length(out), 1)
	  colnames(out) <- colnames(x)
	  return(out)
  }

  ix <- switch(align,
      "left" = { 1:(n-k+1) },
      "center" = { floor((1+k)/2):ceiling(n-k/2) },
      "right" = { k:n })

  m <- k %/% 2
  rval <- runmed(x, k, ...)
  attr(rval, "k") <- NULL
  if(m >= 1) rval <- rval[-c(1:m, (n-m+1):n)]

  x[ix] <- rval
  na.fill(x, fill = fill, ix)

}

rollmedian.default <- function(x, k, fill = if (na.pad) NA, na.pad = FALSE, 
	align = c("center", "left", "right"), ...)
{
		if (length(x) < 1L) return(x)
		
		coredata(rollmedian(zoo(x), k, fill = fill, align = align, ...))
}

rollmedian.ts <- function(x, k, fill = if (na.pad) NA, na.pad = FALSE, 
	align = c("center", "left", "right"), ...)
{
		if (length(x) < 1L) return(x)
		
		as.ts(rollmedian(as.zoo(x), k, fill = fill, align = align, ...))
}

Try the zoo package in your browser

Any scripts or data that you put into this service are public.

zoo documentation built on April 14, 2023, 12:39 a.m.