Adaptive moving average - top performance in R

Question

I am looking for some performance gains in terms of rolling/sliding window functions in R. It is quite common task which can be used in any ordered observations data set. I would like to share some of my findings, maybe somebody would be able to provide feedback to make it even faster.
Important note is that I focus on the case align="right" and adaptive rolling window, so width is a vector (same length as our observation vector). In case if we have width as scalar there are already very well developed functions in zoo and TTR packages which would be very hard to beat (4 years later: it was easier than I expected) as some of them are even using Fortran (but still user-defined FUNs can be faster using mentioned below wapply).
RcppRoll package is worth to mention due to its great performance, but so far there is no function which answers to that question. Would be great if someone could extend it to answer the question.

Consider we have a following data:

x = c(120,105,118,140,142,141,135,152,154,138,125,132,131,120)
plot(x, type="l")

And we want to apply rolling function over x vector with variable rolling window width.

set.seed(1)
width = sample(2:4,length(x),TRUE)

In this particular case we would have rolling function adaptive to sample of c(2,3,4).
We will apply mean function, expected results:

r = f(x, width, FUN = mean)
print(r)
##  [1]       NA       NA 114.3333 120.7500 141.0000 135.2500 139.5000
##  [8] 142.6667 147.0000 146.0000 131.5000 128.5000 131.5000 127.6667
plot(x, type="l")
lines(r, col="red")

Any indicator can be employed to produce width argument as different variants of adaptive moving averages, or any other function.

Looking for a top performance.

Escapade

Answer 1

December 2018 update

Efficient implementation of adaptive rolling functions has been made in data.table recently - more info in ?froll manual. Additionally an efficient alternative solution using base R has been identified (fastama below). Unfortunately Kevin Ushey's answer does not address the question thus it is not included in benchmark. Scale of benchmark has been increased as it pointless to compare microseconds.

set.seed(108)
x = rnorm(1e6)
width = rep(seq(from = 100, to = 500, by = 5), length.out=length(x))
microbenchmark(
  zoo=rollapplyr(x, width = width, FUN=mean, fill=NA),
  mapply=base_mapply(x, width=width, FUN=mean, na.rm=T),
  wmapply=wmapply(x, width=width, FUN=mean, na.rm=T),
  ama=ama(x, width, na.rm=T),
  fastama=fastama(x, width),
  frollmean=frollmean(x, width, na.rm=T, adaptive=TRUE),
  frollmean_exact=frollmean(x, width, na.rm=T, adaptive=TRUE, algo="exact"),
  times=1L
)
#Unit: milliseconds
#            expr          min           lq         mean       median           uq          max neval
#             zoo 32371.938248 32371.938248 32371.938248 32371.938248 32371.938248 32371.938248     1
#          mapply 13351.726032 13351.726032 13351.726032 13351.726032 13351.726032 13351.726032     1
#         wmapply 15114.774972 15114.774972 15114.774972 15114.774972 15114.774972 15114.774972     1
#             ama  9780.239091  9780.239091  9780.239091  9780.239091  9780.239091  9780.239091     1
#         fastama   351.618042   351.618042   351.618042   351.618042   351.618042   351.618042     1
#       frollmean     7.708054     7.708054     7.708054     7.708054     7.708054     7.708054     1
# frollmean_exact   194.115012   194.115012   194.115012   194.115012   194.115012   194.115012     1

ama = function(x, n, na.rm=FALSE, fill=NA, nf.rm=FALSE) {
  # more or less the same as previous forloopply
  stopifnot((nx<-length(x))==length(n))
  if (nf.rm) x[!is.finite(x)] = NA_real_
  ans = rep(NA_real_, nx)
  for (i in seq_along(x)) {
    ans[i] = if (i >= n[i])
      mean(x[(i-n[i]+1):i], na.rm=na.rm)
    else as.double(fill)
  }
  ans
}
fastama = function(x, n, na.rm, fill=NA) {
  if (!missing(na.rm)) stop("fast adaptive moving average implemented in R does not handle NAs, input having NAs will result in incorrect answer so not even try to compare to it")
  # fast implementation of adaptive moving average in R, in case of NAs incorrect answer
  stopifnot((nx<-length(x))==length(n))
  cs = cumsum(x)
  ans = rep(NA_real_, nx)
  for (i in seq_along(cs)) {
    ans[i] = if (i == n[i])
      cs[i]/n[i]
    else if (i > n[i])
      (cs[i]-cs[i-n[i]])/n[i]
    else as.double(fill)
  }
  ans
}

---

Old answer:

I chose 4 available solutions which doesn't need to do to C++, quite easy to find or google.

# 1. rollapply
library(zoo)
?rollapplyr
# 2. mapply
base_mapply <- function(x, width, FUN, ...){
  FUN <- match.fun(FUN)
  f <- function(i, width, data){
    if(i < width) return(NA_real_)
    return(FUN(data[(i-(width-1)):i], ...))
  }
  mapply(FUN = f, 
         seq_along(x), width,
         MoreArgs = list(data = x))
}
# 3. wmapply - modified version of wapply found: https://rmazing.wordpress.com/2013/04/23/wapply-a-faster-but-less-functional-rollapply-for-vector-setups/
wmapply <- function(x, width, FUN = NULL, ...){
  FUN <- match.fun(FUN)
  SEQ1 <- 1:length(x)
  SEQ1[SEQ1 <  width] <- NA_integer_
  SEQ2 <- lapply(SEQ1, function(i) if(!is.na(i)) (i - (width[i]-1)):i)
  OUT <- lapply(SEQ2, function(i) if(!is.null(i)) FUN(x[i], ...) else NA_real_)
  return(base:::simplify2array(OUT, higher = TRUE))
}
# 4. forloopply - simple loop solution
forloopply <- function(x, width, FUN = NULL, ...){
  FUN <- match.fun(FUN)
  OUT <- numeric()
  for(i in 1:length(x)) {
    if(i < width[i]) next
    OUT[i] <- FUN(x[(i-(width[i]-1)):i], ...)
  }
  return(OUT)
}

Below are the timings for prod function. mean function might be already optimized inside rollapplyr. All results equal.

library(microbenchmark)
# 1a. length(x) = 1000, window = 5-20
x <- runif(1000,0.5,1.5)
width <- rep(seq(from = 5, to = 20, by = 5), length(x)/4)
microbenchmark(
  rollapplyr(data = x, width = width, FUN = prod, fill = NA),
  base_mapply(x = x, width = width, FUN = prod, na.rm=T),
  wmapply(x = x, width = width, FUN = prod, na.rm=T),
  forloopply(x = x, width = width, FUN = prod, na.rm=T),
  times=100L
)
Unit: milliseconds
                                                       expr       min        lq    median       uq       max neval
 rollapplyr(data = x, width = width, FUN = prod, fill = NA) 59.690217 60.694364 61.979876 68.55698 153.60445   100
   base_mapply(x = x, width = width, FUN = prod, na.rm = T) 14.372537 14.694266 14.953234 16.00777  99.82199   100
       wmapply(x = x, width = width, FUN = prod, na.rm = T)  9.384938  9.755893  9.872079 10.09932  84.82886   100
    forloopply(x = x, width = width, FUN = prod, na.rm = T) 14.730428 15.062188 15.305059 15.76560 342.44173   100

# 1b. length(x) = 1000, window = 50-200
x <- runif(1000,0.5,1.5)
width <- rep(seq(from = 50, to = 200, by = 50), length(x)/4)
microbenchmark(
  rollapplyr(data = x, width = width, FUN = prod, fill = NA),
  base_mapply(x = x, width = width, FUN = prod, na.rm=T),
  wmapply(x = x, width = width, FUN = prod, na.rm=T),
  forloopply(x = x, width = width, FUN = prod, na.rm=T),
  times=100L
)
Unit: milliseconds
                                                       expr      min       lq   median       uq      max neval
 rollapplyr(data = x, width = width, FUN = prod, fill = NA) 71.99894 74.19434 75.44112 86.44893 281.6237   100
   base_mapply(x = x, width = width, FUN = prod, na.rm = T) 15.67158 16.10320 16.39249 17.20346 103.6211   100
       wmapply(x = x, width = width, FUN = prod, na.rm = T) 10.88882 11.54721 11.75229 12.19790 106.1170   100
    forloopply(x = x, width = width, FUN = prod, na.rm = T) 15.70704 16.06983 16.40393 17.14210 108.5005   100

# 2a. length(x) = 10000, window = 5-20
x <- runif(10000,0.5,1.5)
width <- rep(seq(from = 5, to = 20, by = 5), length(x)/4)
microbenchmark(
  rollapplyr(data = x, width = width, FUN = prod, fill = NA),
  base_mapply(x = x, width = width, FUN = prod, na.rm=T),
  wmapply(x = x, width = width, FUN = prod, na.rm=T),
  forloopply(x = x, width = width, FUN = prod, na.rm=T),
  times=100L
)
Unit: milliseconds
                                                       expr       min       lq   median       uq       max neval
 rollapplyr(data = x, width = width, FUN = prod, fill = NA) 753.87882 781.8789 809.7680 872.8405 1116.7021   100
   base_mapply(x = x, width = width, FUN = prod, na.rm = T) 148.54919 159.9986 231.5387 239.9183  339.7270   100
       wmapply(x = x, width = width, FUN = prod, na.rm = T)  98.42682 105.2641 117.4923 183.4472  245.4577   100
    forloopply(x = x, width = width, FUN = prod, na.rm = T) 533.95641 602.0652 646.7420 672.7483  922.3317   100

# 2b. length(x) = 10000, window = 50-200
x <- runif(10000,0.5,1.5)
width <- rep(seq(from = 50, to = 200, by = 50), length(x)/4)
microbenchmark(
  rollapplyr(data = x, width = width, FUN = prod, fill = NA),
  base_mapply(x = x, width = width, FUN = prod, na.rm=T),
  wmapply(x = x, width = width, FUN = prod, na.rm=T),
  forloopply(x = x, width = width, FUN = prod, na.rm=T),
  times=100L
)
Unit: milliseconds
                                                       expr      min       lq    median        uq       max neval
 rollapplyr(data = x, width = width, FUN = prod, fill = NA) 912.5829 946.2971 1024.7245 1071.5599 1431.5289   100
   base_mapply(x = x, width = width, FUN = prod, na.rm = T) 171.3189 180.6014  260.8817  269.5672  344.4500   100
       wmapply(x = x, width = width, FUN = prod, na.rm = T) 123.1964 131.1663  204.6064  221.1004  484.3636   100
    forloopply(x = x, width = width, FUN = prod, na.rm = T) 561.2993 696.5583  800.9197  959.6298 1273.5350   100

Escapade

@Dirk, I don't want to start a blog for just one share. SO is a very good discussion board too. The question about rolling window FUNs is quite common on SO but I didn't find any good benchmarks. Still I hope there is some performance improvment to gain in that area without going to Cpp, so I'm looking forward for better answers to my question. – Escapade

Disagree, I see nothing wrong with this. SO is a repository of knowledge. I for one learned something from this. – Seizure

@DirkEddelbuettel, SO does encourage users to ask and answer their own questions, so long as it's done with proper etiquette. See here. – Alimentary

Sorry, no patience for meta.s.e navel-gazing here. SO used to be an excellent resources. Now it's flooded by people who can't/won't do any research on their own, repeat questions and other abuses of the platform. And using it as a personal CMS still doesn't ring right to me. – Wiedmann

@DirkEddelbuettel, agree with lots of lazyness out there, but you have to recognize that is not at all the issue here. Clearly MusX spent a fair bit of his time putting his question and answers together. I've read a lot of the standard R lit out there, and the issues he describes are not typically documented. There is far worse behavior to go downvote / yell at. – Seizure

Let me put it another way, if someone else had asked the question, and MusX had answered it, his answer would have been seen as a positive contribution. And it's not a useless question either, so I really can't see how this is bad. – Seizure

There is one good (C++-based) solution to the problem---contributed as a CRAN package by Kevin. The OP hushed "could not test" without providing any detail, and proceded to waste everybody's time with a lot of non-compiled solutions. And that is a contribution? – Wiedmann

as per info from Kevin RcppRoll handle width as scalar only, so by default it would not solve the problem. I don't know Cpp, but I believe there might me done adjustments to handle this, the same as I did to wapply from r-bloggers - which also accept only scalar width. Most of the tasks can be outperformed using R-cpp interface. Without width as scalar it is hard to compare the timings, even then it is good to compare best non cpp solution to cpp solution timings. – Escapade

Answer 2

For reference, you should definitely check out RcppRoll if you have only a single window length to 'roll' over:

library(RcppRoll) ## install.packages("RcppRoll")
library(microbenchmark)
x <- runif(1E5)
all.equal( rollapplyr(x, 10, FUN=prod), roll_prod(x, 10) )
microbenchmark( times=5,
  rollapplyr(x, 10, FUN=prod),
  roll_prod(x, 10)
)

gives me

> library(RcppRoll)
> library(microbenchmark)
> x <- runif(1E5)
> all.equal( rollapplyr(x, 10, FUN=prod), roll_prod(x, 10) )
[1] TRUE
> microbenchmark( times=5,
+   zoo=rollapplyr(x, 10, FUN=prod),
+   RcppRoll=roll_prod(x, 10)
+ )
Unit: milliseconds
     expr        min         lq     median         uq         max neval
      zoo 924.894069 968.467299 997.134932 1029.10883 1079.613569     5
 RcppRoll   1.509155   1.553062   1.760739    1.90061    1.944999     5

It's a bit faster ;) and the package is flexible enough for users to define and use their own rolling functions (with C++). I may extend the package in the future to allow multiple window widths, but I am sure it will be tricky to get right.

If you want to define the prod yourself, you can do so -- RcppRoll allows you to define your own C++ functions to pass through and generate a 'rolling' function if you'd like. rollit gives a somewhat nicer interface, while rollit_raw just lets you write a C++ function yourself, somewhat like you might do with Rcpp::cppFunction. The philosophy being, you should only have to express the computation you wish to perform on a particular window, and RcppRoll can take care of iterating over windows of some size.

library(RcppRoll)
library(microbenchmark)
x <- runif(1E5)
my_rolling_prod <- rollit(combine="*")
my_rolling_prod2 <- rollit_raw("
double output = 1;
for (int i=0; i < n; ++i) {
  output *= X(i);
}
return output;
")
all.equal( roll_prod(x, 10), my_rolling_prod(x, 10) )
all.equal( roll_prod(x, 10), my_rolling_prod2(x, 10) )
microbenchmark( times=5,
  rollapplyr(x, 10, FUN=prod),
  roll_prod(x, 10),
  my_rolling_prod(x, 10),
  my_rolling_prod2(x, 10)
)

gives me

> library(RcppRoll)
> library(microbenchmark)
> # 1a. length(x) = 1000, window = 5-20
> x <- runif(1E5)
> my_rolling_prod <- rollit(combine="*")
C++ source file written to /var/folders/m7/_xnnz_b53kjgggkb1drc1f8c0000gn/T//RtmpcFMJEV/file80263aa7cca2.cpp .
Compiling...
Done!
> my_rolling_prod2 <- rollit_raw("
+ double output = 1;
+ for (int i=0; i < n; ++i) {
+   output *= X(i);
+ }
+ return output;
+ ")
C++ source file written to /var/folders/m7/_xnnz_b53kjgggkb1drc1f8c0000gn/T//RtmpcFMJEV/file802673777da2.cpp .
Compiling...
Done!
> all.equal( roll_prod(x, 10), my_rolling_prod(x, 10) )
[1] TRUE
> all.equal( roll_prod(x, 10), my_rolling_prod2(x, 10) )
[1] TRUE
> microbenchmark(
+   rollapplyr(x, 10, FUN=prod),
+   roll_prod(x, 10),
+   my_rolling_prod(x, 10),
+   my_rolling_prod2(x, 10)
+ )

> microbenchmark( times=5,
+   rollapplyr(x, 10, FUN=prod),
+   roll_prod(x, 10),
+   my_rolling_prod(x, 10),
+   my_rolling_prod2(x, 10)
+ )
Unit: microseconds
                          expr        min          lq      median          uq         max neval
 rollapplyr(x, 10, FUN = prod) 979710.368 1115931.323 1117375.922 1120085.250 1149117.854     5
              roll_prod(x, 10)   1504.377    1635.749    1638.943    1815.344    2053.997     5
        my_rolling_prod(x, 10)   1507.687    1572.046    1648.031    2103.355    7192.493     5
       my_rolling_prod2(x, 10)    774.381     786.750     884.951    1052.508    1434.660     5

So really, as long as you are capable of expressing the computation you wish to perform in a particular window through either the rollit interface or with a C++ function passed through rollit_raw (whose interface is a bit rigid, but still functional), you are in good shape.

Alimentary

I don't know your roll_prod but I was looking for not optimized functions, I choose prod to simulate user-defined function just because other standard mean,max,etc. were already optimized in rollapply. Indeed your function has outstanding time but still width as a scalar is not a problem to solve here. Anyway for me the biggest problem is Cpp here. Thanks for the timings, can I ask for the same timing using roll_it? To have a timings for standard user-defined prod function. – Escapade

I updated my answer with an example of how you might use a user-defined function with RcppRoll; in particular, two ways of expressing prod here. – Alimentary

Awesome! I think this has straightened me out on a related question too! Thanks! – Excitement

Do the update address the question for Adaptive rolling fun? I don't see any vectorized attribute. – Escapade

Answer 3

Somehow people have missed the ultra fast runmed() in base R (stats package). It's not adaptive, as far as I understand the original question, but for a rolling median, it's FAST! Comparing here to roll_median() from RcppRoll.

> microbenchmark(
+   runmed(x = x, k = 3),
+   roll_median(x, 3),
+   times=1000L
+ )
Unit: microseconds
                 expr     min      lq      mean  median      uq     max neval
 runmed(x = x, k = 3)  41.053  44.854  47.60973  46.755  49.795 117.838  1000
    roll_median(x, 3) 101.872 105.293 108.72840 107.574 111.375 178.657  1000

Gravedigger

it has to be adaptive to answer the question :) – Escapade