adaptive && partial support, helper functions

Author: jangorecki

R/froll.R

@@ -1,36 +1,60 @@
+# helpers for partial2adaptive
+trimn = function(n, len, align) {
+  n = min(n, len) ## so frollsum(1:2, 3, partial=TRUE) works
+  if (align=="right")
+    c(seq.int(n), rep.int(n, len-n))
+  else
+    c(rep.int(n, len-n), rev(seq.int(n)))
+}
+trimnadaptive = function(n, align) {
+  if (align=="right")
+    pmin(n, seq_along(n))
+  else
+    pmin(n, rev(seq_along(n)))
+}
+
 # partial2adaptive helper function
 ## tune provided 'n' via partial=TRUE to adaptive=TRUE by prepared adaptive 'n' as shown in ?froll examples
-# partial2adaptive(1:4, 2, "right")
-# partial2adaptive(1:4, 2:3, "right")
-# partial2adaptive(list(1:4, 2:5), 2:3, "right")
-# frollsum(1:4, 2, partial=FALSE)
-# frollsum(1:4, 2, partial=TRUE)
-# frollsum(1:4, 2:3, partial=FALSE)
-# frollsum(1:4, 2:3, partial=TRUE)
-# frollsum(list(1:4, 2:5), 2:3, partial=FALSE)
-# frollsum(list(1:4, 2:5), 2:3, partial=TRUE)
-partial2adaptive = function(x, n, align) {
+# partial2adaptive(1:4, 2, "right", adaptive=FALSE)
+# partial2adaptive(1:4, 2:3, "right", adaptive=FALSE)
+# partial2adaptive(list(1:4, 2:5), 2:3, "right", adaptive=FALSE)
+# frollsum(1:4, 2, partial=FALSE, adaptive=FALSE)
+# frollsum(1:4, 2, partial=TRUE, adaptive=FALSE)
+# frollsum(1:4, 2:3, partial=FALSE, adaptive=FALSE)
+# frollsum(1:4, 2:3, partial=TRUE, adaptive=FALSE)
+# frollsum(list(1:4, 2:5), 2:3, partial=FALSE, adaptive=FALSE)
+# frollsum(list(1:4, 2:5), 2:3, partial=TRUE, adaptive=FALSE)
+partial2adaptive = function(x, n, align, adaptive) {
   if (align=="center")
     stopf("'partial' cannot be used together with align='center'")
   if (is.list(x) && length(unique(lengths(x)))!=1L)
     stopf("'partial' does not support variable length of columns in 'x'")
-  if (!is.numeric(n))
-    stopf("n must be an integer vector or a list of integer vectors")
   len = if (is.list(x)) length(x[[1L]]) else length(x)
   verbose = getOption("datatable.verbose")
-  if (verbose)
-    cat("partial2adaptive: froll partial=TRUE trimming 'n' and redirecting to adaptive=TRUE\n")
-  trimn = function(n, len, align) {
-    n = min(n, len) ## so frollsum(1:2, 3, partial=TRUE) works
-    if (align=="right")
-      c(seq.int(n), rep.int(n, len-n))
-    else
-      c(rep.int(n, len-n), rev(seq.int(n)))
-  }
-  if (length(n)>1L) {
-    lapply(n, len, align, FUN=trimn)
+  if (!adaptive) {
+    if (is.list(n))
+      stopf("n must be an integer, list is accepted for adaptive TRUE")
+    if (!is.numeric(n))
+      stopf("n must be an integer vector or a list of integer vectors")
+    if (verbose)
+      cat("partial2adaptive: froll partial=TRUE trimming 'n' and redirecting to adaptive=TRUE\n")
+    if (length(n)>1L) {
+      lapply(n, len, align, FUN=trimn)
+    } else {
+      trimn(n, len, align)
+    }
   } else {
-    trimn(n, len, align)
+    if (!(is.numeric(n) || (is.list(n) && all(vapply_1b(n, is.numeric)))))
+      stopf("n must be an integer vector or a list of integer vectors")
+    if (!is.list(n))
+      n = list(n)
+    if (length(unique(lengths(n))) != 1L)
+      stopf("adaptive window provided in 'n' must not to have different lengths")
+    if (length(n[[1L]]) != len)
+      stopf("length of vectors in 'x' must match to length of adaptive window in 'n'")
+    if (verbose)
+      cat("partial2adaptive: froll adaptive=TRUE and partial=TRUE trimming 'n'\n")
+    lapply(n, align, FUN=triman)
   }
 }
 
@@ -39,13 +63,9 @@ froll = function(fun, x, n, fill=NA, algo, align=c("right","left","center"), na.
   if (isTRUE(give.names))
     orig = list(n=n, adaptive=adaptive)
   if (isTRUE(partial)) {
-    if (isTRUE(adaptive))
-      stopf("'partial' argument cannot be used together with 'adaptive'")
-    if (is.list(n))
-      stopf("n must be integer, list is accepted for adaptive TRUE")
     if (!length(n))
       stopf("n must be non 0 length")
-    n = partial2adaptive(x, n, align)
+    n = partial2adaptive(x, n, align, adaptive)
     adaptive = TRUE
   }
   leftadaptive = isTRUE(adaptive) && align=="left"

inst/tests/froll.Rraw

@@ -919,6 +919,7 @@ test(6000.4001, frollmax(1:3, 2), c(NA, 2, 3), output="frollmaxFast: running for
 test(6000.4002, frollmax(1:10, 5), c(NA,NA,NA,NA,5,6,7,8,9,10), output="frollmaxFast: nested window max calculation called 0 times")
 test(6000.4003, frollmax(10:1, 5), c(NA,NA,NA,NA,10,9,8,7,6,5), output="frollmaxFast: nested window max calculation called 5 times")
 test(6000.4004, frollmax(1:3, 2, algo="exact"), c(NA, 2, 3), output="frollmaxExact: running in parallel for input length")
+test(6000.4005, frollmax(c(1,2,3,NA,5), 2), c(NA, 2, 3, NA, NA), output="continue with extra care for NFs")
 options(datatable.verbose=FALSE)
 n = 3
 x = c(7,2,3,6,3,2,4,5) # no NA
@@ -1021,16 +1022,32 @@ ans = frollmean(x, n, align="left")
 ans[(length(x)-n-1L):length(x)] = frollmean(x[(length(x)-n-1L):length(x)], n, partial=TRUE, align="left")
 test(6006.023, ans, c(1,1.5,2,2.5,2.75,3))
 ans = list(c(0.50,0.75,1.00,1.50,2.00,2.50), c(0.50,0.75,1.00,1.25,1.75,2.25))
-test(6006.031, frollmean(1:6/2, list(3L,4L), partial=TRUE), error="n must be integer, list is accepted for adaptive TRUE")
+test(6006.031, frollmean(1:6/2, list(3L,4L), partial=TRUE), error="n must be an integer, list is accepted for adaptive TRUE")
 test(6006.032, frollmean(1:6/2, 3:4, partial=TRUE), ans)
 options(datatable.verbose=TRUE)
 test(6006.901, frollmean(x, n, partial=TRUE), c(0.5,0.75,1,1.5,2,2.5), output="froll partial=TRUE trimming 'n' and redirecting to adaptive=TRUE")
+test(6006.902, frollmean(x, rep(n, length(x)), adaptive=TRUE, partial=TRUE), c(0.5,0.75,1,1.5,2,2.5), output="trimming", notOutput="redirecting")
 options(datatable.verbose=FALSE)
-test(6006.902, frollmean(1:4, rep(2L,4L), adaptive=TRUE, partial=TRUE), error="'partial' argument cannot be used together with 'adaptive'")
 test(6006.903, frollmean(1:4, 2L, align="center", partial=TRUE), error="'partial' cannot be used together with align='center'")
 test(6006.904, frollmean(list(1:4, 2:4), n, partial=TRUE), error="'partial' does not support variable length of columns in 'x'")
 test(6006.905, frollmean(x, TRUE, partial=TRUE), error="n must be an integer vector or a list of integer vectors")
-test(6006.906, frollmean(x, list(TRUE), partial=TRUE), error="n must be integer, list is accepted for adaptive TRUE")
+test(6006.906, frollmean(x, list(TRUE), partial=TRUE), error="n must be an integer, list is accepted for adaptive TRUE")
+
+## partial adaptive
+test(6006.930, frollmean(1:4, rep(2L,4L), adaptive=TRUE, partial=TRUE), c(1,1.5,2.5,3.5))
+test(6006.9301, frollmean(1:4, list(1:4, 1:3), adaptive=TRUE, partial=TRUE), error="adaptive window provided in 'n' must not to have different lengths")
+test(6006.9302, frollmean(1:4, list(1:3), adaptive=TRUE, partial=TRUE), error="length of vectors in 'x' must match to length of adaptive window in 'n'")
+test(6006.9303, frollmean(1:4, list(rep(2L,4L)), adaptive=TRUE, partial=TRUE), c(1,1.5,2.5,3.5))
+test(6006.9311, frollsum(1:4, 1:4, adaptive=TRUE, partial=TRUE), c(1,3,6,10)) ## all same as index
+test(6006.9312, frollsum(1:4, 1:4, align="left", adaptive=TRUE, partial=TRUE), c(1,5,7,4))
+test(6006.9321, frollsum(1:4, c(2,3,1,1), adaptive=TRUE, partial=TRUE), c(1,3,3,4)) ## leading two bigger than index
+test(6006.9322, frollsum(1:4, c(2,3,1,1), align="left", adaptive=TRUE, partial=TRUE), c(3,9,3,4))
+test(6006.9323, frollsum(1:4, c(6,5,4,2), adaptive=TRUE, partial=TRUE), c(1,3,6,7)) ## leading two bigger than rev index
+test(6006.9324, frollsum(1:4, c(6,5,4,2), align="left", adaptive=TRUE, partial=TRUE), c(10,9,7,4))
+test(6006.9331, frollsum(1:4, c(2,4,5,6), adaptive=TRUE, partial=TRUE), c(1,3,6,10)) ## trailing two bigger than index
+test(6006.9332, frollsum(1:4, c(2,4,5,6), align="left", adaptive=TRUE, partial=TRUE), c(3,9,7,4))
+test(6006.9333, frollsum(1:4, c(1,1,3,2), adaptive=TRUE, partial=TRUE), c(1,2,6,7)) ## trailing two bigger than rev index
+test(6006.9334, frollsum(1:4, c(1,1,3,2), align="left", adaptive=TRUE, partial=TRUE), c(1,2,7,4))
 
 ## give.names
 test(6006.951, frollsum(1:3, 2, give.names=TRUE), c(NA,3,5))
@@ -1208,7 +1225,7 @@ if (requireNamespace("zoo", quietly=TRUE)) {
 }
 #### adaptive moving average compare
 num = 6009.0
-arollfun = function(FUN, x, n, na.rm=FALSE, align=c("right","left"), fill=NA, nf.rm=FALSE) { ## partial cannot be used with adaptive
+arollfun = function(FUN, x, n, na.rm=FALSE, align=c("right","left"), fill=NA, nf.rm=FALSE, partial=FALSE) {
   # adaptive moving average in R
   stopifnot((nx<-length(x))==length(n))
   align = match.arg(align)
@@ -1218,12 +1235,16 @@ arollfun = function(FUN, x, n, na.rm=FALSE, align=c("right","left"), fill=NA, nf
   if (align=="right") {
     for (i in seq_along(x)) {
       if (i >= n[i])
-        ans[i] = f(x[(i-n[i]+1):i], na.rm=na.rm)
+        ans[i] = f(x[(i-n[i]+1L):i], na.rm=na.rm)
+      else if (partial)
+        ans[i] = f(x[1L:i], na.rm=na.rm)
     }
   } else {
     for (i in seq_along(x)) {
       if (i <= nx-n[i]+1)
-        ans[i] = f(x[i:(i+n[i]-1)], na.rm=na.rm)
+        ans[i] = f(x[i:(i+n[i]-1L)], na.rm=na.rm)
+      else if (partial)
+        ans[i] = f(x[i:length(x)], na.rm=na.rm)
     }
   }
   ans
@@ -1235,32 +1256,36 @@ afun_compare = function(x, n, funs=c("mean","sum","max"), algos=c("fast","exact"
     for (align in c("right","left")) {
       for (na.rm in c(FALSE, TRUE)) {
         for (fill in c(NA_real_, 0)) {
-          for (has.nf in c(NA,TRUE,FALSE)) {
-            if (identical(has.nf, FALSE)) {
-              if (na.rm)
-                next ## errors "not make sense"
-              if (any(!is.finite(x)))
-                next ## do not test warnings (mean, sum) or incorrect expect results (max)
-            }
-            for (algo in algos) {
-              num <<- num + num.step
-              eval(substitute(
-                test(.num, ignore.warning="no non-missing arguments",
-                     arollfun(.fun, x, n, fill=.fill, na.rm=.na.rm, align=.align),
-                     frollfun(.fun, x, n, fill=.fill, na.rm=.na.rm, algo=.algo, adaptive=TRUE, align=.align, has.nf=.has.nf)),
-                list(.num=num, .fun=fun, .fill=fill, .na.rm=na.rm, .algo=algo, .align=align, .has.nf=has.nf)
-              ))
+          for (partial in c(FALSE, TRUE)) {
+            for (has.nf in c(NA, TRUE, FALSE)) {
+              if (identical(has.nf, FALSE)) {
+                if (na.rm) {
+                  next
+                } ## errors "not make sense"
+                if (any(!is.finite(x))) {
+                  next
+                } ## do not test warnings (mean, sum) or incorrect expect results (max)
+              }
+              for (algo in algos) {
+                num <<- num + num.step
+                eval(substitute(
+                  test(.num,
+                    ignore.warning = "no non-missing arguments",
+                    arollfun(.fun, x, n, fill = .fill, na.rm = .na.rm, align = .align),
+                    frollfun(.fun, x, n, fill = .fill, na.rm = .na.rm, algo = .algo, adaptive = TRUE, align = .align, has.nf = .has.nf)
+                  ),
+                  list(.num = num, .fun = fun, .fill = fill, .na.rm = na.rm, .algo = algo, .align = align, .has.nf = has.nf)
+                ))
+              }
             }
           }
-          if (base::getRversion() >= "3.4.0") { ## SET_GROWABLE_BIT
-            num <<- num + num.step
-            eval(substitute(
-              test(.num, ignore.warning="no non-missing arguments",
-                   frollapply(x, n, FUN=match.fun(.fun), fill=.fill, na.rm=.na.rm, adaptive=TRUE, align=.align),
-                   frollfun(.fun, x, n, fill=.fill, na.rm=.na.rm, adaptive=TRUE, align=.align)),
-              list(.num=num, .fun=fun, .fill=fill, .na.rm=na.rm, .align=align)
-            ))
-          }
+          num <<- num + num.step
+          eval(substitute(
+            test(.num, ignore.warning="no non-missing arguments",
+              frollapply(x, n, FUN=match.fun(.fun), fill=.fill, na.rm=.na.rm, adaptive=TRUE, align=.align, partial=.partial),
+              frollfun(.fun, x, n, fill=.fill, na.rm=.na.rm, adaptive=TRUE, align=.align, partial=.partial)),
+            list(.num=num, .fun=fun, .fill=fill, .na.rm=na.rm, .align=align, .partial=partial)
+          ))
         }
       }
     }
@@ -1359,7 +1384,7 @@ if (!r340) {
   test(6010.2018, frollapply(1:5, rep(3, 5), function(x) head(x, 2), adaptive=TRUE), error="frolladaptiveapply: results from provided FUN are not length 1")
   test(6010.2019, frollapply(1:10, list(1:5), mean, adaptive=TRUE), error="length of integer vector(s) provided as list to 'n' argument must be equal to number of observations provided in 'x'")
   test(6010.2020, frollapply(1:10, 1:5, mean, adaptive=TRUE), error="length of integer vector(s) provided as list to 'n' argument must be equal to number of observations provided in 'x'")
-  test(6010.2021, frollapply(1:4, rep(2L,4L), mean, adaptive=TRUE, partial=TRUE), error="'partial' argument cannot be used together with 'adaptive'")
+  test(6010.2021, frollapply(1:4, rep(2L,4L), mean, adaptive=TRUE, partial=TRUE), c(1,1.5,2.5,3.5))
   options(datatable.verbose=TRUE)
   test(6010.2029, frollapply(c(1,3,4,2,0), c(3,2,2,3,2), sum, adaptive=TRUE, align="left"), c(8,7,6,NA,NA), output=c("processing from align='right'"))
   x = c(1,2,1,1,1,2,3,2)

man/froll.Rd

@@ -122,7 +122,7 @@
 \section{\code{partial} argument}{
   \code{partial=TRUE} is used to calculate rolling moments \emph{only} within the input itself. That is, at the boundaries (say, observation 2 for \code{n=4} and \code{align="right"}), we don't consider observations before the first as "missing", but instead shrink the window to be size \code{n=2}.
   In practice, this is the same as an \emph{adaptive} window, and could be accomplished, albeit less concisely, with a well-chosen \code{n} and \code{adaptive=TRUE}.
-  In fact, we implement \code{partial=TRUE} using the same algorithms as \code{adaptive=TRUE}. Therefore \code{partial=TRUE} inherits the limitations of adaptive rolling functions, see above. Adaptive functions use more complex algorithms; if performance is important, \code{partial=TRUE} should be avoided in favour of computing missing observations "by hand" after the rolling function; see examples.
+  In fact, we implement \code{partial=TRUE} using the same algorithms as \code{adaptive=TRUE}. Therefore \code{partial=TRUE} inherits the limitations of adaptive rolling functions, see above. Adaptive functions use more complex algorithms; if performance is important, \code{partial=TRUE} should be avoided in favour of computing only missing observations separately after the rolling function; see examples.
 }
 \section{\code{frollapply}}{
   \code{frollapply} computes rolling aggregate on arbitrary R functions. \code{adaptive} argument is not supported (to be changed). The input \code{x} (first argument) to the function \code{FUN} is coerced to \emph{numeric} beforehand(to be changed) and \code{FUN} has to return a scalar \emph{numeric} value (to be changed). Checks for that are made only during the first iteration when \code{FUN} is evaluated. Edge cases can be found in examples below. Any R function is supported, but it is not optimized using our own C implementation -- hence, for example, using \code{frollapply} to compute a rolling average is inefficient. It is also always single-threaded because there is no thread-safe API to R's C \code{eval}. Nevertheless we've seen the computation speed up vis-a-vis versions implemented in base R.

src/data.table.h

@@ -284,7 +284,8 @@ void internal_error(const char *call_name, const char *format, ...);
 
 // types.c
 char *end(char *start);
-void ansMsg(ans_t *ans, int n, bool verbose, const char *func);
+void ansSetMsg(ans_t *ans, uint8_t status, const char *msg, const char *func);
+void ansGetMsgs(ans_t *ans, int n, bool verbose, const char *func);
 SEXP testMsgR(SEXP status, SEXP x, SEXP k);
 
 //fifelse.c