diff --git a/NEWS.md b/NEWS.md index 7751e669f6..17fb0c1e20 100644 --- a/NEWS.md +++ b/NEWS.md @@ -20,6 +20,18 @@ frollsum(c(1,2,3,Inf,5,6), 2) #[1] NA 3 5 Inf Inf 11 +4. `frollapply` result is not coerced to numeric anymore. Users' code could possibly break if it depends on forced coercion of input/output to numeric type. + ```r + ## before + frollapply(c(F,T,F,F,F,T), 2, any) + #[1] NA 1 1 0 0 1 + + ## now + frollapply(c(F,T,F,F,F,T), 2, any) + #[1] NA TRUE TRUE FALSE FALSE TRUE + ``` + Additionally argument names in `frollapply` has been renamed from `x` to `X` and `n` to `N` to avoid conflicts with common argument names that may be passed to `...`, aligning to base R API of `lapply`. `x` and `n` continue to work with a warning, for now. + ### NOTICE OF INTENDED FUTURE POTENTIAL BREAKING CHANGES 1. `data.table(x=1, )`, where `` is an expression resulting in a 1-column matrix without column names, will eventually have names `x` and `V2`, not `x` and `V1`, consistent with `data.table(x=1, )` where `` results in an atomic vector, for example `data.table(x=1, cbind(1))` and `data.table(x=1, 1)` will both have columns named `x` and `V2`. In this release, the matrix case continues to be named `V1`, but the new behavior can be activated by setting `options(datatable.old.matrix.autoname)` to `FALSE`. See point 5 under Bug Fixes for more context; this change will provide more internal consistency as well as more consistency with `data.frame()`. @@ -157,6 +169,47 @@ As of now, adaptive rolling max has no _on-line_ implementation (`algo="fast"`), it uses a naive approach (`algo="exact"`). Therefore further speed up is still possible if `algo="fast"` gets implemented. +17. Function `frollapply` has been completely rewritten. Thanks to @jangorecki for implementation. Be sure to read `frollapply` manual before using the function. There are following changes: + - all basic types are now supported on input/output, not only double. Users' code could possibly break if it depends on forced coercion of input/output to double type. + - new argument `by.column` allowing to pass a multi-column subset of a data.table into a rolling function, closes [#4887](https://github.com/Rdatatable/data.table/issues/4887). + ```r + x = data.table(v1=rnorm(120), v2=rnorm(120)) + f = function(x) coef(lm(v2 ~ v1, data=x)) + coef.fill = c("(Intercept)"=NA_real_, "v1"=NA_real_) + frollapply(x, 4, f, by.column=FALSE, fill=coef.fill) + # (Intercept) v1 + # 1: NA NA + # 2: NA NA + # 3: NA NA + # 4: 0.65456931 0.3138012 + # 5: -1.07977441 -2.0588094 + #--- + #116: 0.15828417 0.3570216 + #117: -0.09083424 1.5494507 + #118: -0.18345878 0.6424837 + #119: -0.28964772 0.6116575 + #120: -0.40598313 0.6112854 + ``` + - uses multiple CPU threads (on a decent OS); evaluation of UDF is inherently slow so this can be a great help. + ```r + x = rnorm(1e5) + n = 500 + setDTthreads(1) + system.time( + th1 <- frollapply(x, n, median, simplify=unlist) + ) + # user system elapsed + # 3.078 0.005 3.084 + setDTthreads(4) + system.time( + th4 <- frollapply(x, n, median, simplify=unlist) + ) + # user system elapsed + # 2.453 0.135 0.897 + all.equal(th1, th4) + #[1] TRUE + ``` + ### BUG FIXES 1. `fread()` no longer warns on certain systems on R 4.5.0+ where the file owner can't be resolved, [#6918](https://github.com/Rdatatable/data.table/issues/6918). Thanks @ProfFancyPants for the report and PR. diff --git a/R/froll.R b/R/froll.R index 1d7a9829f5..2f834614b2 100644 --- a/R/froll.R +++ b/R/froll.R @@ -25,13 +25,23 @@ trimnadaptive = function(n, align) { # 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) { + ## do not quote argument x and n arg names because frollapply has them in uppercase if (!length(n)) stopf("n must be non 0 length") 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'") - len = if (is.list(x)) length(x[[1L]]) else length(x) + if (is.list(x)) { + if (!is.data.frame(x) && !equal.lengths(x)) ## froll + stopf("'partial' does not support variable length of columns in x") + else if (all_data.frame(x) && !equal.nrows(x)) ## frollapply by.column=F, single DT already wrapped into list + stopf("'partial' does not support variable nrow of data.tables in x") + } + len = if (is.list(x)) { + if (is.data.frame(x[[1L]])) ## frollapply by.column + nrow(x[[1L]]) + else ## froll, this will work for both x list and x dt on input + length(x[[1L]]) + } else length(x) verbose = getOption("datatable.verbose") if (!adaptive) { if (is.list(n)) @@ -39,7 +49,7 @@ partial2adaptive = function(x, n, align, adaptive) { if (!is.numeric(n)) stopf("n must be an integer vector or a list of integer vectors") if (verbose) - catf("partial2adaptive: froll partial=TRUE trimming 'n' and redirecting to adaptive=TRUE\n") + catf("partial2adaptive: froll partial=TRUE trimming n and redirecting to adaptive=TRUE\n") if (length(n) > 1L) { ## c(2,3) -> list(c(1,2,2,2),c(1,2,3,3)) ## for x=1:4 lapply(n, len, align, FUN=trimn) @@ -50,14 +60,14 @@ partial2adaptive = function(x, n, align, adaptive) { } else { 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 (length(unique(lengths(n))) != 1L) - stopf("adaptive window provided in 'n' must not to have different lengths") + if (is.list(n) && length(unique(lengths(n))) != 1L) + stopf("adaptive windows provided in n must not to have different lengths") if (is.numeric(n) && length(n) != len) - stopf("length of 'n' argument must be equal to number of observations provided in 'x'") + stopf("length of n argument must be equal to number of observations provided in x") if (is.list(n) && length(n[[1L]]) != len) - stopf("length of vectors in 'x' must match to length of adaptive window in 'n'") + stopf("length of vectors in x must match to length of adaptive window in n") if (verbose) - catf("partial2adaptive: froll adaptive=TRUE and partial=TRUE trimming 'n'\n") + catf("partial2adaptive: froll adaptive=TRUE and partial=TRUE trimming n\n") if (is.numeric(n)) { ## c(3,3,3,2) -> c(1,2,3,2) ## for x=1:4 trimnadaptive(n, align) @@ -93,7 +103,7 @@ make.roll.names = function(x.len, n.len, n, x.nm, n.nm, fun, adaptive) { if (length(n.nm)) { ## !adaptive || is.list(n) n.nm } else { ## adaptive && is.numeric(n) - NULL # nocov ## call to make.roll.names is excluded by is.list(ans) condition before calling it, it will be relevant for !by.column in next PR + stopf("internal error: make.roll.names call should have been escaped in frollapply during 'unpack atomic input'") # nocov ## frollapply(data.frame(x=1:5), rep(2,5), dim, by.column=FALSE, give.names=TRUE, adaptive=TRUE) } } if (!is.null(ans) && length(ans) != x.len*n.len) @@ -101,19 +111,27 @@ make.roll.names = function(x.len, n.len, n, x.nm, n.nm, fun, adaptive) { ans } -froll = function(fun, x, n, fill=NA, algo, align=c("right","left","center"), na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, FUN, rho, give.names=FALSE) { +froll = function(fun, x, n, fill=NA, algo=c("fast","exact"), align=c("right","left","center"), na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, give.names=FALSE, hasNA) { + stopifnot(!missing(fun), is.character(fun), length(fun)==1L, !is.na(fun)) + if (!missing(hasNA)) { + if (!is.na(has.nf)) + stopf("hasNA is deprecated, use has.nf instead") + warningf("hasNA is deprecated, use has.nf instead") + has.nf = hasNA + } # remove check on next major release + algo = match.arg(algo) align = match.arg(align) if (isTRUE(give.names)) { - orig = list(n=n, adaptive=adaptive) - xnam = if (is.list(x)) names(x) else character() - nnam = if (isTRUE(adaptive)) { - if (is.list(n)) names(n) else character() - } else names(n) - nx = if (is.list(x)) length(x) else 1L - nn = if (isTRUE(adaptive)) { - if (is.list(n)) length(n) else 1L - } else length(n) - } + orig = list(n=n, adaptive=adaptive) + xnam = if (is.list(x)) names(x) else character() + nnam = if (isTRUE(adaptive)) { + if (is.list(n)) names(n) else character() + } else names(n) + nx = if (is.list(x)) length(x) else 1L + nn = if (isTRUE(adaptive)) { + if (is.list(n)) length(n) else 1L + } else length(n) + } if (isTRUE(partial)) { n = partial2adaptive(x, n, align, adaptive) adaptive = TRUE @@ -128,10 +146,7 @@ froll = function(fun, x, n, fill=NA, algo, align=c("right","left","center"), na. n = rev2(n) align = "right" } ## support for left adaptive added in #5441 - if (missing(FUN)) - ans = .Call(CfrollfunR, fun, x, n, fill, algo, align, na.rm, has.nf, adaptive) - else - ans = .Call(CfrollapplyR, FUN, x, n, fill, align, adaptive, rho) + ans = .Call(CfrollfunR, fun, x, n, fill, algo, align, na.rm, has.nf, adaptive) if (leftadaptive) { if (verbose) catf("froll: adaptive=TRUE && align='left' post-processing from align='right'\n") @@ -144,30 +159,12 @@ froll = function(fun, x, n, fill=NA, algo, align=c("right","left","center"), na. ans } -frollfun = function(fun, x, n, fill=NA, algo=c("fast","exact"), align=c("right","left","center"), na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, hasNA, give.names=FALSE) { - stopifnot(!missing(fun), is.character(fun), length(fun)==1L, !is.na(fun)) - if (!missing(hasNA)) { - if (!is.na(has.nf)) - stopf("hasNA is deprecated, use has.nf instead") - warningf("hasNA is deprecated, use has.nf instead") - has.nf = hasNA - } # remove check on next major release - algo = match.arg(algo) - froll(fun=fun, x=x, n=n, fill=fill, algo=algo, align=align, na.rm=na.rm, has.nf=has.nf, adaptive=adaptive, partial=partial, give.names=give.names) -} - -frollmean = function(x, n, fill=NA, algo=c("fast","exact"), align=c("right","left","center"), na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, hasNA, give.names=FALSE) { - frollfun(fun="mean", x=x, n=n, fill=fill, algo=algo, align=align, na.rm=na.rm, has.nf=has.nf, adaptive=adaptive, partial=partial, hasNA=hasNA, give.names=give.names) +frollmean = function(x, n, fill=NA, algo=c("fast","exact"), align=c("right","left","center"), na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, give.names=FALSE, hasNA) { + froll(fun="mean", x=x, n=n, fill=fill, algo=algo, align=align, na.rm=na.rm, has.nf=has.nf, adaptive=adaptive, partial=partial, hasNA=hasNA, give.names=give.names) } -frollsum = function(x, n, fill=NA, algo=c("fast","exact"), align=c("right","left","center"), na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, hasNA, give.names=FALSE) { - frollfun(fun="sum", x=x, n=n, fill=fill, algo=algo, align=align, na.rm=na.rm, has.nf=has.nf, adaptive=adaptive, partial=partial, hasNA=hasNA, give.names=give.names) +frollsum = function(x, n, fill=NA, algo=c("fast","exact"), align=c("right","left","center"), na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, give.names=FALSE, hasNA) { + froll(fun="sum", x=x, n=n, fill=fill, algo=algo, align=align, na.rm=na.rm, has.nf=has.nf, adaptive=adaptive, partial=partial, hasNA=hasNA, give.names=give.names) } -frollmax = function(x, n, fill=NA, algo=c("fast","exact"), align=c("right","left","center"), na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, hasNA, give.names=FALSE) { - frollfun(fun="max", x=x, n=n, fill=fill, algo=algo, align=align, na.rm=na.rm, has.nf=has.nf, adaptive=adaptive, partial=partial, hasNA=hasNA, give.names=give.names) -} - -frollapply = function(x, n, FUN, ..., fill=NA, align=c("right","left","center"), adaptive=FALSE, partial=FALSE, give.names=FALSE) { - FUN = match.fun(FUN) - rho = new.env() - froll(FUN=FUN, rho=rho, x=x, n=n, fill=fill, align=align, adaptive=adaptive, partial=partial, give.names=give.names) +frollmax = function(x, n, fill=NA, algo=c("fast","exact"), align=c("right","left","center"), na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, give.names=FALSE, hasNA) { + froll(fun="max", x=x, n=n, fill=fill, algo=algo, align=align, na.rm=na.rm, has.nf=has.nf, adaptive=adaptive, partial=partial, hasNA=hasNA, give.names=give.names) } diff --git a/R/frollapply.R b/R/frollapply.R new file mode 100644 index 0000000000..2a8e9caa73 --- /dev/null +++ b/R/frollapply.R @@ -0,0 +1,397 @@ +## ansmask is to handle leading values from fill to match type of the ans +simplifylist = function(x, fill, ansmask) { + l = lengths(x) + ul = unique(l) + if (length(ul)!=1L) ## different lenghts + return(x) + t = vapply_1c(x, typeof, use.names=FALSE) + ut = unique(t) + if (length(ut)==2L) { + all.ut = ut + t = vapply_1c(x[ansmask], typeof, use.names=FALSE) + ut = unique(t) + if (length(ut)!=1L) + return(x) ## different typeof even excluding fill, a FUN was not type stable + if (!(ut=="integer"||ut=="logical"||ut=="double"||ut=="complex"||ut=="character"||ut=="raw")) + return(x) ## ans is not atomic + if (identical(fill, NA)) { ## different typeof, try to handle fill=NA logical type + filli = which(!ansmask) + ans1 = x[[which.first(ansmask)]] + x[filli] = rep_len(list(ans1[NA]), length(filli)) ## this will recycle to length of ans1 + } else if (all(c("integer","double") %in% all.ut)) { ## typeof numeric and int, fill is coerced to the type FUN + filli = which(!ansmask) + cast = if (ut=="double") as.numeric else as.integer + x[filli] = rep_len(list(cast(fill)), length(filli)) + } else { ## length == 2L but no easy way to match type + return(x) + } + } else if (length(ut)>2L) { ## unique typeof length > 2L + return(x) + } + if (ut=="integer"||ut=="logical"||ut=="double"||ut=="complex"||ut=="character"||ut=="raw") { + if (ul==1L) ## length 1 + return(unlist(x, recursive=FALSE, use.names=FALSE)) + else ## length 2+ + return(rbindlist(lapply(x, as.list))) + } else if (ut=="list") { + if (all(vapply_1b(x, is.data.frame, use.names=FALSE))) ## list(data.table(...), data.table(...)) + return(rbindlist(x)) + ll = lapply(x, lengths) ## length of each column of each x + ull = unique(ll) + if (length(ull)==1L) ## list(list(1:2, 1:2), list(2:3, 2:3)) + return(rbindlist(x)) + lu = function(x) length(unique(x)) + if (all(vapply_1i(ull, lu, use.names=FALSE)==1L)) ## within each x column lengths the same, each could be DF: list(list(1, 2), list(1:2, 2:3)) + return(rbindlist(x)) + } ## else NULL, closure, special, builtin, environment, S4, ... + x +} + +## parallel's fork serializes results so we need setalloccol +fixselfref = function(x) { + if (length(x) && is.data.table(x[[1L]])) { ## calling is.data.table many times always may be too much, so first we check only first element + dtmask = vapply_1b(x, is.data.table, use.names=FALSE) ## most likely all, but we cannot be sure that function is type stable + x[dtmask] = lapply(x[dtmask], setalloccol) + } + x +} + +all_atomic = function(x) all(vapply_1b(x, is.atomic, use.names=FALSE)) +all_data.frame = function(x) all(vapply_1b(x, is.data.frame, use.names=FALSE)) +all_list = function(x) all(vapply_1b(x, is.list, use.names=FALSE)) +equal.lengths = function(x) length(unique(lengths(x))) <= 1L +equal.nrows = function(x) length(unique(vapply(x, nrow, 0L))) <= 1L + +frollapply = function(X, N, FUN, ..., by.column=TRUE, fill=NA, align=c("right","left","center"), adaptive=FALSE, partial=FALSE, give.names=FALSE, simplify=TRUE, x, n) { + if (!missing(x)) { + warningf("'x' is deprecated in frollapply, use 'X' instead") + X = x + } + if (!missing(n)) { + warningf("'n' is deprecated in frollapply, use 'N' instead") + N = n + } + if (!isTRUEorFALSE(by.column)) + stopf("'by.column' must be TRUE or FALSE") + if (!isTRUEorFALSE(adaptive)) + stopf("'adaptive' must be TRUE or FALSE") + if (!isTRUEorFALSE(partial)) + stopf("'partial' must be TRUE or FALSE") + if (!isTRUEorFALSE(give.names)) + stopf("'give.names' must be TRUE or FALSE") + if (!isTRUEorFALSE(simplify) && !is.function(simplify)) + stopf("'simplify' must be TRUE or FALSE or a function") + + align = match.arg(align) + FUN = match.fun(FUN) + verbose = getOption("datatable.verbose") + if (give.names) + orig = list(N=N, adaptive=adaptive) + + ## by.column, x validation, x preprocess + if (by.column) { + if (is.atomic(X)) { + xvec = FALSE ## marker about form of input, used to unpack answer to vector + len = length(X) ## count of observations for deepest loop + nx = as.integer(as.logical(len)) ## top level loop for vectorized x + X = list(X) + xnam = character() ## used for give.names + } else if (is.list(X) && all_atomic(X)) { + xvec = TRUE + nx = length(X) + len = lengths(X) + xnam = names(X) + } else + stopf("frollapply by.column=TRUE requires 'X' argument to be atomic or a list of those") + } else { + list.df = FALSE + if (is.data.frame(X)) { + xvec = FALSE + len = nrow(X) + nx = as.integer(as.logical(len)) + X = list(X) + xnam = character() + } else if (is.list(X)) { + if (all_atomic(X)) { ## handles frollapply(.(col1, col2), ...) + if (!equal.lengths(X)) + stopf("frollapply by.column=FALSE, when provided a list in 'X' then all vectors must have equal lengths, like data.frame") + list.df = TRUE + xvec = FALSE + len = if (length(X)) length(X[[1L]]) else 0L + nx = as.integer(as.logical(len)) + X = list(X) + xnam = character() + } else if (all_data.frame(X)) { + if (!all(vapply_1b(X, all_atomic, use.names=FALSE))) + stopf("frollapply by.column=FALSE got vectorized input in 'X', list of data.frames/data.tables, but not all columns of data.frames/data.tables are atomic") + xvec = TRUE + len = vapply_1i(X, nrow, use.names=FALSE) + nx = length(X) + xnam = names(X) + } else if (all_list(X)) { ## vectorized input does not support lists as that would be ambiguous + stopf("frollapply by.column=FALSE supports vectorized input in 'X' as a list of data.frames/data.tables, not a list of lists. Turn nested lists into data.frames/data.table and retry.") + } else { ## mixed types + stopf("frollapply by.column=FALSE got list in 'X' but it is not valid one. If intent is to pass a list as non-vectorized input, but a single object to apply function to, then the list must have all its vectors atomic. For a vectorized input, passing multiple objects to apply function to, it must be a list of data.frames/data.tables.") + } + } else + stopf("frollapply by.column=FALSE requires 'X' argument to be a data.table/data.frame or a list of equal length vectors. For vectorized input can be a list of data.frames/data.tables, but not a list of lists. All columns/vectors must be atomic.") + } + ## adaptive, n validation, n preprocess + if (!length(N)) + stopf("'N' must be non 0 length") + if (!adaptive) { + if (is.list(N)) + stopf("'N' must be integer, list is accepted for adaptive TRUE") + else if (!is.numeric(N)) + stopf("'N' must be integer vector") + nnam = names(N) ## used for give.names + if (!is.integer(N)) + N = as.integer(N) + nn = length(N) ## top level loop for vectorized n + } else { + if (length(unique(len)) > 1L) ## vectorized x requires same nrow for adaptive + stopf("adaptive rolling function can only process 'X' having equal length of elements; If you want to call rolling function on list having variable length of elements call it for each field separately") + if (is.numeric(N)) { + if (length(N) != len[1L]) + stopf("length of integer vector(s) provided as list to 'N' argument must be equal to number of observations provided in 'X'") + if (!is.integer(N)) + N = as.integer(N) + nn = 1L + N = list(N) + nnam = character() + } else if (is.list(N)) { + if (length(N[[1L]])!=len[1L]) + stopf("length of integer vector(s) provided as list to 'N' argument must be equal to number of observations provided in 'X'") + if (!equal.lengths(N)) + stopf("adaptive windows provided in 'N' must not to have different lengths") + if (!all(vapply_1b(N, is.numeric, use.names=FALSE))) + stopf("n must be an integer vector or list of an integer vectors") + if (!all(vapply_1b(N, is.integer, use.names=FALSE))) + N = lapply(N, as.integer) + nn = length(N) + nnam = names(N) + } else + stopf("n must be an integer vector or list of an integer vectors") + } + ## partial + if (partial) { + N = partial2adaptive(X, N, align, adaptive) + if (!is.list(N)) + N = list(N) + adaptive = TRUE + } + ## left adaptive preprocess x and n + if (adaptive) { + if (align=="center") + stopf("using adaptive TRUE and align 'center' is not implemented") + leftadaptive = align=="left" + } else leftadaptive = FALSE + if (leftadaptive) { + if (verbose) + cat("frollapply: adaptive=TRUE && align='left' pre-processing for align='right'\n") + if (by.column) { + X = lapply(X, rev) + } else { + rev.d = function(d) { + l = lapply(d, rev) + if (is.data.table(d)) setDT(l) else if (is.data.frame(d)) setDF(l) else l + } + X = lapply(X, rev.d) + } + stopifnot(is.list(N)) ## internal + N = lapply(N, rev) + align = "right" + } + + ## prepare functions so we don't need to branch inside the loops, makes code in loops cleaner as well + ## only tight has to be optimized + if (!adaptive) { + cpy = copy + ansMask = function(len, n) { + mask = rep(TRUE, len) + mask[seq_len(n-1L)] = FALSE + mask + } + if (by.column) { + allocWindow = function(x, n) x[seq_len(n)] + tight = function(i, dest, src, n) FUN(.Call(CmemcpyVector, dest, src, i, n), ...) + } else { + if (!list.df) { + allocWindow = function(x, n) x[seq_len(n), , drop=FALSE] + } else { + allocWindow = function(x, n) lapply(x, `[`, seq_len(n)) + } + tight = function(i, dest, src, n) FUN(.Call(CmemcpyDT, dest, src, i, n), ...) + } + } else { + #has.growable = base::getRversion() >= "3.4.0" + ## this is now always TRUE + ## we keep this branch, it may be useful when getting rid of SET_GROWABLE_BIT and SETLENGTH #6180 + has.growable = TRUE + cpy = if (has.growable) function(x) .Call(Csetgrowable, copy(x)) else copy + ansMask = function(len, n) { + mask = seq_len(len) >= n + mask[is.na(mask)] = FALSE ## test 6010.206 + mask + } + if (by.column) { + allocWindow = function(x, n) x[seq_len(max(n, na.rm=TRUE))] + if (has.growable) { + tight = function(i, dest, src, n) FUN(.Call(CmemcpyVectoradaptive, dest, src, i, n), ...) + } else { + tight = function(i, dest, src, n) FUN(src[(i-n[i]+1L):i], ...) # nocov + } + } else { + if (!list.df) { + allocWindow = function(x, n) x[seq_len(max(n, na.rm=TRUE)), , drop=FALSE] + } else { + allocWindow = function(x, n) lapply(x, `[`, seq_len(max(n))) + } + if (has.growable) { + tight = function(i, dest, src, n) FUN(.Call(CmemcpyDTadaptive, dest, src, i, n), ...) + } else { + if (!list.df) { # nocov + tight = function(i, dest, src, n) FUN(src[(i-n[i]+1L):i, , drop=FALSE], ...) # nocov + } else { + tight = function(i, dest, src, n) FUN(lapply(src, `[`, (i-n[i]+1L):i), ...) # nocov + } + } + } + } + ## prepare templates for errors and warnings + err.collect = gettext("frollapply calling parallel::mccollect to collect results from forked processes raised an error.\n%s") + warn.collect = gettext("frollapply calling parallel::mccollect to collect results from forked processes raised a warning.\n%s") + if (is.function(simplify)) { + err.simplify = gettext("frollapply completed successfully but raised an error when attempting to simplify results using user specified function in 'simplify' argument. Be sure to provide 'fill' argument matching the type and shape of results returned by the your function. Use simplify=FALSE to obtain a list instead.\n%s") + warn.simplify = gettext("frollapply completed successfully but raised a warning when attempting to simplify results using user specified function in 'simplify' argument. Be sure to provide 'fill' argument matching the type and shape of results returned by the your function. Use simplify=FALSE to obtain a list instead.\n%s") + } else if (isTRUE(simplify)) { + err.simplify = gettext("frollapply completed successfully but raised an error when attempting to simplify results using our internal 'simplifylist' function. Be sure to provide 'fill' argument matching the type and shape of results returned by the your function. Use simplify=FALSE to obtain a list instead. If you believe your results could be automatically simplified please submit your use case as new issue in our issue tracker.\n%s") + warn.simplify = gettext("frollapply completed successfully but raised a warning when attempting to simplify results using our internal 'simplifylist' function. Be sure to provide 'fill' argument matching the type and shape of results returned by the your function. Use simplify=FALSE to obtain a list instead. If you believe your results could be automatically simplified please submit your use case as new issue in our issue tracker.\n%s") + } + + DTths = getDTthreads(FALSE) + use.fork = .Platform$OS.type!="windows" && DTths > 1L + if (verbose) { + if (use.fork) cat("frollapply running on multiple CPU threads using parallel::mcparallel\n") + else cat("frollapply running on single CPU thread\n") + } + ans = vector("list", nx*nn) + ## vectorized x + for (i in seq_len(nx)) { + thisx = X[[i]] + thislen = len[i] + if (!thislen) + next + ## vectorized n + for (j in seq_len(nn)) { + thisn = N[[j]] + w = allocWindow(thisx, thisn) ## prepare window, handles adaptive + ansmask = ansMask(thislen, thisn) + ansi = which(ansmask) + if (use.fork) { ## !windows && getDTthreads()>1L + ths = min(DTths, length(ansi)) + ii = split(ansi, sort(rep_len(seq_len(ths), length(ansi)))) ## assign row indexes to threads + jobs = vector("integer", ths) + for (th in seq_len(ths)) { + jobs[th] = parallel::mcparallel({ + #catf("%d\n", 4, "") + # nocov start ## fork processes seem not to be tracked by codecov, at least when parallel not in suggests + setDTthreads(1L) ## disable nested parallelism + lapply(ii[[th]], ## loops over indexes for that thread + FUN = tight, ## handles adaptive and by.column + dest = cpy(w), ## allocate own window for each thread, if we would not copy here, then copy would be handled later on by fork's copy-on-write + src = thisx, ## full input + n = thisn) ## scalar or in adaptive case a vector + # nocov end + })[["pid"]] + } + if (length(ansi)) { + fork.res = withCallingHandlers( ## collect results early to minimize time when user could raise SIGINT + tryCatch( + parallel::mccollect(jobs), + error = function(e) stopf(err.collect, e[["message"]]), + warning = function(w) warningf(warn.collect, w[["message"]]) + ), + interrupt = function(e) { + # nocov start + suspendInterrupts({ + lapply(jobs, function(pid) try(tools::pskill(pid), silent = TRUE)) + parallel::mccollect(jobs, wait = FALSE) + }) + invokeRestart("abort") ## raise SIGINT + # nocov end + } + ) + ## check for any errors in FUN, warnings are silently ignored + fork.err = vapply_1b(fork.res, inherits, "try-error", use.names = FALSE) + if (any(fork.err)) { + stopf( + "frollapply received an error(s) when evaluating FUN:\n%s", + paste(unique(vapply_1c(fork.res[fork.err], function(err) attr(err, "condition", TRUE)[["message"]], use.names = FALSE)), collapse = "\n") + ) + } + thisans = unlist(fork.res, recursive = FALSE, use.names = FALSE) + ## fix selfref after serializing data.table from forked process + thisans = fixselfref(thisans) + } + } else { ## windows || getDTthreads()==1L + h = list2env(list(warning=NULL, error=NULL)) ## pretty printing errors/warnings + oldDTthreads = setDTthreads(1L) ## for consistency, anyway window size is unlikely to be big enough to benefit any parallelism + withCallingHandlers( + tryCatch( + thisans <- lapply(ansi, FUN = tight, dest = cpy(w), src = thisx, n = thisn), + error = function(e) h$err = conditionMessage(e) + ), warning = function(w) {h$warn = c(h$warn, conditionMessage(w)); invokeRestart("muffleWarning")} + ) + setDTthreads(oldDTthreads) + if (!is.null(h$warn)) + warningf("frollapply received a warning(s) when evaluating FUN:\n%s", paste(unique(h$warn), collapse="\n")) + if (!is.null(h$err)) + stopf("frollapply received an error(s) when evaluating FUN:\n%s", h$err) + } + ## align + if (leftadaptive) { + ansmask = rev(ansmask) + ansi = which(ansmask) + } else if (align!="right") { ## must be non-adaptive bc adaptive don't support align=center + ansmask = shift(ansmask, if (align=="left") 1L-thisn else -floor(thisn/2L), fill=FALSE, type="shift") + ansi = which(ansmask) + } + ## fill + thisansi = (i-1L)*nn+j + ans[[thisansi]] = vector("list", thislen) + filli = which(!ansmask) + ans[[thisansi]][filli] = rep_len(list(fill), length(filli)) + if (length(ansi)) { + if (leftadaptive) + thisans = rev(thisans) + ans[[thisansi]][ansi] = thisans + } + ## simplify + if (is.function(simplify)) { + ans[[thisansi]] = tryCatch( + simplify(ans[[thisansi]]), + error = function(e) stopf(err.simplify, e[["message"]]), + warning = function(w) warningf(warn.simplify, w[["message"]]) + ) + } else if (isTRUE(simplify)) { + ans[[thisansi]] = tryCatch( + simplifylist(ans[[thisansi]], fill, ansmask), + error = function(e) stopf(err.simplify, e[["message"]]), + warning = function(w) warningf(warn.simplify, w[["message"]]) + ) + } + } + } + + ## preparing output format + if (length(ans)) { + if (!xvec && length(ans)==1L) { + ans = ans[[1L]] ## unpack atomic input + } else if (give.names) { + nms = make.roll.names(x.len=nx, n.len=nn, n=orig$N, x.nm=xnam, n.nm=nnam, fun="apply", adaptive=orig$adaptive) + setattr(ans, "names", nms) + } + } + ans +} diff --git a/inst/tests/froll.Rraw b/inst/tests/froll.Rraw index ee89788cf0..080fccd2d5 100644 --- a/inst/tests/froll.Rraw +++ b/inst/tests/froll.Rraw @@ -7,7 +7,6 @@ if (exists("test.data.table", .GlobalEnv, inherits=FALSE)) { require(data.table) test = data.table:::test froll = data.table:::froll - frollfun = data.table:::frollfun } exact_NaN = isTRUE(capabilities()["long.double"]) && identical(as.integer(.Machine$longdouble.digits), 64L) @@ -93,8 +92,8 @@ test(6000.017, frollmean(x, "a"), error="n must be integer") test(6000.018, frollmean(x, factor("a")), error="n must be integer") test(6000.019, frollmean(x, TRUE), error="n must be integer") test(6000.020, frollmean(x, list(1:10)), error="n must be integer, list is accepted for adaptive TRUE") -test(6000.021, frollmean(x, list(NA), adaptive=TRUE), error="n must be integer vector or list of integer vectors") -test(6000.022, frollmean(x, list(c(1:5,1:5), NA), adaptive=TRUE), error="n must be integer vector or list of integer vectors") +test(6000.021, frollmean(x, list(NA), adaptive=TRUE), error="n must be an integer vector or list of an integer vectors") +test(6000.022, frollmean(x, list(c(1:5,1:5), NA), adaptive=TRUE), error="n must be an integer vector or list of an integer vectors") test(6000.0221, frollmean(1:2, list(c(0L, 0L)), adaptive=TRUE), error="n must be positive integer values") #### various length list vectors @@ -455,7 +454,7 @@ test(6000.1197, frollmean(c(1:5,NA), 2, algo="exact", na.rm=TRUE), output=c( )) options(datatable.verbose=FALSE) #### adaptive=TRUE n=character -test(6000.1198, frollmean(1:5, n=letters[1:5], adaptive=TRUE), error="n must be integer vector or list of integer vectors") +test(6000.1198, frollmean(1:5, n=letters[1:5], adaptive=TRUE), error="n must be an integer vector or list of an integer vectors") #### non-finite values (NA, NaN, Inf, -Inf) ma = function(x, n, na.rm=FALSE, nf.rm=FALSE) { @@ -1025,19 +1024,20 @@ 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 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.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.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 an integer, list is accepted for adaptive TRUE") -test(6006.907, frollsum(1:4, integer(), partial = TRUE), error = "n must be non 0 length") +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(list(data.table(v1=1:4), data.table(v1=1:3)), n, partial=TRUE), error="'partial' does not support variable nrow of data.tables in x") +test(6006.906, frollmean(x, TRUE, partial=TRUE), error="n must be an integer") +test(6006.907, frollmean(x, list(TRUE), partial=TRUE), error="n must be an integer, list is accepted for adaptive TRUE") +test(6006.908, frollsum(1:4, integer(), partial = TRUE), error = "n must be non 0 length") ## 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.9301, frollmean(1:4, list(1:4, 1:3), adaptive=TRUE, partial=TRUE), error="adaptive windows 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)) @@ -1050,7 +1050,7 @@ test(6006.9332, frollsum(1:4, c(2,4,5,6), align="left", adaptive=TRUE, partial=T 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)) test(6006.9335, frollsum(1:4, list(c(1,1,3,2), c("a","b","c","d")), adaptive=TRUE, partial=TRUE), error = "n must be an integer vector or a list of integer vectors") -test(6006.9336, frollsum(1:4, c(1,2,3), adaptive=TRUE, partial=TRUE), error = "length of 'n' argument must be equal to number of observations provided in 'x'") +test(6006.9336, frollsum(1:4, c(1,2,3), adaptive=TRUE, partial=TRUE), error = "length of n argument must be equal to number of observations provided in x") ## give.names test(6006.9511, frollsum(c(1,2,3), 2, give.names=TRUE), c(NA,3,5)) @@ -1120,8 +1120,376 @@ test(6006.9967, frollsum(list(c(1,2,3)), c(2,2,2), adaptive=TRUE, partial=TRUE, test(6006.9968, frollsum(list(c(1,2,3)), list(n1=c(2,2,2)), adaptive=TRUE, partial=TRUE, give.names=TRUE), list(V1_n1=c(1,3,5))) test(6006.9969, frollsum(list(x1=c(1,2,3)), list(n1=c(2,2,2)), adaptive=TRUE, partial=TRUE, give.names=TRUE), list(x1_n1=c(1,3,5))) -## validation +## frollapply +x = as.double(1:10) +test(6010.001, frollsum(x, 3L), frollapply(x, 3L, sum)) +test(6010.002, frollsum(x, 6), frollapply(x, 6, sum)) +test(6010.003, frollmean(x, 3), frollapply(x, 3, mean)) +d = as.data.table(list(1:6/2, 3:8/4)) +test(6010.004, frollsum(d, 3:4), frollapply(d, 3:4, sum)) +test(6010.005, frollmean(d, 3:4), frollapply(d, 3:4, mean)) +d = rbind(d, list(NA,NA)) +ans = list(c(NA,NA,1.5,2,1.5,2,2.5), c(NA,NA,NA,2,1,1.5,2), c(NA,NA,1.25,1.5,1.75,1.5,2), c(NA,NA,NA,1.5,1,1.25,1.5)) +test(6010.006, frollapply(d, 3:4, function(x, ...) if (sum(x, ...)>5) min(x, ...) else max(x, ...), na.rm=TRUE), ans) +# segfault and protect limits #3993 - disabled by default due to high memory usage +if (FALSE) { + test(6010.007, frollapply(1, rep(1L, 1e5), identity), as.list(rep(1, 1e5))) + test(6010.008, frollapply(1, rep(1L, 1e6), identity), as.list(rep(1, 1e6))) + test(6010.009, frollapply(as.list(rep(1, 1e6)), 1, identity), as.list(rep(1, 1e6))) +} +## check documented side effect of noalloc optimization +rollapply = function(x, n, FUN, fill=NA) { + ans = vector("list", length(x)) + if (n>1L) ans[1L:(n-1L)] = as.list(rep(fill, n-1L)) + for (i in n:length(x)) ans[[i]] = FUN(x[(i-n+1L):i]) + ans +} +old = setDTthreads(1L) +test(6010.011, frollapply(c(1, 9), 1L, FUN=identity, simplify=FALSE), list(9,9)) +test(6010.012, frollapply(c(1, 9), 1L, FUN=list, simplify=FALSE), list(list(9),list(9))) +test(6010.013, frollapply(c(1, 9), 1L, FUN=function(x) copy(identity(x)), simplify=FALSE), list(1,9)) +test(6010.014, frollapply(c(1, 9), 1L, FUN=function(x) copy(list(x)), simplify=FALSE), list(list(1),list(9))) +test(6010.015, frollapply(c(1, 9), 1L, FUN=function(x) copy(identity(x)), simplify=FALSE), rollapply(c(1, 9), n=1L, identity)) +test(6010.016, frollapply(c(1, 9), 1L, FUN=function(x) copy(list(x)), simplify=FALSE), rollapply(c(1, 9), n=1L, list)) +setDTthreads(old) +#### test disabling parallelism +use.fork = .Platform$OS.type!="windows" && getDTthreads()>1L +if (use.fork) { + options(datatable.verbose=TRUE) + test(6010.021, frollapply(1:2, 1, identity), 1:2, output="running on multiple CPU threads using parallel::mcparallel") + options(datatable.verbose=FALSE) + test(6010.022, frollapply(1:2, 1, function(x) {warning("warn"); x}), 1:2) ## warning ignored + test(6010.023, frollapply(1:2, 1, function(x) {stop("err:", tail(x,1)); x}), error="err:1\nerr:2") + test(6010.024, frollapply(1:2, 1, function(x) stop("err")), error="err") ## unique error +} +old = setDTthreads(1L) +options(datatable.verbose=TRUE) +test(6010.025, frollapply(1:2, 1, identity), c(2L,2L), output="running on single CPU thread") +options(datatable.verbose=FALSE) +test(6010.026, frollapply(1:2, 1, function(x) {warning("warn"); x}), c(2L,2L), warning="warn") +test(6010.027, frollapply(1:2, 1, function(x) {warning("warn:", tail(x,1)); x}), c(2L,2L), warning="warn:1\nwarn:2") +test(6010.028, frollapply(1:2, 1, function(x) {stop("err:", tail(x,1)); x}), error="err:1") ## only first +setDTthreads(old) + +#### corner cases from examples - handled properly after frollapply rewrite to R +test(6010.101, frollapply(1:5, 3, function(x) head(x, 2)), list(NA, NA, 1:2, 2:3, 3:4)) +f = function(x) { + n = length(x) + # length 1 will be returned only for first iteration where we check length + if (n==x[n]) x[1L] else range(x) # range(x)[2L] is silently ignored +} +test(6010.102, frollapply(1:5, 3, f), list(NA,NA,1L,c(2L,4L),c(3L,5L))) +test(6010.103, frollapply(c(1,2,1,1,1,2,3,2), 3, uniqueN), c(NA,NA,2L,2L,1L,2L,3L,2L)) +test(6010.104, frollapply(c(1,2,1,1,NA,2,NA,2), 3, anyNA), c(NA,NA,FALSE,FALSE,TRUE,TRUE,TRUE,TRUE)) +f = function(x) { + n = length(x) + # double type will be returned only for first iteration where we check type + if (n==x[n]) 1 else NA # NA logical turns into garbage without coercion to double +} +test(6010.105, head(frollapply(1:5, 3, f), 3L), list(NA, NA, 1)) + +## partial +x = 1:6/2 +n = 3 +an = function(n, len) c(seq.int(n), rep(n, len-n)) +test(6010.111, frollapply(FUN=mean, x, an(n, length(x)), adaptive=TRUE), c(0.5,0.75,1,1.5,2,2.5)) +test(6010.112, frollapply(FUN=mean, x, n, partial=TRUE), c(0.5,0.75,1,1.5,2,2.5)) +ans = frollapply(FUN=mean, x, n) +ans[seq.int(n-1L)] = frollapply(FUN=mean, x[seq.int(n-1L)], n, partial=TRUE) +test(6010.113, ans, c(0.5,0.75,1,1.5,2,2.5)) +test(6010.121, frollapply(FUN=mean, x, rev(an(rev(n), length(x))), adaptive=TRUE, align="left"), c(1,1.5,2,2.5,2.75,3)) +test(6010.122, frollapply(FUN=mean, x, n, partial=TRUE, align="left"), c(1,1.5,2,2.5,2.75,3)) +ans = frollapply(FUN=mean, x, n, align="left") +ans[(length(x)-n-1L):length(x)] = frollapply(FUN=mean, x[(length(x)-n-1L):length(x)], n, partial=TRUE, align="left") +test(6010.123, 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(6010.131, frollapply(FUN=mean, 1:6/2, list(3L,4L), partial=TRUE), error="'N' must be integer, list is accepted for adaptive TRUE") +test(6010.132, frollapply(FUN=mean, 1:6/2, 3:4, partial=TRUE), ans) +test(6010.143, frollapply(FUN=mean, 1:4, 2L, align="center", partial=TRUE), error="'partial' cannot be used together with align='center'") +test(6010.144, frollapply(FUN=mean, list(1:4, 2:4), n, partial=TRUE), error="'partial' does not support variable length of columns in x") +test(6010.145, frollapply(FUN=mean, x, TRUE, partial=TRUE), error="'N' must be integer vector") +test(6010.146, frollapply(FUN=mean, x, list(TRUE), partial=TRUE), error="'N' must be integer, list is accepted for adaptive TRUE") +## growable failed if length was set after copy: attempt to set index 1/1 in SET_STRING_ELT +old = setDTthreads(1L) +test(6010.150, frollapply(c("B","B","C"), 3, unique, simplify=FALSE, partial=TRUE), list("B", "B", c("B","C"))) +setDTthreads(old) + +# frollapply adaptive +test(6010.2011, frollapply(1:3, c(3,3,3), sum, adaptive=TRUE), c(NA,NA,6L)) +test(6010.2012, frollapply(1:3, c(4,4,4), sum, adaptive=TRUE), rep(NA,3)) # none of the windows in k was small enough to cover length of x +test(6010.2013, frollapply(1:5, rep(2, 5), mean, adaptive=NA), error="'adaptive' must be TRUE or FALSE") +test(6010.2014, frollapply(1:5, rep(3, 5), toString, adaptive=TRUE), c(NA,NA,"1, 2, 3","2, 3, 4","3, 4, 5")) +test(6010.2015, frollapply(1:2, 1:2, mean, adaptive=TRUE, align="right"), c(1, 1.5)) +test(6010.2016, frollapply(1:2, 1:2, mean, adaptive=TRUE, align="center"), error="using adaptive TRUE and align 'center' is not implemented") +test(6010.2017, frollapply(list(1:2, 1:3), list(1:2), mean, adaptive=TRUE), error="adaptive rolling function can only process 'X' having equal length of elements; If you want to call rolling function on list having variable length of elements call it for each field separately") +test(6010.2018, frollapply(1:5, rep(3, 5), function(x) head(x, 2), adaptive=TRUE), list(NA, NA, 1:2, 2:3, 3:4)) +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.202, 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'") +options(datatable.verbose=TRUE) +test(6010.2021, 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="processing for align='right'") +options(datatable.verbose=FALSE) +test(6010.203, frollapply(c(1,2,1,1,1,2,3,2), rep(3, 8), uniqueN, adaptive=TRUE), c(NA,NA,2L,2L,1L,2L,3L,2L)) +test(6010.204, frollapply(c(1,2,1,1,NA,2,NA,2), rep(3, 8), anyNA, adaptive=TRUE), c(NA,NA,FALSE,FALSE,TRUE,TRUE,TRUE,TRUE)) +test(6010.205, frollapply(c(2,2,2,3,4), c(1,3,3,2,3), uniqueN, adaptive=TRUE), c(1L,NA,1L,2L,3L)) ## window width bigger than location +test(6010.206, frollapply(1:5, c(NA,NA,3,2,3), sum, adaptive=TRUE), c(NA,NA,6L,7L,12L)) ## NAs in adaptive window are ok + +#### test coverage +test(6010.501, frollapply(1:3, "b", sum), error="'N' must be integer") +test(6010.503, frollapply(1:3, integer(), sum), error="'N' must be non 0 length") +test(6010.504, frollapply(1:3, 2L, sum, fill=1:2), list(1:2, 3L, 5L)) +test(6010.505, frollapply(1:3, 2L, sum, fill=NA_integer_), c(NA,3L,5L)) +test(6010.506, frollapply(1:3, 2L, sum, fill=-1L), c(-1L,3L,5L)) +test(6010.5071, frollapply(1:3, 2L, sum, fill=-2), c(-2L,3L,5L)) +test(6010.5072, frollapply(1:3, 2L, sum, fill=-2L), c(-2L,3L,5L)) +test(6010.508, frollapply(1:3, 2L, sum, fill="z"), list("z",3L,5L)) +test(6010.509, frollapply(1:3, 4L, sum), c(NA,NA,NA)) +test(6010.510, frollapply(1:5, 3L, sum), c(NA,NA,6L,9L,12L)) +test(6010.511, frollapply(1:5, 3L, sum, align="center"), c(NA,6L,9L,12L,NA)) +test(6010.512, frollapply(1:5, 3L, sum, align="left"), c(6L,9L,12L,NA,NA)) +test(6010.513, frollapply(1:5, 4L, sum), c(NA,NA,NA,10L,14L)) +test(6010.514, frollapply(1:5, 4L, sum, align="center"), c(NA,10L,14L,NA,NA)) +test(6010.515, frollapply(1:5, 4L, sum, align="left"), c(10L,14L,NA,NA,NA)) +test(6010.516, frollapply(1:6, 3L, sum), c(NA,NA,6L,9L,12L,15L)) +test(6010.517, frollapply(1:6, 3L, sum, align="center"), c(NA,6L,9L,12L,15L,NA)) +test(6010.518, frollapply(1:6, 3L, sum, align="left"), c(6L,9L,12L,15L,NA,NA)) +test(6010.519, frollapply(1:6, 4L, sum), c(NA,NA,NA,10L,14L,18L)) +test(6010.520, frollapply(1:6, 4L, sum, align="center"), c(NA,10L,14L,18L,NA,NA)) +test(6010.521, frollapply(1:6, 4L, sum, align="left"), c(10L,14L,18L,NA,NA,NA)) +test(6010.522, frollapply(c(1:3,NA,5:6), 4L, sum), rep(NA_integer_,6)) +test(6010.523, frollapply(c(1:3,NA,5:6), 4L, sum, na.rm=TRUE), c(NA,NA,NA,6L,10L,14L)) +test(6010.524, frollapply(c(1,2,3,NA,NA,NA,NA), 3L, mean), c(NA,NA,2,NA,NA,NA,NA)) +test(6010.525, frollapply(c(1,2,3,NA,NA,NA,NA), 3L, mean, na.rm=TRUE), c(NA,NA,2,2.5,3,NaN,NaN)) +test(6010.526, frollapply(numeric(), 3L, sum), list()) +test(6010.527, frollapply(1:5, 3L, toString), c(NA, NA, "1, 2, 3", "2, 3, 4", "3, 4, 5")) +ma = function(x, n, na.rm=FALSE) { + ans = rep(NA_real_, nx<-length(x)) + for (i in n:nx) ans[i]=mean(x[(i-n+1L):i], na.rm=na.rm) + ans +} +n = 4L +x = as.double(1:16) +x[5] = NaN +test(6010.531, frollapply(x, n, mean), ma(x, n)) +x[6] = NA +test(6010.532, frollapply(x, n, mean), ma(x, n)) +x[5] = NA +x[6] = NaN +test(6010.533, frollapply(x, n, mean), ma(x, n)) +x[5] = Inf +test(6010.534, frollapply(x, n, mean), ma(x, n)) +x[6] = -Inf +test(6010.535, frollapply(x, n, mean), ma(x, n)) +x[5:7] = c(NA, Inf, -Inf) +test(6010.536, frollapply(x, n, mean), ma(x, n)) +#### error from invalid args +test(6010.541, frollapply(1:2, 2, sum, by.column=NA), error="must be TRUE or FALSE") +test(6010.542, frollapply(1:2, 2, sum, adaptive=NA), error="must be TRUE or FALSE") +test(6010.543, frollapply(1:2, 2, sum, partial=NA), error="must be TRUE or FALSE") +test(6010.544, frollapply(1:2, 2, sum, give.names=NA), error="must be TRUE or FALSE") +test(6010.545, frollapply(1:2, 2, sum, simplify=NA), error="must be TRUE or FALSE or a function") +test(6010.561, frollapply(x=1:2, N=2, FUN=sum), c(NA,3L), warning="'x' is deprecated in frollapply, use 'X' instead") +test(6010.562, frollapply(X=1:2, n=2, FUN=sum), c(NA,3L), warning="'n' is deprecated in frollapply, use 'N' instead") +test(6010.563, frollapply(x=1:2, n=2, FUN=sum), c(NA,3L), warning=c("'x' is deprecated in frollapply, use 'X' instead","'n' is deprecated in frollapply, use 'N' instead")) +test(6010.564, frollapply(1:2, c("a","a"), length, adaptive=TRUE), error="n must be an integer vector or list of an integer vectors") +test(6010.565, frollapply(1:2, list(c("a","a")), length, adaptive=TRUE), error="n must be an integer vector or list of an integer vectors") +test(6010.566, frollapply(1:2, 2, length, by.column=FALSE), error="frollapply by.column=FALSE requires 'X' argument to be") +test(6010.567, frollapply(list(1:2, list(c("a","b"))), 2, length, by.column=FALSE), error="frollapply by.column=FALSE got list in 'X' but it is not valid one") +test(6010.568, frollapply(list(data.frame(x=1:2), data.frame(x=I(list(1:2)))), 2, length, by.column=FALSE), error="not all columns of data.frames/data.tables are atomic") +test(6010.569, frollapply(list(1:2, sum), 2, length), error="argument to be atomic or a list of those") + +## by.column +x = data.table(v1=1:5, v2=2:6/2) +test(6010.601, frollapply(x, 3, dim, by.column=FALSE, fill=c(rows=NA_integer_, cols=NA_integer_)), data.table(rows=c(NA,NA,3L,3L,3L), cols=c(NA,NA,2L,2L,2L))) +test(6010.602, frollapply(x, 3, FUN=tail, 1L, by.column=FALSE, fill=data.table(v1=NA_integer_, v2=NA_real_)), copy(x)[1:2, names(x) := NA]) +test(6010.603, frollapply(x, 3, FUN=tail, 1L, by.column=FALSE, partial=TRUE), x) +test(6010.604, frollapply(x, 3, dim, by.column=FALSE, partial=TRUE), data.table(V1=c(1:3,3L,3L), V2=c(2L,2L,2L,2L,2L))) ## fill is not used in partial +test(6010.605, frollapply(x, 3, function(x) setNames(dim(x), c("rows","cols")), by.column=FALSE, partial=TRUE), data.table(rows=c(1:3,3L,3L), cols=c(2L,2L,2L,2L,2L))) +test(6010.606, frollapply(x, rep(3,5), dim, by.column=FALSE, fill=c(rows=NA_integer_, cols=NA_integer_), adaptive=TRUE, align="left"), data.table(rows=c(3L,3L,3L,NA,NA), cols=c(2L,2L,2L,NA,NA))) +test(6010.6061, frollapply(as.data.frame(x), rep(3,5), dim, by.column=FALSE, fill=c(rows=NA_integer_, cols=NA_integer_), adaptive=TRUE, align="left", simplify=function(x) as.data.frame(do.call("rbind",x))), data.frame(rows=c(3L,3L,3L,NA,NA), cols=c(2L,2L,2L,NA,NA))) +test(6010.6062, frollapply(as.list(x), rep(3,5), function(x) c(length(x[[1L]]), length(x)), by.column=FALSE, fill=c(rows=NA_integer_, cols=NA_integer_), adaptive=TRUE, align="left", simplify=function(x) setNames(transpose(x), c("rows","cols"))), list(rows=c(3L,3L,3L,NA,NA), cols=c(2L,2L,2L,NA,NA))) + +#### empty input +test(6010.607, frollapply(list(), 3, identity, by.column=FALSE), list()) +test(6010.608, frollapply(list(numeric(), numeric()), 3, identity, by.column=FALSE), list()) +test(6010.609, frollapply(list(numeric(), 1:3), 3, identity, by.column=FALSE), error="all vectors must have equal lengths") +test(6010.610, frollapply(numeric(), 3, identity), list()) +test(6010.611, frollapply(list(numeric(), numeric()), 3, identity), list(NULL,NULL)) +test(6010.612, frollapply(list(numeric(), 1:3), 3, identity), list(NULL, list(NA,NA,1:3))) + +#### list input in frollapply +DT = as.data.table(iris) +test(6010.620, ## list()/.() same as data.frame() + DT[, frollapply(.(Sepal.Length, Sepal.Width), 3, function(l) list(l[[1L]][1L], l[[2L]][1L]), fill=list(NA,NA), by.column=FALSE)], + DT[, frollapply(data.frame(Sepal.Length, Sepal.Width), 3, function(l) list(l[[1L]][1L], l[[2L]][1L]), fill=list(NA,NA), by.column=FALSE)]) +rm(DT) +flow = function(x) { + v1 = x[[1L]] + v2 = x[[2L]] + (v1[2L] - v1[1L] * (1+v2[2L])) / v1[1L] +} +idx = c(1:2, 51:52, 101:102) +ans = c(NA, -3.03921568627451, NA, -3.28571428571429, NA, -2.77936507936508) +test(6010.621, as.data.table(iris)[, "flow" := frollapply(.(Sepal.Length, Sepal.Width), 2L, flow, by.column=FALSE), by = Species]$flow[idx], ans) +test(6010.622, as.data.table(iris)[, "flow" := frollapply(data.frame(Sepal.Length, Sepal.Width), 2L, flow, by.column=FALSE), by = Species]$flow[idx], ans) +test(6010.623, as.data.table(iris)[, "flow" := unlist(lapply(split(data.frame(Sepal.Length, Sepal.Width), Species), frollapply, 2L, flow, by.column=FALSE))]$flow[idx], ans) +f = function(l) as.list(range(l[[1L]])-range(l[[2L]])) +test(6010.624, frollapply(list(1:5, 5:1), c(2,2,3,3,4), f, adaptive=TRUE, by.column=FALSE, fill=list(NA,NA)), data.table(V1=c(NA,-3L,-2L,0L,1L), V2=c(NA,-3L,-2L,0L,1L))) +test(6010.625, frollapply(list(1:5, 5:1), c(2,2,3,3,4), f, align="left", adaptive=TRUE, by.column=FALSE, fill=list(NA,NA)), data.table(V1=c(-3L,-1L,2L,NA,NA), V2=c(-3L,-1L,2L,NA,NA))) +#### list of df/lists +x = list(data.table(x=1:2, y=2:3), data.table(z=3:5)) +test(6010.631, frollapply(x, 2, tail, 1, by.column=FALSE, fill=data.table(), simplify=function(x) rbindlist(x, fill=TRUE)), list(data.table(x=2L, y=3L), data.table(z=4:5))) +test(6010.632, frollapply(x, 2:3, tail, 1, by.column=FALSE, fill=data.table(), simplify=function(x) rbindlist(x, fill=TRUE)), list(data.table(x=2L, y=3L), data.table(NULL), data.table(z=4:5), data.table(z=5L))) +x = lapply(x, as.list) +test(6010.633, frollapply(x, 2, tail, 1, by.column=FALSE, fill=list()), error="supports vectorized input") + +#### lm +f = function(x) coef(lm(v2 ~ v1, data=x)) +coef.fill = c("(Intercept)"=NA_real_, "v1"=NA_real_) +test(6010.651, frollapply(data.table(v1=1:5, v2=2:6/2), 3, f, by.column=FALSE, fill=coef.fill), data.table("(Intercept)"=c(NA,NA,0.5,0.5,0.5), "v1"=c(NA,NA,0.5,0.5,0.5))) +test(6010.652, frollapply(data.table(v1=1:5, v2=2:6), 3, f, by.column=FALSE, fill=coef.fill), data.table("(Intercept)"=c(NA,NA,1,1,1), "v1"=c(NA,NA,1,1,1))) +## vectorized input for by.column=FALSE +X = list(data1 = data.table(v1=1:5, v2=2:6/2), data2 = data.table(v1=1:5, v2=2:6)) +n = c(small = 3, big = 4) +ans = list(data1_small = data.table("(Intercept)"=c(NA,NA,0.5,0.5,0.5), "v1"=c(NA,NA,0.5,0.5,0.5)), + data1_big = data.table("(Intercept)"=c(NA,NA,NA,0.5,0.5), "v1"=c(NA,NA,NA,0.5,0.5)), + data2_small = data.table("(Intercept)"=c(NA,NA,1,1,1), "v1"=c(NA,NA,1,1,1)), + data2_big = data.table("(Intercept)"=c(NA,NA,NA,1,1), "v1"=c(NA,NA,NA,1,1))) +test(6010.653, y = ans, x = lapply( + FUN = function(x) x[, names(x) := lapply(.SD, round, 8L)], ## otherwise we get 0.500...0001 and that fails test() when input is a list + frollapply(X, n, f, by.column=FALSE, fill=coef.fill, give.names=TRUE) +)) +rm(X, ans, n) + +## simplify simplifyList +test(6010.701, frollapply(1:5, 2, sum), c(NA,3L,5L,7L,9L)) +test(6010.702, frollapply(1:5, 2, sum, simplify=unlist), c(NA,3L,5L,7L,9L)) +test(6010.703, frollapply(1:5, 2, sum, simplify=FALSE), list(NA,3L,5L,7L,9L)) +test(6010.704, frollapply(1:5, 2, range), list(NA,1:2,2:3,3:4,4:5)) ## fill=NA could possibly be recycled to length of FUN results +test(6010.705, frollapply(1:5, 2, range, simplify=FALSE), list(NA,1:2,2:3,3:4,4:5)) +test(6010.706, frollapply(1:5, 2, range, fill=c(NA_integer_,NA_integer_)), data.table(V1=c(NA,1:4), V2=c(NA,2:5))) +test(6010.707, frollapply(1:5, 2, range, fill=c(min=NA_integer_, max=NA_integer_)), data.table(min=c(NA,1:4), max=c(NA,2:5))) +test(6010.708, frollapply(1:5, 2, range, fill=c(min=NA_integer_, max=NA_integer_), simplify=function(x) rbindlist(lapply(x, as.list))), data.table(min=c(NA,1:4), max=c(NA,2:5))) +test(6010.709, frollapply(1:5, 2, function(x) as.list(range(x)), fill=list(min=NA_integer_, max=NA_integer_)), data.table(min=c(NA,1:4), max=c(NA,2:5))) +test(6010.710, frollapply(1:5, 2, function(x) as.list(range(x)), fill=list(min=NA_integer_, max=NA_integer_), simplify=rbindlist), data.table(min=c(NA,1:4), max=c(NA,2:5))) +test(6010.711, frollapply(1:5, 2, function(x) as.list(range(x)), fill=list(NA_integer_, NA_integer_), simplify=FALSE), list(list(NA_integer_, NA_integer_), as.list(1:2), as.list(2:3), as.list(3:4), as.list(4:5))) +test(6010.712, as.null(frollapply(1:3, 1, function(x) if (x==1L) sum else if (x==2L) mean else `[`, simplify=TRUE)), NULL) ## as.null as we are only interested in codecov here +test(6010.713, as.null(frollapply(1:3, 1, function(x) `[`, simplify = TRUE)), NULL) ## as.null as we are only interested in codecov here + +#### fixing .internal.selfref +use.fork = .Platform$OS.type!="windows" && getDTthreads()>1L +if (use.fork) { + is.ok = function(x) {stopifnot(is.data.table(x)); capture.output(print(attr(x, ".internal.selfref", TRUE)))!=""} + ans = frollapply(1:2, 2, data.table) ## default: fill=NA + test(6010.770, is.ok(ans[[2L]])) ## mismatch of 'fill' type so simplify=TRUE did not run rbindlist but frollapply detected DT and fixed + ans = frollapply(1:2, 2, data.table, fill=data.table(NA)) ## fill type match + test(6010.771, is.ok(ans)) ## simplify=TRUE did run rbindlist, but frollapply fixed anyway + ans = frollapply(1:2, 2, data.table, fill=data.table(NA), simplify=FALSE) + test(6010.772, is.ok(ans[[2L]])) + ans = frollapply(1:2, 2, function(x) list(data.table(x)), fill=list(data.table(NA)), simplify=FALSE) + test(6010.773, !is.ok(ans[[2L]][[1L]])) + test(6010.7731, set(ans[[2L]][[1L]],, "newcol", 1L), error="data.table has either been loaded from disk") + ans = lapply(ans, lapply, setDT) + test(6010.774, is.ok(ans[[2L]][[1L]])) ## fix after + ans = frollapply(1:2, 2, function(x) list(data.table(x)), fill=list(data.table(NA)), simplify=function(x) lapply(x, lapply, setDT)) + test(6010.775, is.ok(ans[[2L]][[1L]])) ## fix inside frollapply via simplify + f = function(x) (if (x[1L]==1L) data.frame else data.table)(x) ## automatic fix may not work for a non-type stable function + ans = frollapply(1:3, 2, f, fill=data.table(NA), simplify=FALSE) + test(6010.776, !is.ok(ans[[3L]])) + ans = frollapply(1:3, 2, f, fill=data.table(NA), simplify=function(x) lapply(x, function(y) if (is.data.table(y)) setDT(y) else y)) + test(6010.777, is.ok(ans[[3L]])) ## fix inside frollapply via simplify +} + +## partial adaptive +test(6010.801, frollapply(1:4, rep(2L,4L), mean, adaptive=TRUE, partial=TRUE), c(1,1.5,2.5,3.5)) +test(6010.802, frollapply(FUN=mean, 1:4, rep(2L,4L), adaptive=TRUE, partial=TRUE), c(1,1.5,2.5,3.5)) +test(6010.803, frollapply(FUN=mean, 1:4, list(1:4, 1:3), adaptive=TRUE, partial=TRUE), error="adaptive windows provided in 'N' must not to have different lengths") +test(6010.804, frollapply(FUN=mean, 1:4, list(1:3), adaptive=TRUE, partial=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.805, frollapply(FUN=mean, 1:4, list(rep(2L,4L)), adaptive=TRUE, partial=TRUE), c(1,1.5,2.5,3.5)) +test(6010.806, frollapply(FUN=sum, as.double(1:4), 1:4, adaptive=TRUE, partial=TRUE), c(1,3,6,10)) ## all same as index +test(6010.807, frollapply(FUN=sum, as.double(1:4), 1:4, align="left", adaptive=TRUE, partial=TRUE), c(1,5,7,4)) +test(6010.808, frollapply(FUN=sum, as.double(1:4), c(2,3,1,1), adaptive=TRUE, partial=TRUE), c(1,3,3,4)) ## leading two bigger than index +test(6010.809, frollapply(FUN=sum, as.double(1:4), c(2,3,1,1), align="left", adaptive=TRUE, partial=TRUE), c(3,9,3,4)) +test(6010.810, frollapply(FUN=sum, as.double(1:4), c(6,5,4,2), adaptive=TRUE, partial=TRUE), c(1,3,6,7)) ## leading two bigger than rev index +test(6010.811, frollapply(FUN=sum, as.double(1:4), c(6,5,4,2), align="left", adaptive=TRUE, partial=TRUE), c(10,9,7,4)) +test(6010.812, frollapply(FUN=sum, as.double(1:4), c(2,4,5,6), adaptive=TRUE, partial=TRUE), c(1,3,6,10)) ## trailing two bigger than index +test(6010.813, frollapply(FUN=sum, as.double(1:4), c(2,4,5,6), align="left", adaptive=TRUE, partial=TRUE), c(3,9,7,4)) +test(6010.814, frollapply(FUN=sum, as.double(1:4), c(1,1,3,2), adaptive=TRUE, partial=TRUE), c(1,2,6,7)) ## trailing two bigger than rev index +test(6010.815, frollapply(FUN=sum, as.double(1:4), c(1,1,3,2), align="left", adaptive=TRUE, partial=TRUE), c(1,2,7,4)) + +## give.names +test(6010.9511, frollapply(FUN=sum, c(1,2,3), 2, give.names=TRUE), c(NA,3,5)) +test(6010.9512, frollapply(FUN=sum, c(1,2,3), c(b=2), give.names=TRUE), c(NA,3,5)) +test(6010.9513, frollapply(FUN=sum, c(a1=1,a2=2,a3=3), c(b=2), give.names=TRUE), c(NA,3,5)) +test(6010.9514, frollapply(FUN=sum, c(a1=1,a2=2,a3=3), 2, give.names=TRUE), c(NA,3,5)) +test(6010.952, frollapply(FUN=sum, list(c(1,2,3)), 2, give.names=TRUE), list(V1_rollapply2=c(NA,3,5))) +test(6010.953, frollapply(FUN=sum, list(x1=c(1,2,3)), 2, give.names=TRUE), list(x1_rollapply2=c(NA,3,5))) +test(6010.954, frollapply(FUN=sum, list(c(1,2,3)), c(n1=2), give.names=TRUE), list(V1_n1=c(NA,3,5))) +test(6010.955, frollapply(FUN=sum, list(x1=c(1,2,3)), c(n1=2), give.names=TRUE), list(x1_n1=c(NA,3,5))) +test(6010.956, frollapply(FUN=sum, c(1,2,3), 2:3, give.names=TRUE), list(rollapply2=c(NA,3,5), rollapply3=c(NA,NA,6))) +test(6010.957, frollapply(FUN=sum, list(c(1,2,3)), 2:3, give.names=TRUE), list(V1_rollapply2=c(NA,3,5), V1_rollapply3=c(NA,NA,6))) +test(6010.958, frollapply(FUN=sum, list(c(1,2,3), c(2,3,4)), 2, give.names=TRUE), list(V1_rollapply2=c(NA,3,5), V2_rollapply2=c(NA,5,7))) +test(6010.959, frollapply(FUN=sum, list(c(1,2,3), c(2,3,4)), 2:3, give.names=TRUE), list(V1_rollapply2=c(NA,3,5), V1_rollapply3=c(NA,NA,6), V2_rollapply2=c(NA,5,7), V2_rollapply3=c(NA,NA,9))) +test(6010.960, frollapply(FUN=sum, c(1,2,3), c(n1=2, n2=3), give.names=TRUE), list(n1=c(NA,3,5), n2=c(NA,NA,6))) +test(6010.961, frollapply(FUN=sum, list(c(1,2,3)), c(n1=2, n2=3), give.names=TRUE), list(V1_n1=c(NA,3,5), V1_n2=c(NA,NA,6))) +test(6010.962, frollapply(FUN=sum, list(x1=c(1,2,3)), 2:3, give.names=TRUE), list(x1_rollapply2=c(NA,3,5), x1_rollapply3=c(NA,NA,6))) +test(6010.963, frollapply(FUN=sum, list(x1=c(1,2,3)), c(n1=2, n2=3), give.names=TRUE), list(x1_n1=c(NA,3,5), x1_n2=c(NA,NA,6))) +test(6010.964, frollapply(FUN=sum, list(c(1,2,3), c(2,3,4)), c(n1=2), give.names=TRUE), list(V1_n1=c(NA,3,5), V2_n1=c(NA,5,7))) +test(6010.965, frollapply(FUN=sum, list(c(1,2,3), c(2,3,4)), c(n1=2, n2=3), give.names=TRUE), list(V1_n1=c(NA,3,5), V1_n2=c(NA,NA,6), V2_n1=c(NA,5,7), V2_n2=c(NA,NA,9))) +test(6010.966, frollapply(FUN=sum, list(x1=c(1,2,3), x2=c(2,3,4)), 2, give.names=TRUE), list(x1_rollapply2=c(NA,3,5), x2_rollapply2=c(NA,5,7))) +test(6010.967, frollapply(FUN=sum, list(x1=c(1,2,3), x2=c(2,3,4)), 2:3, give.names=TRUE), list(x1_rollapply2=c(NA,3,5), x1_rollapply3=c(NA,NA,6), x2_rollapply2=c(NA,5,7), x2_rollapply3=c(NA,NA,9))) +test(6010.968, frollapply(FUN=sum, list(x1=c(1,2,3), x2=c(2,3,4)), c(n1=2), give.names=TRUE), list(x1_n1=c(NA,3,5), x2_n1=c(NA,5,7))) +test(6010.969, frollapply(FUN=sum, list(x1=c(1,2,3), x2=c(2,3,4)), c(n1=2, n2=3), give.names=TRUE), list(x1_n1=c(NA,3,5), x1_n2=c(NA,NA,6), x2_n1=c(NA,5,7), x2_n2=c(NA,NA,9))) +test(6010.971, frollapply(FUN=sum, c(1,2,3), c(2,2,2), adaptive=TRUE, give.names=TRUE), c(NA,3,5)) ## adaptive +test(6010.972, frollapply(FUN=sum, c(1,2,3), list(c(2,2,2)), adaptive=TRUE, give.names=TRUE), c(NA,3,5)) +test(6010.973, frollapply(FUN=sum, list(c(1,2,3)), c(2,2,2), adaptive=TRUE, give.names=TRUE), list(V1=c(NA,3,5))) +test(6010.974, frollapply(FUN=sum, list(c(1,2,3)), list(c(2,2,2)), adaptive=TRUE, give.names=TRUE), list(V1_arollapply1=c(NA,3,5))) +test(6010.975, frollapply(FUN=sum, list(x1=c(1,2,3)), c(2,2,2), adaptive=TRUE, give.names=TRUE), list(x1=c(NA,3,5))) +test(6010.976, frollapply(FUN=sum, list(x1=c(1,2,3)), list(c(2,2,2)), adaptive=TRUE, give.names=TRUE), list(x1_arollapply1=c(NA,3,5))) +test(6010.977, frollapply(FUN=sum, list(c(1,2,3)), list(n1=c(2,2,2)), adaptive=TRUE, give.names=TRUE), list(V1_n1=c(NA,3,5))) +test(6010.978, frollapply(FUN=sum, list(x1=c(1,2,3)), list(n1=c(2,2,2)), adaptive=TRUE, give.names=TRUE), list(x1_n1=c(NA,3,5))) +test(6010.979, frollapply(FUN=sum, c(1,2,3), list(c(2,2,2), c(3,3,3)), adaptive=TRUE, give.names=TRUE), list(arollapply1=c(NA,3,5), arollapply2=c(NA,NA,6))) +test(6010.980, frollapply(FUN=sum, list(c(1,2,3)), list(c(2,2,2), c(3,3,3)), adaptive=TRUE, give.names=TRUE), list(V1_arollapply1=c(NA,3,5), V1_arollapply2=c(NA,NA,6))) +test(6010.981, frollapply(FUN=sum, list(c(1,2,3), c(2,3,4)), c(2,2,2), adaptive=TRUE, give.names=TRUE), list(V1=c(NA,3,5), V2=c(NA,5,7))) +test(6010.982, frollapply(FUN=sum, list(c(1,2,3), c(2,3,4)), list(c(2,2,2)), adaptive=TRUE, give.names=TRUE), list(V1_arollapply1=c(NA,3,5), V2_arollapply1=c(NA,5,7))) +test(6010.983, frollapply(FUN=sum, list(c(1,2,3), c(2,3,4)), list(c(2,2,2), c(3,3,3)), adaptive=TRUE, give.names=TRUE), list(V1_arollapply1=c(NA,3,5), V1_arollapply2=c(NA,NA,6), V2_arollapply1=c(NA,5,7), V2_arollapply2=c(NA,NA,9))) +test(6010.984, frollapply(FUN=sum, c(1,2,3), list(n1=c(2,2,2), n2=c(3,3,3)), adaptive=TRUE, give.names=TRUE), list(n1=c(NA,3,5), n2=c(NA,NA,6))) +test(6010.985, frollapply(FUN=sum, list(c(1,2,3)), list(n1=c(2,2,2), n2=c(3,3,3)), adaptive=TRUE, give.names=TRUE), list(V1_n1=c(NA,3,5), V1_n2=c(NA,NA,6))) +test(6010.986, frollapply(FUN=sum, list(x1=c(1,2,3)), list(c(2,2,2), c(3,3,3)), adaptive=TRUE, give.names=TRUE), list(x1_arollapply1=c(NA,3,5), x1_arollapply2=c(NA,NA,6))) +test(6010.987, frollapply(FUN=sum, list(x1=c(1,2,3)), list(n1=c(2,2,2), n2=c(3,3,3)), adaptive=TRUE, give.names=TRUE), list(x1_n1=c(NA,3,5), x1_n2=c(NA,NA,6))) +test(6010.988, frollapply(FUN=sum, list(c(1,2,3), c(2,3,4)), list(n1=c(2,2,2)), adaptive=TRUE, give.names=TRUE), list(V1_n1=c(NA,3,5), V2_n1=c(NA,5,7))) +test(6010.989, frollapply(FUN=sum, list(c(1,2,3), c(2,3,4)), list(n1=c(2,2,2), n2=c(3,3,3)), adaptive=TRUE, give.names=TRUE), list(V1_n1=c(NA,3,5), V1_n2=c(NA,NA,6), V2_n1=c(NA,5,7), V2_n2=c(NA,NA,9))) +test(6010.990, frollapply(FUN=sum, list(x1=c(1,2,3), x2=c(2,3,4)), c(2,2,2), adaptive=TRUE, give.names=TRUE), list(x1=c(NA,3,5), x2=c(NA,5,7))) +test(6010.991, frollapply(FUN=sum, list(x1=c(1,2,3), x2=c(2,3,4)), list(c(2,2,2)), adaptive=TRUE, give.names=TRUE), list(x1_arollapply1=c(NA,3,5), x2_arollapply1=c(NA,5,7))) +test(6010.992, frollapply(FUN=sum, list(x1=c(1,2,3), x2=c(2,3,4)), list(c(2,2,2), c(3,3,3)), adaptive=TRUE, give.names=TRUE), list(x1_arollapply1=c(NA,3,5), x1_arollapply2=c(NA,NA,6), x2_arollapply1=c(NA,5,7), x2_arollapply2=c(NA,NA,9))) +test(6010.993, frollapply(FUN=sum, list(x1=c(1,2,3), x2=c(2,3,4)), list(n1=c(2,2,2)), adaptive=TRUE, give.names=TRUE), list(x1_n1=c(NA,3,5), x2_n1=c(NA,5,7))) +test(6010.994, frollapply(FUN=sum, list(x1=c(1,2,3), x2=c(2,3,4)), list(n1=c(2,2,2), n2=c(3,3,3)), adaptive=TRUE, give.names=TRUE), list(x1_n1=c(NA,3,5), x1_n2=c(NA,NA,6), x2_n1=c(NA,5,7), x2_n2=c(NA,NA,9))) +test(6010.9950, frollapply(FUN=sum, c(1,2,3), 2, partial=TRUE, give.names=TRUE), c(1,3,5)) ## partial +test(6010.9951, frollapply(FUN=sum, c(1,2,3), c(n1=2), partial=TRUE, give.names=TRUE), c(1,3,5)) +test(6010.9952, frollapply(FUN=sum, list(c(1,2,3)), 2, partial=TRUE, give.names=TRUE), list(V1_rollapply2=c(1,3,5))) +test(6010.9953, frollapply(FUN=sum, list(x1=c(1,2,3)), 2, partial=TRUE, give.names=TRUE), list(x1_rollapply2=c(1,3,5))) +test(6010.9954, frollapply(FUN=sum, list(c(1,2,3)), c(n1=2), partial=TRUE, give.names=TRUE), list(V1_n1=c(1,3,5))) +test(6010.9955, frollapply(FUN=sum, list(x1=c(1,2,3)), c(n1=2), partial=TRUE, give.names=TRUE), list(x1_n1=c(1,3,5))) +test(6010.9956, frollapply(FUN=sum, list(c(1,2,3), c(2,3,4)), c(2, 3), partial=TRUE, give.names=TRUE), list(V1_rollapply2=c(1,3,5), V1_rollapply3=c(1,3,6), V2_rollapply2=c(2,5,7), V2_rollapply3=c(2,5,9))) +test(6010.9957, frollapply(FUN=sum, list(c(1,2,3), c(2,3,4)), c(n1=2, n2=3), partial=TRUE, give.names=TRUE), list(V1_n1=c(1,3,5), V1_n2=c(1,3,6), V2_n1=c(2,5,7), V2_n2=c(2,5,9))) +test(6010.9958, frollapply(FUN=sum, list(x1=c(1,2,3), x2=c(2,3,4)), c(2, 3), partial=TRUE, give.names=TRUE), list(x1_rollapply2=c(1,3,5), x1_rollapply3=c(1,3,6), x2_rollapply2=c(2,5,7), x2_rollapply3=c(2,5,9))) +test(6010.9959, frollapply(FUN=sum, list(x1=c(1,2,3), x2=c(2,3,4)), c(n1=2, n2=3), partial=TRUE, give.names=TRUE), list(x1_n1=c(1,3,5), x1_n2=c(1,3,6), x2_n1=c(2,5,7), x2_n2=c(2,5,9))) +test(6010.9960, frollapply(FUN=sum, c(1,2,3), c(2,2,2), adaptive=TRUE, partial=TRUE, give.names=TRUE), c(1,3,5)) ## adaptive partial +test(6010.9961, frollapply(FUN=sum, c(1,2,3), list(c(2,2,2)), adaptive=TRUE, partial=TRUE, give.names=TRUE), c(1,3,5)) +test(6010.9962, frollapply(FUN=sum, list(c(1,2,3)), c(2,2,2), adaptive=TRUE, partial=TRUE, give.names=TRUE), list(V1=c(1,3,5))) +test(6010.9963, frollapply(FUN=sum, list(c(1,2,3)), list(c(2,2,2)), adaptive=TRUE, partial=TRUE, give.names=TRUE), list(V1_arollapply1=c(1,3,5))) +test(6010.9964, frollapply(FUN=sum, list(x1=c(1,2,3)), c(2,2,2), adaptive=TRUE, partial=TRUE, give.names=TRUE), list(x1=c(1,3,5))) +test(6010.9965, frollapply(FUN=sum, list(x1=c(1,2,3)), list(c(2,2,2)), adaptive=TRUE, partial=TRUE, give.names=TRUE), list(x1_arollapply1=c(1,3,5))) +test(6010.9966, frollapply(FUN=sum, c(1,2,3), list(c(n1=c(2,2,2))), adaptive=TRUE, partial=TRUE, give.names=TRUE), c(1,3,5)) +test(6010.9967, frollapply(FUN=sum, list(c(1,2,3)), c(2,2,2), adaptive=TRUE, partial=TRUE, give.names=TRUE), list(V1=c(1,3,5))) +test(6010.9968, frollapply(FUN=sum, list(c(1,2,3)), list(n1=c(2,2,2)), adaptive=TRUE, partial=TRUE, give.names=TRUE), list(V1_n1=c(1,3,5))) +test(6010.9969, frollapply(FUN=sum, list(x1=c(1,2,3)), list(n1=c(2,2,2)), adaptive=TRUE, partial=TRUE, give.names=TRUE), list(x1_n1=c(1,3,5))) + +# frollapply doesn't handle zero-length output #7054 +test(6010.9991, frollapply(list(integer()), 0, function(x) 1), list(NULL)) +test(6010.9992, frollapply(list(integer()), list(integer()), str, adaptive=TRUE), list(NULL)) + +## batch validation set.seed(108) makeNA = function(x, ratio=0.1, nf=FALSE) { n = as.integer(length(x) * ratio) @@ -1136,7 +1504,6 @@ makeNA = function(x, ratio=0.1, nf=FALSE) { } x } -num = 6007.0 ## against base to verify exactness of non-finite values, not handled in zoo rollfun = function(x, n, FUN, fill=NA_real_, na.rm=FALSE, nf.rm=FALSE, partial=FALSE) { ans = rep(fill, nx<-length(x)) @@ -1170,7 +1537,7 @@ base_compare = function(x, n, funs=c("mean","sum","max"), algos=c("fast","exact" eval(substitute( # so we can have values displayed in output/log rather than variables test(.num, ignore.warning="no non-missing arguments", rollfun(x, n, FUN=.fun, fill=.fill, na.rm=.na.rm, partial=.partial), - frollfun(.fun, x, n, fill=.fill, na.rm=.na.rm, algo=.algo, partial=.partial, has.nf=.has.nf)), + froll(.fun, x, n, fill=.fill, na.rm=.na.rm, algo=.algo, partial=.partial, has.nf=.has.nf)), list(.num=num, .fun=fun, .fill=fill, .na.rm=na.rm, .algo=algo, .partial=partial, .has.nf=has.nf) )) } @@ -1179,7 +1546,7 @@ base_compare = function(x, n, funs=c("mean","sum","max"), algos=c("fast","exact" eval(substitute( # so we can have values displayed in output/log rather than variables test(.num, ignore.warning="no non-missing arguments", frollapply(x, n, FUN=match.fun(.fun), fill=.fill, na.rm=.na.rm, partial=.partial), - frollfun(.fun, x, n, fill=.fill, na.rm=.na.rm, partial=.partial)), + froll(.fun, x, n, fill=.fill, na.rm=.na.rm, partial=.partial)), list(.num=num, .fun=fun, .fill=fill, .na.rm=na.rm, .partial=partial) )) } @@ -1187,6 +1554,7 @@ base_compare = function(x, n, funs=c("mean","sum","max"), algos=c("fast","exact" } } } +num = 7001.0 ## random NA non-finite x = makeNA(rnorm(1e3), nf=TRUE); n = 50 base_compare(x, n) @@ -1196,7 +1564,7 @@ x = makeNA(rnorm(1e3), nf=TRUE); n = 51 base_compare(x, n) x = makeNA(rnorm(1e3+1), nf=TRUE); n = 51 base_compare(x, n) -num = 6008.0 + #### against zoo if (requireNamespace("zoo", quietly=TRUE)) { drollapply = function(...) as.double(zoo::rollapply(...)) # rollapply is not consistent in data type of answer, force to double @@ -1222,7 +1590,7 @@ if (requireNamespace("zoo", quietly=TRUE)) { eval(substitute( # so we can have values displayed in output/log rather than variables test(.num, ignore.warning="no non-missing arguments", drollapply(x, n, FUN=.fun, fill=.fill, align=.align, na.rm=.na.rm, partial=.partial), - frollfun(.fun, x, n, align=.align, fill=.fill, na.rm=.na.rm, algo=.algo, partial=.partial, has.nf=.has.nf)), + froll(.fun, x, n, align=.align, fill=.fill, na.rm=.na.rm, algo=.algo, partial=.partial, has.nf=.has.nf)), list(.num=num, .fun=fun, .align=align, .fill=fill, .na.rm=na.rm, .algo=algo, .partial=partial, .has.nf=has.nf) )) } @@ -1231,7 +1599,7 @@ if (requireNamespace("zoo", quietly=TRUE)) { eval(substitute( # so we can have values displayed in output/log rather than variables test(.num, ignore.warning="no non-missing arguments", frollapply(x, n, FUN=.fun, fill=.fill, align=.align, na.rm=.na.rm, partial=.partial), - frollfun(.fun, x, n, align=.align, fill=.fill, na.rm=.na.rm, partial=.partial)), + froll(.fun, x, n, align=.align, fill=.fill, na.rm=.na.rm, partial=.partial)), list(.num=num, .fun=fun, .align=align, .fill=fill, .na.rm=na.rm, .partial=partial) )) } @@ -1240,6 +1608,7 @@ if (requireNamespace("zoo", quietly=TRUE)) { } } } + num = 7002.0 ## no NA x = rnorm(1e3); n = 50 # x even, n even zoo_compare(x, n) @@ -1269,7 +1638,6 @@ if (requireNamespace("zoo", quietly=TRUE)) { zoo_compare(x, n) } #### 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=FALSE) { # adaptive moving average in R stopifnot((nx<-length(x))==length(n)) @@ -1316,10 +1684,10 @@ afun_compare = function(x, n, funs=c("mean","sum","max"), algos=c("fast","exact" 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) + arollfun(.fun, x, n, fill = .fill, na.rm = .na.rm, align = .align, partial=.partial), + froll(.fun, x, n, fill=.fill, na.rm=.na.rm, algo=.algo, adaptive=TRUE, align=.align, has.nf=.has.nf, partial=.partial) ), - list(.num = num, .fun = fun, .fill = fill, .na.rm = na.rm, .algo = algo, .align = align, .has.nf = has.nf) + list(.num = num, .fun = fun, .fill = fill, .na.rm = na.rm, .algo = algo, .align = align, .partial=partial, .has.nf = has.nf) )) } } @@ -1327,15 +1695,16 @@ afun_compare = function(x, n, funs=c("mean","sum","max"), algos=c("fast","exact" 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) + frollapply(x, n, FUN=match.fun(.fun), fill=.fill, na.rm=.na.rm, adaptive=TRUE, align=.align), + froll(.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 = 7003.0 #### no NA x = rnorm(1e3); n = sample(50, length(x), TRUE) # x even, n even afun_compare(x, n) @@ -1373,124 +1742,3 @@ afun_compare(x, n) x = makeNA(rnorm(1e3+1), nf=TRUE); n = sample(51, length(x), TRUE) afun_compare(x, n) rm(num) - -## frollapply -x = 1:10 -test(6010.001, frollsum(x, 3L), frollapply(x, 3L, sum)) -test(6010.002, frollsum(x, 6), frollapply(x, 6, sum)) -test(6010.003, frollmean(x, 3), frollapply(x, 3, mean)) -d = as.data.table(list(1:6/2, 3:8/4)) -test(6010.004, frollsum(d, 3:4), frollapply(d, 3:4, sum)) -test(6010.005, frollmean(d, 3:4), frollapply(d, 3:4, mean)) -d = rbind(d, list(NA,NA)) -ans = list(c(NA,NA,1.5,2,1.5,2,2.5), c(NA,NA,NA,2,1,1.5,2), c(NA,NA,1.25,1.5,1.75,1.5,2), c(NA,NA,NA,1.5,1,1.25,1.5)) -test(6010.006, frollapply(d, 3:4, function(x, ...) if (sum(x, ...)>5) min(x, ...) else max(x, ...), na.rm=TRUE), ans) -# segfault and protect limits #3993 - disabled by default due to high memory usage -if (FALSE) { - test(6010.007, frollapply(1, rep(1L, 1e5), identity), as.list(rep(1, 1e5))) - test(6010.008, frollapply(1, rep(1L, 1e6), identity), as.list(rep(1, 1e6))) - test(6010.009, frollapply(as.list(rep(1, 1e6)), 1, identity), as.list(rep(1, 1e6))) -} -#### corner cases from examples -test(6010.101, frollapply(1:5, 3, function(x) head(x, 2)), error="frollapply: results from provided FUN are not length 1") -f = function(x) { - n = length(x) - # length 1 will be returned only for first iteration where we check length - if (n==x[n]) x[1L] else range(x) # range(x)[2L] is silently ignored -} -test(6010.102, frollapply(1:5, 3, f), c(NA,NA,1,2,3)) -options(datatable.verbose=TRUE) -x = c(1,2,1,1,1,2,3,2) -ans = c(NA,NA,2,2,1,2,3,2) -numUniqueN = function(x) as.numeric(uniqueN(x)) -test(6010.103, frollapply(x, 3, uniqueN), ans, output=c("frollapplyR: allocating memory.*","frollapply: results from provided FUN are not of type double, coercion from integer or logical will be applied on each iteration.*","frollapply: took.*","frollapplyR: processing.*took.*")) -test(6010.104, frollapply(x, 3, numUniqueN), ans, output=c("frollapplyR: allocating memory.*","frollapply: took.*","frollapplyR: processing.*took.*")) -test(6010.105, as.logical(frollapply(c(1,2,1,1,NA,2,NA,2), 3, anyNA)), c(NA,NA,FALSE,FALSE,TRUE,TRUE,TRUE,TRUE), output=c("frollapplyR: allocating memory.*","frollapply: results from provided FUN are not of type double, coercion from integer or logical will be applied on each iteration","frollapply: took.*","frollapplyR: processing.*took.*")) -f = function(x) { - n = length(x) - # double type will be returned only for first iteration where we check type - if (n==x[n]) 1 else NA # NA logical turns into garbage without coercion to double -} -#test(6010.106, head(frollapply(1:5, 3, f), 3L), c(NA_real_,NA_real_,1), output=c("frollapplyR: allocating memory.*","frollapply: took.*","frollapplyR: processing.*took.*")) # only head 3 is valid, rest is undefined as REAL is applied on logical type, can return garbage or fail with REAL error -options(datatable.verbose=FALSE) - -# frollapply adaptive -r340 = base::getRversion() >= "3.4.0" ## support SET_GROWABLE_BIT -if (!r340) { - test(6010.2, frollapply(1:3, c(3,3,3), sum, adaptive=TRUE), error="frollapply adaptive=TRUE requires at least R 3.4.0") -} else { - test(6010.2011, frollapply(1:3, c(3,3,3), sum, adaptive=TRUE), c(NA,NA,6)) - test(6010.2012, frollapply(1:3, c(4,4,4), sum, adaptive=TRUE), rep(NA_real_,3)) # none of the windows in k was small enough to cover length of x - test(6010.2013, frollapply(1:5, rep(2, 5), mean, adaptive=NA), error="adaptive must be TRUE or FALSE") - test(6010.2014, frollapply(1:5, rep(3, 5), toString, adaptive=TRUE), error="frolladaptiveapply: results from provided FUN are not of type double") - test(6010.2015, frollapply(1:2, 1:2, mean, adaptive=TRUE, align="right"), c(1, 1.5)) - test(6010.2016, frollapply(1:2, 1:2, mean, adaptive=TRUE, align="center"), error="using adaptive TRUE and align 'center' is not implemented") - test(6010.2017, frollapply(list(1:2, 1:3), list(1:2), mean, adaptive=TRUE), error="adaptive rolling function can only process 'x' having equal length of elements, like data.table or data.frame. If you want to call rolling function on list having variable length of elements call it for each field separately") - 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), 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) - ans = c(NA,NA,2,2,1,2,3,2) - numUniqueN = function(x) as.numeric(uniqueN(x)) - test(6010.203, frollapply(x, rep(3, length(x)), uniqueN, adaptive=TRUE), ans, output=c("frollapplyR: allocating memory.*","frolladaptiveapply: results from provided FUN are not of type double, coercion from integer or logical will be applied on each iteration.*","frolladaptiveapply: took.*","frollapplyR: processing.*took.*")) - test(6010.204, frollapply(x, rep(3, length(x)), numUniqueN, adaptive=TRUE), ans, output=c("frollapplyR: allocating memory.*","frolladaptiveapply: took.*","frollapplyR: processing.*took.*")) - test(6010.205, as.logical(frollapply(c(1,2,1,1,NA,2,NA,2), rep(3, length(x)), anyNA, adaptive=TRUE)), c(NA,NA,FALSE,FALSE,TRUE,TRUE,TRUE,TRUE), output=c("frollapplyR: allocating memory.*","frolladaptiveapply: results from provided FUN are not of type double, coercion from integer or logical will be applied on each iteration","frolladaptiveapply: took.*","frollapplyR: processing.*took.*")) - options(datatable.verbose=FALSE) - test(6010.206, frollapply(c(2,2,2,3,4), c(1,3,3,2,3), uniqueN, adaptive=TRUE), c(1,NA,1,2,3)) ## window width bigger than location -} - -#### test coverage -test(6010.501, frollapply(1:3, "b", sum), error="n must be integer") -test(6010.503, frollapply(1:3, integer(), sum), error="n must be non 0 length") -test(6010.504, frollapply(1:3, 2L, sum, fill=1:2), error="fill must be a vector of length 1") -test(6010.505, frollapply(1:3, 2L, sum, fill=NA_integer_), c(NA,3,5)) -test(6010.506, frollapply(1:3, 2L, sum, fill=-1L), c(-1,3,5)) -test(6010.507, frollapply(1:3, 2L, sum, fill=-2), c(-2,3,5)) -test(6010.508, frollapply(1:3, 2L, sum, fill="z"), error="fill must be numeric") -test(6010.509, frollapply(1:3, 4L, sum), c(NA_real_,NA_real_,NA_real_)) -test(6010.510, frollapply(1:5, 3L, sum), c(NA,NA,6,9,12)) -test(6010.511, frollapply(1:5, 3L, sum, align="center"), c(NA,6,9,12,NA)) -test(6010.512, frollapply(1:5, 3L, sum, align="left"), c(6,9,12,NA,NA)) -test(6010.513, frollapply(1:5, 4L, sum), c(NA,NA,NA,10,14)) -test(6010.514, frollapply(1:5, 4L, sum, align="center"), c(NA,10,14,NA,NA)) -test(6010.515, frollapply(1:5, 4L, sum, align="left"), c(10,14,NA,NA,NA)) -test(6010.516, frollapply(1:6, 3L, sum), c(NA,NA,6,9,12,15)) -test(6010.517, frollapply(1:6, 3L, sum, align="center"), c(NA,6,9,12,15,NA)) -test(6010.518, frollapply(1:6, 3L, sum, align="left"), c(6,9,12,15,NA,NA)) -test(6010.519, frollapply(1:6, 4L, sum), c(NA,NA,NA,10,14,18)) -test(6010.520, frollapply(1:6, 4L, sum, align="center"), c(NA,10,14,18,NA,NA)) -test(6010.521, frollapply(1:6, 4L, sum, align="left"), c(10,14,18,NA,NA,NA)) -test(6010.522, frollapply(c(1:3,NA,5:6), 4L, sum), rep(NA_real_,6)) -test(6010.523, frollapply(c(1:3,NA,5:6), 4L, sum, na.rm=TRUE), c(NA,NA,NA,6,10,14)) -test(6010.524, frollapply(c(1,2,3,NA,NA,NA,NA), 3L, mean), c(NA,NA,2,NA,NA,NA,NA)) -test(6010.525, frollapply(c(1,2,3,NA,NA,NA,NA), 3L, mean, na.rm=TRUE), c(NA,NA,2,2.5,3,NaN,NaN)) -test(6010.526, frollapply(numeric(), 3L, sum), numeric()) -test(6010.527, frollapply(1:5, 3L, toString), error="frollapply: results from provided FUN are not of type double") -options(datatable.verbose=TRUE) -test(6010.551, frollapply(1:3, 4L, sum), c(NA_real_,NA_real_,NA_real_), output=c("frollapplyR: allocating memory.*","frollapply: window width longer than input vector.*","frollapplyR: processing.*took.*")) -test(6010.552, frollapply(1:5, 3L, sum), c(NA,NA,6,9,12), output=c("frollapplyR: allocating memory.*","frollapply: took.*","frollapplyR: processing.*took.*")) -test(6010.553, frollapply(1:5, 3L, sum, align="center"), c(NA,6,9,12,NA), output=c("frollapplyR: allocating memory.*","frollapply: align 0, shift.*","frollapply: took.*","frollapplyR: processing.*took.*")) -options(datatable.verbose=FALSE) -ma = function(x, n, na.rm=FALSE) { - ans = rep(NA_real_, nx<-length(x)) - for (i in n:nx) ans[i]=mean(x[(i-n+1):i], na.rm=na.rm) - ans -} -n = 4L -x = as.double(1:16) -x[5] = NaN -test(6010.601, frollapply(x, n, mean), ma(x, n)) -x[6] = NA -test(6010.602, frollapply(x, n, mean), ma(x, n)) -x[5] = NA -x[6] = NaN -test(6010.603, frollapply(x, n, mean), ma(x, n)) -x[5] = Inf -test(6010.604, frollapply(x, n, mean), ma(x, n)) -x[6] = -Inf -test(6010.605, frollapply(x, n, mean), ma(x, n)) -x[5:7] = c(NA, Inf, -Inf) -test(6010.606, frollapply(x, n, mean), ma(x, n)) diff --git a/man/froll.Rd b/man/froll.Rd index 61811a112b..645c77bf19 100644 --- a/man/froll.Rd +++ b/man/froll.Rd @@ -1,30 +1,27 @@ -\name{roll} -\alias{roll} -\alias{froll} +\name{froll} \alias{rolling} \alias{sliding} \alias{moving} -\alias{rollmean} +\alias{running} +\alias{froll} \alias{frollmean} -\alias{rollsum} -\alias{rollmax} \alias{frollsum} \alias{frollmax} -\alias{rollapply} -\alias{frollapply} +\alias{roll} +\alias{rollmean} +\alias{rollsum} +\alias{rollmax} \title{Rolling functions} \description{ - Fast rolling functions to calculate aggregates on sliding windows. + Fast rolling functions to calculate aggregates on sliding windows. For a user-defined rolling function see \code{\link{frollapply}}. } \usage{ frollmean(x, n, fill=NA, algo=c("fast","exact"), align=c("right","left","center"), - na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, hasNA, give.names=FALSE) + na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, give.names=FALSE, hasNA) frollsum(x, n, fill=NA, algo=c("fast","exact"), align=c("right","left","center"), - na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, hasNA, give.names=FALSE) + na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, give.names=FALSE, hasNA) frollmax(x, n, fill=NA, algo=c("fast","exact"), align=c("right","left","center"), - na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, hasNA, give.names=FALSE) - frollapply(x, n, FUN, \dots, fill=NA, align=c("right","left","center"), - adaptive=FALSE, partial=FALSE, give.names=FALSE) + na.rm=FALSE, has.nf=NA, adaptive=FALSE, partial=FALSE, give.names=FALSE, hasNA) } \arguments{ \item{x}{ Vector, \code{data.frame} or \code{data.table} of integer, numeric or logical columns over which to calculate the windowed aggregations. May also be a list, in which case the rolling function is applied to each of its elements. } @@ -38,17 +35,15 @@ \item{has.nf}{ Logical. If it is known whether \code{x} contains non-finite values (\code{NA}, \code{NaN}, \code{Inf}, \code{-Inf}), then setting this to \code{TRUE} or \code{FALSE} may speed up computation. Defaults to \code{NA}. See \emph{has.nf argument} section below for details. } \item{adaptive}{ Logical, default \code{FALSE}. Should the rolling function be calculated adaptively? See \emph{Adaptive rolling functions} section below for details. } \item{partial}{ Logical, default \code{FALSE}. Should the rolling window size(s) provided in \code{n} be computed also for leading incomplete running window. See \emph{\code{partial} argument} section below for details. } - \item{FUN}{ The function to be applied to the rolling window in \code{frollapply}; See \emph{frollapply} section below for details. } - \item{\dots}{ Extra arguments passed to \code{FUN} in \code{frollapply}. } - \item{hasNA}{ Logical. Deprecated, use \code{has.nf} argument instead. } \item{give.names}{ Logical, default \code{FALSE}. When \code{TRUE}, names are automatically generated corresponding to names of \code{x} and names of \code{n}. If answer is an atomic vector, then the argument is ignored, see examples. } + \item{hasNA}{ Logical. Deprecated, use \code{has.nf} argument instead. } } \details{ \code{froll*} functions accept vector, list, \code{data.frame} or \code{data.table}. Functions operate on a single vector; when passing a non-atomic input, then function is applied column-by-column, not to the complete set of columns at once. Argument \code{n} allows multiple values to apply rolling function on multiple window sizes. If \code{adaptive=TRUE}, then \code{n} can be a list to specify multiple window sizes for adaptive rolling computation. See \emph{Adaptive rolling functions} section below for details. - When multiple columns and/or multiple windows widths are provided, then computations run in parallel (except for \code{frollapply}. The exception is for \code{algo="exact"}, which runs in parallel even for a single column and single window width. By default, data.table uses only half of the available CPUs, see \code{\link{setDTthreads}} for details on how to tune CPU usage. + When multiple columns and/or multiple window widths are provided, then computations run in parallel. The exception is for \code{algo="exact"}, which runs in parallel even for single column and single window width. By default, data.table uses only half of available CPUs, see \code{\link{setDTthreads}} for details on how to tune CPU usage. Adaptive rolling functions are a special case where each observation has its own corresponding rolling window width. Due to the logic @@ -79,10 +74,10 @@ information in real-time but only at the end of the processing. } \value{ - A list except when the input is a \code{vector} and \code{length(n)==1}, in which case a \code{vector} is returned, for convenience. Thus, rolling functions can be used conveniently within \code{data.table} syntax. + For a non \emph{vectorized} input (\code{x} is not a list, and \code{n} specify single rolling window) a \code{vector} is returned, for convenience. Thus, rolling functions can be used conveniently within \code{data.table} syntax. For a \emph{vectorized} input a list is returned. } \note{ - Be aware that rolling functions operate on the physical order of input. If the intent is to roll values in a vector by a logical window, for example an hour or a day, then one has to use an adaptive rolling function or ensure that there are no gaps in the input. For details see \href{https://github.com/Rdatatable/data.table/issues/3241}{issue #3241}. + Be aware that rolling functions operate on the physical order of input. If the intent is to roll values in a vector by a logical window, for example an hour, or a day, then one has to ensure that there are no gaps in input or use adaptive rolling function to handle gaps by specifying expected window sizes. For details see \href{https://github.com/Rdatatable/data.table/issues/3241}{issue #3241}. } \section{\code{has.nf} argument}{ \code{has.nf} can be used to speed up processing in cases when it is known if \code{x} contains (or not) non-finite values (\code{NA}, \code{NaN}, \code{Inf}, \code{-Inf}). @@ -124,9 +119,6 @@ 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 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. -} \section{\code{zoo} package users notice}{ Users coming from most popular package for rolling functions \code{zoo} might expect following differences in \code{data.table} implementation \itemize{ @@ -138,13 +130,11 @@ \item \code{align} defaults to \code{"right"}. \item \code{na.rm} is respected, and other functions are not needed when input contains \code{NA}. - \item integers and logical are always coerced to double - (to be changed for frollapply). + \item integers and logical are always coerced to numeric. \item when \code{adaptive=FALSE} (default), then \code{n} must be a numeric vector. List is not accepted. \item when \code{adaptive=TRUE}, then \code{n} must be vector of length equal to \code{nrow(x)}, or list of such vectors. - \item \code{by.column} argument is not yet supported in \code{frollapply}. For details and upvote see \href{https://github.com/Rdatatable/data.table/issues/4887}{issue #4887}. } } \examples{ @@ -222,38 +212,9 @@ anserr = list( ) errs = sapply(lapply(anserr, abs), sum, na.rm=TRUE) sapply(errs, format, scientific=FALSE) # roundoff - -# frollapply corner cases -f = function(x) head(x, 2) ## FUN returns non length 1 -try(frollapply(1:5, 3, f)) -f = function(x) { ## FUN sometimes returns non length 1 - n = length(x) - # length 1 will be returned only for first iteration where we check length - if (n==x[n]) x[1L] else range(x) # range(x)[2L] is silently ignored! -} -frollapply(1:5, 3, f) -options(datatable.verbose=TRUE) -x = c(1,2,1,1,1,2,3,2) -frollapply(x, 3, uniqueN) ## FUN returns integer -numUniqueN = function(x) as.numeric(uniqueN(x)) -frollapply(x, 3, numUniqueN) -x = c(1,2,1,1,NA,2,NA,2) -frollapply(x, 3, anyNA) ## FUN returns logical -as.logical(frollapply(x, 3, anyNA)) -options(datatable.verbose=FALSE) -f = function(x) { ## FUN returns character - if (sum(x)>5) "big" else "small" -} -try(frollapply(1:5, 3, f)) -f = function(x) { ## FUN is not type-stable - n = length(x) - # double type will be returned only for first iteration where we check type - if (n==x[n]) 1 else NA # NA logical turns into garbage without coercion to double -} -try(frollapply(1:5, 3, f)) } \seealso{ - \code{\link{shift}}, \code{\link{data.table}}, \code{\link{setDTthreads}} + \code{\link{frollapply}}, \code{\link{shift}}, \code{\link{data.table}}, \code{\link{setDTthreads}} } \references{ \href{https://en.wikipedia.org/wiki/Round-off_error}{Round-off error} diff --git a/man/frollapply.Rd b/man/frollapply.Rd new file mode 100644 index 0000000000..df608d7318 --- /dev/null +++ b/man/frollapply.Rd @@ -0,0 +1,272 @@ +\name{frollapply} +\alias{frollapply} +\alias{rollapply} +\title{Rolling user-defined function} +\description{ + Fast rolling user-defined function (\emph{UDF}) to calculate on sliding window. Experimental. Please read, at least, \emph{caveats} section below. +} +\usage{ + frollapply(X, N, FUN, \dots, by.column=TRUE, fill=NA, + align=c("right","left","center"), adaptive=FALSE, partial=FALSE, + give.names=FALSE, simplify=TRUE, x, n) +} +\arguments{ + \item{X}{ Atomic vector, \code{data.frame}, \code{data.table} or \code{list}. When \code{by.column=TRUE} (default) then a non-atomic \code{X} is processed as \emph{vectorized} input, so rolling function is calculated for each column/vector (non-atomic columns/vectors are not supported). When \code{by.column=FALSE} then \code{X} expects to be a data.frame, data.table or a list of equal length vectors (non-atomic columns/vectors are not supported), so rolling function is calculated for \code{X} as data.frame/data.table/list rather than atomic vector. It supports \emph{vectorized} input as well, passing list of data.frames/data.tables, but not list of lists. } + \item{N}{ Integer vector giving rolling window size(s). This is the \emph{total} number of included values in aggregate function. Adaptive rolling functions also accept a list of integer vectors when applying multiple window sizes, see \code{adaptive} argument description for details. In both \code{adaptive} cases \code{N} may also be a list, supporting \emph{vectorized} input, then rolling function is calculated for each element of the list. } + \item{FUN}{ The function to be applied on a subsets of \code{X}. } + \item{\dots}{ Extra arguments passed to \code{FUN}. Note that arguments passed to \dots cannot have same names as arguments of \code{frollapply}. } + \item{by.column}{ Logical. When \code{TRUE} (default) then \code{X} of types list/data.frame/data.table is treated as vectorized input rather an object to apply rolling window on. Setting to \code{FALSE} allows rolling window to be applied on multiple variables, using data.frame, data.table or a list, as a whole. For details see \emph{\code{by.column} argument} section below. } + \item{fill}{ An object; value to pad by. Defaults to \code{NA}. When \code{partial=TRUE} this argument is ignored. } + \item{align}{ Character, specifying the "alignment" of the rolling window, defaulting to \code{"right"}. For details see \code{\link{froll}}. } + \item{adaptive}{ Logical, default \code{FALSE}. Should the rolling function be calculated adaptively? For details see \code{\link{froll}}. } + \item{partial}{ Logical, default \code{FALSE}. Should the rolling window size(s) provided in \code{N} be trimmed to available observations. For details see \code{\link{froll}}. } + \item{give.names}{ Logical, default \code{FALSE}. When \code{TRUE}, names are automatically generated corresponding to names of \code{X} and names of \code{N}. If answer is an atomic vector, then the argument is ignored, see examples. } + \item{simplify}{ Logical or a function. When \code{TRUE} (default) then internal \code{simplifylist} function is applied on a list storing results of all computations. When \code{FALSE} then list is returned without any post-processing. Argument can take a function as well, then the function is applied to a list that would have been returned when \code{simplify=FALSE}. If results are not automatically simplified when \code{simplify=TRUE} then, for backward compatibility, one should use \code{simplify=FALSE} explicitly. See \emph{\code{simplify} argument} section below for details. } + \item{x}{ Deprecated, use \code{X} instead. } + \item{n}{ Deprecated, use \code{N} instead. } +} +\value{ + Argument \code{simplify} impacts the type returned. Its default value \code{TRUE} is set for convenience and backward compatibility, but it is advised to use \code{simplify=unlist} (or other desired function) instead. + \itemize{ + \item \code{simplify=FALSE} will always return list where each element will be a result of each iteration. + \item \code{simplify=unlist} (or any other function) will return object returned by provided function as supplied with results of \code{frollapply} using \code{simplify=FALSE}. + \item \code{simplify=TRUE} will try to simplify results by \code{unlist}, \code{rbind} or other functions, its behavior is subject to change, see \emph{\code{simplify} argument} section below for more details. + } +} +\note{ + Be aware that rolling functions operates on the physical order of input. If the intent is to roll values in a vector by a logical window, for example an hour, or a day, then one has to ensure that there are no gaps in input or use adaptive rolling function to handle gaps by specifying expected window sizes. For details see \href{https://github.com/Rdatatable/data.table/issues/3241}{issue #3241}. +} +\section{\code{by.column} argument}{ + Setting \code{by.column} to \code{FALSE} allows to apply function on multiple variables rather than a single vector. Then \code{X} expects to be data.table, data.table or a list of equal length vectors, and window size provided in \code{N} refers to number of rows (or length of a vectors in a list). See examples for use cases. Error \emph{"incorrect number of dimensions"} can be commonly observed when \code{by.column} was not set to \code{FALSE} when \code{FUN} expects its input to be a data.frame/data.table. +} +\section{\code{simplify} argument}{ + One should avoid \code{simplify=TRUE} when writing robust code. One reason is performance, as explained in \emph{Performance consideration} section below. Another is backward compatibility. If results are not automatically simplified when \code{simplify=TRUE} then, for backward compatibility, one should use \code{simplify=FALSE} explicitly. In future version we may improve internal \code{simplifylist} function, then \code{simplify=TRUE} may return object of a different type, breaking downstream code. If results are already simplified with \code{simplify=TRUE}, then it can be considered backward compatible. +} +\section{Caveats}{ + With great power comes great responsibility. + \enumerate{ + \item An optimization used to avoid repeated allocation of window subsets (explained more deeply in \emph{Implementation} section below) may, in special cases, return rather surprising results: +\preformatted{ +setDTthreads(1) +frollapply(c(1, 9), N=1L, FUN=identity) ## unexpected +#[1] 9 9 +frollapply(c(1, 9), N=1L, FUN=list) ## unexpected +# V1 +# +#1: 9 +#2: 9 +setDTthreads(2) +frollapply(c(1, 9), N=1L, FUN=identity) ## good only because threads >= input +#[1] 1 9 +frollapply(c(1, 5, 9), N=1L, FUN=identity) ## unexpected again +#[1] 5 5 9 +} + Problem occurs, in rather unlikely scenarios for rolling computations, when objects returned from a function can be its input (i.e. \code{identity}), or a reference to it (i.e. \code{list}), then one has to add extra \code{copy} call: +\preformatted{ +setDTthreads(1) +frollapply(c(1, 9), N=1L, FUN=function(x) copy(identity(x))) ## only 'copy' would be equivalent here +#[1] 1 9 +frollapply(c(1, 9), N=1L, FUN=function(x) copy(list(x))) +# V1 +# +#1: 1 +#2: 9 +} + \item \code{FUN} calls are internally passed to \code{parallel::mcparallel} to evaluate them in parallel. We inherit few limitations from \code{parallel} package explained below. This optimization can be disabled completely by calling \code{setDTthreads(1)}, then limitations listed below do not apply because all iterations of \code{FUN} evaluation will be made sequentially without use of \code{parallel} package. Note that on Windows platform this optimization is always disabled due to lack of \emph{fork} used by \code{parallel} package. One can use \code{options(datatable.verbose=TRUE)} to get extra information if \code{frollapply} is running multithreaded or not. + \itemize{ + \item Warnings produced inside the function are silently ignored. + \item \code{FUN} should not use any on-screen devices, GUI elements, tcltk, multithreaded libraries. Note that \code{setDTthreads(1L)} is passed to forked processes, therefore any data.table code inside \code{FUN} will be forced to be single threaded. It is advised to not call \code{setDTthreads} inside \code{FUN}. \code{frollapply} is already parallelized and nested parallelism is rarely a good idea. + \item Any operation that could misbehave when run in parallel has to be handled. For example writing to the same file from multiple CPU threads. +\preformatted{ +old = setDTthreads(1L) +frollapply(iris, 5L, by.column=FALSE, FUN=fwrite, file="rolling-data.csv", append=TRUE) +setDTthreads(old) +} + \item Objects returned from forked processes, \code{FUN}, are serialized. This may cause problems for objects that are meant not to be serialized, like data.table. We are handling that for data.table class internally in \code{frollapply} whenever \code{FUN} is returning data.table (which is checked on the results of the first \code{FUN} call so it assumes function is type stable). If data.table is nested in another object returned from \code{FUN} then the problem may still manifest, in such case one has to call \code{setDT} on objects returned from \code{FUN}. This can be also nicely handled via \code{simplify} argument when passing a function that calls \code{setDT} on nested data.table objects returned from \code{FUN}. Anyway, returning data.table from \code{FUN} should, in majority of cases, be avoided from the performance reasons, see \emph{UDF optimization} section for details. +\preformatted{ +is.ok = function(x) {stopifnot(is.data.table(x)); format(attr(x, ".internal.selfref", TRUE))!=""} + +## frollapply will fix DT in most cases +ans = frollapply(1:2, 2, data.table, fill=data.table(NA)) +is.ok(ans) +#[1] TRUE +ans = frollapply(1:2, 2, data.table, fill=data.table(NA), simplify=FALSE) +is.ok(ans[[2L]]) +#[1] TRUE + +## nested DT not fixed +ans = frollapply(1:2, 2, function(x) list(data.table(x)), fill=list(data.table(NA)), simplify=FALSE) +is.ok(ans[[2L]][[1L]]) +#[1] FALSE +#### now if we want to use it +set(ans[[2L]][[1L]],, "newcol", 1L) +#Error in set(ans[[2L]][[1L]], , "newcol", 1L) : +# This data.table has either been loaded from disk (e.g. using readRDS()/load()) or constructed manually (e.g. using structure()). Please run setDT() or setalloccol() on it first (to pre-allocate space for new columns) before assigning by reference to it. +#### fix as explained in error message +ans = lapply(ans, lapply, setDT) +is.ok(ans[[2L]][[1L]]) +#[1] TRUE + +## fix inside frollapply via simplify +simplifix = function(x) lapply(x, lapply, setDT) +ans = frollapply(1:2, 2, function(x) list(data.table(x)), fill=list(data.table(NA)), simplify=simplifix) +is.ok(ans[[2L]][[1L]]) +#[1] TRUE + +## automatic fix may not work for a non-type stable function +f = function(x) (if (x[1L]==1L) data.frame else data.table)(x) +ans = frollapply(1:3, 2, f, fill=data.table(NA), simplify=FALSE) +is.ok(ans[[3L]]) +#[1] FALSE +#### fix inside frollapply via simplify +simplifix = function(x) lapply(x, function(y) if (is.data.table(y)) setDT(y) else y) +ans = frollapply(1:3, 2, f, fill=data.table(NA), simplify=simplifix) +is.ok(ans[[3L]]) +#[1] TRUE +} + } + \item Due to possible future improvements of handling simplification of results returned from rolling function, the default \code{simplify=TRUE} may not be backward compatible for functions that produce results that haven't been already automatically simplified. See \emph{\code{simplify} argument} section for details. + } +} +\section{Performance consideration}{ + \code{frollapply} is meant to run any UDF function. If one needs to use a common function like \emph{mean, sum, max}, etc., then we have highly optimized, implemented in C language, rolling functions described in \code{\link{froll}} manual.\cr + Most crucial optimizations are the ones to be applied on UDF. Those are discussed in next section \emph{UDF optimization} below. + \itemize{ + \item When using \code{by.column=FALSE} one can subset dataset before passing it to \code{X} to keep only columns relevant for the computation: +\preformatted{ +x = setDT(lapply(1:100, function(x) as.double(rep.int(x,1e4L)))) +f = function(x) sum(x$V1*x$V2) +system.time(frollapply(x, 100, f, by.column=FALSE)) +# user system elapsed +# 0.157 0.067 0.081 +system.time(frollapply(x[, c("V1","V2"), with=FALSE], 100, f, by.column=FALSE)) +# user system elapsed +# 0.096 0.054 0.054 +} + \item Avoid partial, see \emph{\code{partial} argument} section of \code{\link{froll}} manual. + \item Avoid \code{simplify=TRUE} and provide a function instead: +\preformatted{ +x = rnorm(1e5) +system.time(frollapply(x, 2, function(x) 1L, simplify=TRUE)) +# user system elapsed +# 0.308 0.076 0.196 +system.time(frollapply(x, 2, function(x) 1L, simplify=unlist)) +# user system elapsed +# 0.214 0.080 0.088 +} + \item CPU threads utilization in \code{frollapply} can be controlled by \code{\link{setDTthreads}}, which by default uses half of available CPU threads. + \item Optimization that avoids repeated allocation of a window subset (see \emph{Implementation} section for details), in case of adaptive rolling function, depends on R's \emph{growable bit}. This feature has been added in R 3.4.0. Adaptive \code{frollapply} will still work on older versions of R but, due to repeated allocation of window subset, it will be much slower. + \item Parallel computation of \code{FUN} is handled by \code{parallel} package (part of R core since 2.14.0) and its \emph{fork} mechanism. \emph{Fork} is not available on Windows OS therefore it will be always single threaded on that platform. + } +} +\section{UDF optimization}{ + FUN will be evaluated many times so should be highly optimized. Tips below are not specific to \code{frollapply} and can be applied to any code is meant to run in many iterations. + \itemize{ + \item It is usually better to return the most lightweight objects from \code{FUN}, for example it will be faster to return a list rather a data.table. In the case presented below, \code{simplify=TRUE} is calling \code{rbindlist} on the results anyway, which makes the results equal: +\preformatted{ +fun1 = function(x) {tmp=range(x); data.table(min=tmp[1L], max=tmp[2L])} +fun2 = function(x) {tmp=range(x); list(min=tmp[1L], max=tmp[2L])} +fill1 = data.table(min=NA_integer_, max=NA_integer_) +fill2 = list(min=NA_integer_, max=NA_integer_) +system.time(a<-frollapply(1:1e4, 100, fun1, fill=fill1)) +# user system elapsed +# 2.047 0.337 0.788 +system.time(b<-frollapply(1:1e4, 100, fun2, fill=fill2)) +# user system elapsed +# 0.205 0.125 0.138 +all.equal(a, b) +#[1] TRUE +} + \item Code that is not dependent on rolling window should be taken out as pre or post computation: +\preformatted{ +x = c(1L,3L) +system.time(for (i in 1:1e6) sum(x+1L)) +# user system elapsed +# 0.308 0.004 0.312 +system.time({y = x+1L; for (i in 1:1e6) sum(y)}) +# user system elapsed +# 0.203 0.000 0.202 +} + \item Being strict about data types removes the need for R to handle them automatically: +\preformatted{ +x = vector("integer", 1e6) +system.time(for (i in 1:1e6) x[i] = NA) +# user system elapsed +# 0.160 0.000 0.161 +system.time(for (i in 1:1e6) x[i] = NA_integer_) +# user system elapsed +# 0.05 0.00 0.05 +} + \item If a function calls another function under the hood, it is usually better to call the latter one directly: +\preformatted{ +x = matrix(c(1L,2L,3L,4L), c(2L,2L)) +system.time(for (i in 1:1e4) colSums(x)) +# user system elapsed +# 0.051 0.000 0.051 +system.time(for (i in 1:1e4) .colSums(x, 2L, 2L)) +# user system elapsed +# 0.015 0.000 0.015 +} + \item There are many functions that may be optimized for scaling up for bigger input, yet for a small input they may carry bigger overhead comparing to their simpler counterparts. One may need to experiment on own data, but low overhead functions are likely be faster when evaluating in many iterations: +\preformatted{ +## uniqueN +x = c(1L,3L,5L) +system.time(for (i in 1:1e4) uniqueN(x)) +# user system elapsed +# 0.156 0.004 0.160 +system.time(for (i in 1:1e4) length(unique(x))) +# user system elapsed +# 0.040 0.004 0.043 +## column subset +x = data.table(v1 = c(1L,3L,5L)) +system.time(for (i in 1:1e4) x[, v1]) +# user system elapsed +# 3.197 0.004 3.201 +system.time(for (i in 1:1e4) x[["v1"]]) +# user system elapsed +# 0.063 0.000 0.063 +} + } +} +\section{Implementation}{ + Evaluation of UDF comes with very limited capabilities for optimizations, therefore speed improvements in \code{frollapply} should not be expected as good as in other data.table fast functions. \code{frollapply} is implemented almost exclusively in R, rather than C. Its speed improvement comes from two optimizations that have been applied: + \enumerate{ + \item No repeated allocation of a rolling window subset.\cr + Object (type of \code{X} and size of \code{N}) is allocated once (for each CPU thread), and then for each iteration this object is being re-used by copying expected subset of data into it. This means we still have to subset data on each iteration, but we only copy data into pre-allocated window object, instead of allocating in each iteration. Allocation is carrying much bigger overhead than copy. The faster the \code{FUN} evaluates the more relative speedup we are getting, because allocation of a subset does not depend on how fast or slow \code{FUN} evaluates. See \emph{caveats} section for possible edge cases caused by this optimization. + \item Parallel evaluation of \code{FUN} calls.\cr + Until now (September 2025) all the multithreaded code in data.table was using \emph{OpenMP}. It can be used only in C language and it has very low overhead. Unfortunately it could not be applied in \code{frollapply} because to evaluate UDF from C code one has to call R's C api that is not thread safe (can be run only from single threaded C code). Therefore \code{frollapply} uses \code{\link[parallel]{parallel-package}} to provide parallelism on R language level. It uses \emph{fork} parallelism, which has low overhead as well (unless results of computation are big in size which is not an issue for rolling statistics). \emph{Fork} is not available on Windows OS. See \emph{caveats} section for limitations caused by using this optimization. + } +} +\examples{ +frollapply(1:16, 4, median) +frollapply(1:9, 3, toString) + +## vectorized input +x = list(1:10, 10:1) +n = c(3, 4) +frollapply(x, n, sum) +## give names +x = list(data1 = 1:10, data2 = 10:1) +n = c(small = 3, big = 4) +frollapply(x, n, sum, give.names=TRUE) + +## by.column=FALSE +x = as.data.table(iris) +flow = function(x) { + v1 = x[[1L]] + v2 = x[[2L]] + (v1[2L] - v1[1L] * (1+v2[2L])) / v1[1L] +} +x[, "flow" := frollapply(.(Sepal.Length, Sepal.Width), 2L, flow, by.column=FALSE), + by = Species][] + +## rolling regression: by.column=FALSE +f = function(x) coef(lm(v2 ~ v1, data=x)) +x = data.table(v1=rnorm(120), v2=rnorm(120)) +coef.fill = c("(Intercept)"=NA_real_, "v1"=NA_real_) +frollapply(x, 4, f, by.column=FALSE, fill=coef.fill) +} +\seealso{ + \code{\link{froll}}, \code{\link{shift}}, \code{\link{data.table}}, \code{\link{setDTthreads}} +} +\keyword{ data } diff --git a/src/data.table.h b/src/data.table.h index 983519dd43..badcbac1b2 100644 --- a/src/data.table.h +++ b/src/data.table.h @@ -244,11 +244,16 @@ void frolladaptivesumFast(double *x, uint64_t nx, ans_t *ans, int *k, double fil void frolladaptivesumExact(double *x, uint64_t nx, ans_t *ans, int *k, double fill, bool narm, int hasnf, bool verbose); //void frolladaptivemaxFast(double *x, uint64_t nx, ans_t *ans, int *k, double fill, bool narm, int hasnf, bool verbose); // does not exists as of now void frolladaptivemaxExact(double *x, uint64_t nx, ans_t *ans, int *k, double fill, bool narm, int hasnf, bool verbose); -void frolladaptiveapply(double *x, int64_t nx, SEXP pw, int *k, ans_t *ans, double fill, SEXP call, SEXP rho, bool verbose); // frollR.c SEXP frollfunR(SEXP fun, SEXP xobj, SEXP kobj, SEXP fill, SEXP algo, SEXP align, SEXP narm, SEXP hasnf, SEXP adaptive); -SEXP frollapplyR(SEXP fun, SEXP xobj, SEXP kobj, SEXP fill, SEXP align, SEXP adaptive, SEXP rho); + +// frollapply.c +SEXP memcpyVector(SEXP dest, SEXP src, SEXP offset, SEXP size); +SEXP memcpyDT(SEXP dest, SEXP src, SEXP offset, SEXP size); +SEXP memcpyVectoradaptive(SEXP dest, SEXP src, SEXP offset, SEXP size); +SEXP memcpyDTadaptive(SEXP dest, SEXP src, SEXP offset, SEXP size); +SEXP setgrowable(SEXP x); // nafill.c void nafillDouble(double *x, uint_fast64_t nx, unsigned int type, double fill, bool nan_is_na, ans_t *ans, bool verbose); diff --git a/src/froll.c b/src/froll.c index bf79e70af0..fe8bf46553 100644 --- a/src/froll.c +++ b/src/froll.c @@ -621,71 +621,3 @@ void frollmaxExact(double *x, uint64_t nx, ans_t *ans, int k, double fill, bool } } } - -/* fast rolling any R function - * not plain C, not thread safe - * R eval() allocates - */ -void frollapply(double *x, int64_t nx, double *w, int k, ans_t *ans, int align, double fill, SEXP call, SEXP rho, bool verbose) { - // early stopping for window bigger than input - if (nx < k) { - if (verbose) - Rprintf(_("%s: window width longer than input vector, returning all NA vector\n"), __func__); - for (int i=0; idbl_v[i] = fill; - } - return; - } - double tic = 0; - if (verbose) - tic = omp_get_wtime(); - for (int i=0; idbl_v[i] = fill; - } - // this is i=k-1 iteration - first full window - taken out from the loop - // we use it to add extra check that results of a FUN are length 1 numeric - memcpy(w, x, k*sizeof(double)); - SEXP eval0 = PROTECT(eval(call, rho)); - if (xlength(eval0) != 1) - error(_("%s: results from provided FUN are not length 1"), __func__); - SEXPTYPE teval0 = TYPEOF(eval0); - if (teval0 == REALSXP) { - ans->dbl_v[k-1] = REAL(eval0)[0]; - } else { - if (teval0==INTSXP || teval0==LGLSXP) { - if (verbose) - Rprintf(_("%s: results from provided FUN are not of type double, coercion from integer or logical will be applied on each iteration\n"), __func__); - ans->dbl_v[k-1] = REAL(coerceVector(eval0, REALSXP))[0]; - } else { - error(_("%s: results from provided FUN are not of type double"), __func__); - } - } - UNPROTECT(1); // eval0 - // for each row it copies expected window data into w - // evaluate call which has been prepared to point into w - if (teval0 == REALSXP) { - for (int64_t i=k; idbl_v[i] = REAL(eval(call, rho))[0]; // this may fail with for a not type-stable fun - } - } else { - for (int64_t i=k; idbl_v[i] = REAL(coerceVector(evali, REALSXP))[0]; - UNPROTECT(1); // evali - } - } - // align - if (ans->status < 3 && align < 1) { - int k_ = align==-1 ? k-1 : floor(k/2); - if (verbose) - Rprintf(_("%s: align %d, shift answer by %d\n"), __func__, align, -k_); - memmove((char *)ans->dbl_v, (char *)ans->dbl_v + (k_*sizeof(double)), (nx-k_)*sizeof(double)); - for (int64_t i=nx-k_; idbl_v[i] = fill; - } - } - if (verbose) - Rprintf(_("%s: took %.3fs\n"), __func__, omp_get_wtime()-tic); -} diff --git a/src/frollR.c b/src/frollR.c index 84ff3e60f2..df65c319b6 100644 --- a/src/frollR.c +++ b/src/frollR.c @@ -50,7 +50,7 @@ SEXP coerceK(SEXP obj, bool adaptive) { } else if (isReal(obj)) { SET_VECTOR_ELT(ans, 0, coerceVector(obj, INTSXP)); } else { - error(_("n must be integer vector or list of integer vectors")); + error(_("n must be an integer vector or list of an integer vectors")); } } else { int nk = length(obj); @@ -61,7 +61,7 @@ SEXP coerceK(SEXP obj, bool adaptive) { } else if (isReal(VECTOR_ELT(obj, i))) { SET_VECTOR_ELT(ans, i, coerceVector(VECTOR_ELT(obj, i), INTSXP)); } else { - error(_("n must be integer vector or list of integer vectors")); + error(_("n must be an integer vector or list of an integer vectors")); } } } @@ -208,121 +208,3 @@ SEXP frollfunR(SEXP fun, SEXP xobj, SEXP kobj, SEXP fill, SEXP algo, SEXP align, UNPROTECT(protecti); return isVectorAtomic(xobj) && length(ans) == 1 ? VECTOR_ELT(ans, 0) : ans; } - -// helper to find biggest window width for adaptive frollapply -int maxk(int *k, uint64_t len) { - int mk = k[0]; - for (uint64_t i=1; i mk) - mk = k[i]; - return mk; -} -SEXP frollapplyR(SEXP fun, SEXP xobj, SEXP kobj, SEXP fill, SEXP align, SEXP adaptive, SEXP rho) { - int protecti = 0; - const bool verbose = GetVerbose(); - - if (!isFunction(fun)) - internal_error(__func__, "'fun' must be a function"); // # nocov - if (!isEnvironment(rho)) - internal_error(__func__, "'rho' should be an environment"); // # nocov - - if (!xlength(xobj)) - return(xobj); - double tic = 0; - if (verbose) - tic = omp_get_wtime(); - SEXP x = PROTECT(coerceX(xobj)); protecti++; - R_len_t nx = length(x); - - if (xlength(kobj) == 0) - error(_("n must be non 0 length")); - - if (!IS_TRUE_OR_FALSE(adaptive)) - error(_("%s must be TRUE or FALSE"), "adaptive"); - bool badaptive = LOGICAL(adaptive)[0]; - - SEXP k = PROTECT(coerceK(kobj, badaptive)); protecti++; - int nk = length(k); - int *ik = NULL; int **lk = NULL; - if (!badaptive) { - ik = INTEGER(k); - } else { - lk = (int**)R_alloc(nk, sizeof(int*)); - for (int j=0; j 0 && (inx[i]!=inx[i-1])) - error(_("adaptive rolling function can only process 'x' having equal length of elements, like data.table or data.frame; If you want to call rolling function on list having variable length of elements call it for each field separately")); - if (xlength(VECTOR_ELT(k, j))!=inx[0]) - error(_("length of integer vector(s) provided as list to 'n' argument must be equal to number of observations provided in 'x'")); - } - SET_VECTOR_ELT(ans, i*nk+j, allocVector(REALSXP, inx[i])); - dans[i*nk+j] = ((ans_t) { .dbl_v=REAL(VECTOR_ELT(ans, i*nk+j)), .status=0, .message={"\0","\0","\0","\0"} }); - } - dx[i] = REAL(VECTOR_ELT(x, i)); - } - - SEXP pw, pc; - - // in the outer loop we handle vectorized k argument - // for each k we need to allocate a width window object: pw - // we also need to construct distinct R call pointing to that window - if (!badaptive) { - for (R_len_t j=0; jdbl_v[i] = fill; - } else { - SETLENGTH(pw, k[i]); - memcpy(w, x+(i-k[i]+1), k[i]*sizeof(double)); - SEXP eval0 = PROTECT(eval(call, rho)); - if (xlength(eval0) != 1) - error(_("%s: results from provided FUN are not length 1"), __func__); - teval0 = TYPEOF(eval0); - if (teval0 == REALSXP) { - ans->dbl_v[i] = REAL(eval0)[0]; - } else { - if (teval0==INTSXP || teval0==LGLSXP) { - if (verbose) - Rprintf(_("%s: results from provided FUN are not of type double, coercion from integer or logical will be applied on each iteration\n"), __func__); - ans->dbl_v[i] = REAL(coerceVector(eval0, REALSXP))[0]; - } else { - error(_("%s: results from provided FUN are not of type double"), __func__); - } - } - UNPROTECT(1); // eval0 - break; - } - } - if (i==nx) { // none of the windows in k was small enough to cover length of x - return; - } - // for each row it sets length of current window because it is adaptive version - // then copies expected window data into w - // evaluate call which has been prepared to point into w - if (teval0 == REALSXP) { - for (; idbl_v[i] = fill; // #nocov // this is never reached because smaller i are handled above, leaving it here because this function will be removed in next PR, and adapting it here will only make git conflicts resolution more difficult - } else { - SETLENGTH(pw, k[i]); - memcpy(w, x+(i-k[i]+1), k[i]*sizeof(double)); - ans->dbl_v[i] = REAL(eval(call, rho))[0]; // this may fail with for a not type-stable fun - } - } - } else { - for (; idbl_v[i] = fill; - } else { - SETLENGTH(pw, k[i]); - memcpy(w, x+(i-k[i]+1), k[i]*sizeof(double)); - SEXP evali = PROTECT(eval(call, rho)); - ans->dbl_v[i] = REAL(coerceVector(evali, REALSXP))[0]; - UNPROTECT(1); // evali - } - } - } - if (verbose) - Rprintf(_("%s: took %.3fs\n"), __func__, omp_get_wtime()-tic); -} diff --git a/src/frollapply.c b/src/frollapply.c new file mode 100644 index 0000000000..0778402241 --- /dev/null +++ b/src/frollapply.c @@ -0,0 +1,100 @@ +#include "data.table.h" + +#define MEMCPY \ +switch (TYPEOF(d)) { \ +case INTSXP: { \ + memcpy(INTEGER(d), INTEGER(s)+o, nrow*sizeof(int)); \ +} break; \ +case LGLSXP: { \ + memcpy(LOGICAL(d), LOGICAL(s)+o, nrow*sizeof(int)); \ +} break; \ +case REALSXP: { \ + memcpy(REAL(d), REAL(s)+o, nrow*sizeof(double)); \ +} break; \ +case STRSXP: { \ + for (int i=0; i