|
1 | | -froll = function(fun, x, n, fill=NA, algo=c("fast", "exact"), align=c("right", "left", "center"), na.rm=FALSE, hasNA=NA, adaptive=FALSE) { |
2 | | - stopifnot(!missing(fun), is.character(fun), length(fun)==1L, !is.na(fun)) |
3 | | - algo = match.arg(algo) |
| 1 | +# helpers for partial2adaptive |
| 2 | +trimn = function(n, len, align) { |
| 3 | + n = min(n, len) ## so frollsum(1:2, 3, partial=TRUE) works |
| 4 | + if (align=="right") |
| 5 | + c(seq_len(n), rep.int(n, len-n)) |
| 6 | + else |
| 7 | + c(rep.int(n, len-n), rev(seq_len(n))) |
| 8 | +} |
| 9 | +trimnadaptive = function(n, align) { |
| 10 | + if (align=="right") |
| 11 | + pmin(n, seq_along(n)) |
| 12 | + else |
| 13 | + pmin(n, rev(seq_along(n))) |
| 14 | +} |
| 15 | + |
| 16 | +# partial2adaptive helper function |
| 17 | +## tune provided 'n' via partial=TRUE to adaptive=TRUE by prepared adaptive 'n' as shown in ?froll examples |
| 18 | +# partial2adaptive(1:4, 2, "right", adaptive=FALSE) |
| 19 | +# partial2adaptive(1:4, 2:3, "right", adaptive=FALSE) |
| 20 | +# partial2adaptive(list(1:4, 2:5), 2:3, "right", adaptive=FALSE) |
| 21 | +# frollsum(1:4, 2, partial=FALSE, adaptive=FALSE) |
| 22 | +# frollsum(1:4, 2, partial=TRUE, adaptive=FALSE) |
| 23 | +# frollsum(1:4, 2:3, partial=FALSE, adaptive=FALSE) |
| 24 | +# frollsum(1:4, 2:3, partial=TRUE, adaptive=FALSE) |
| 25 | +# frollsum(list(1:4, 2:5), 2:3, partial=FALSE, adaptive=FALSE) |
| 26 | +# frollsum(list(1:4, 2:5), 2:3, partial=TRUE, adaptive=FALSE) |
| 27 | +partial2adaptive = function(x, n, align, adaptive) { |
| 28 | + if (!length(n)) |
| 29 | + stopf("n must be non 0 length") |
| 30 | + if (align=="center") |
| 31 | + stopf("'partial' cannot be used together with align='center'") |
| 32 | + if (is.list(x) && length(unique(lengths(x))) != 1L) |
| 33 | + stopf("'partial' does not support variable length of columns in 'x'") |
| 34 | + len = if (is.list(x)) length(x[[1L]]) else length(x) |
| 35 | + verbose = getOption("datatable.verbose") |
| 36 | + if (!adaptive) { |
| 37 | + if (is.list(n)) |
| 38 | + stopf("n must be an integer, list is accepted for adaptive TRUE") |
| 39 | + if (!is.numeric(n)) |
| 40 | + stopf("n must be an integer vector or a list of integer vectors") |
| 41 | + if (verbose) |
| 42 | + catf("partial2adaptive: froll partial=TRUE trimming 'n' and redirecting to adaptive=TRUE\n") |
| 43 | + if (length(n) > 1L) { |
| 44 | + ## c(2,3) -> list(c(1,2,2,2),c(1,2,3,3)) ## for x=1:4 |
| 45 | + lapply(n, len, align, FUN=trimn) |
| 46 | + } else { |
| 47 | + ## 3 -> c(1,2,3,3) ## for x=1:4 |
| 48 | + trimn(n, len, align) |
| 49 | + } |
| 50 | + } else { |
| 51 | + if (!(is.numeric(n) || (is.list(n) && all(vapply_1b(n, is.numeric))))) |
| 52 | + stopf("n must be an integer vector or a list of integer vectors") |
| 53 | + if (length(unique(lengths(n))) != 1L) |
| 54 | + stopf("adaptive window provided in 'n' must not to have different lengths") |
| 55 | + if (is.numeric(n) && length(n) != len) |
| 56 | + stopf("length of 'n' argument must be equal to number of observations provided in 'x'") |
| 57 | + if (is.list(n) && length(n[[1L]]) != len) |
| 58 | + stopf("length of vectors in 'x' must match to length of adaptive window in 'n'") |
| 59 | + if (verbose) |
| 60 | + catf("partial2adaptive: froll adaptive=TRUE and partial=TRUE trimming 'n'\n") |
| 61 | + if (is.numeric(n)) { |
| 62 | + ## c(3,3,3,2) -> c(1,2,3,2) ## for x=1:4 |
| 63 | + trimnadaptive(n, align) |
| 64 | + } else { |
| 65 | + ## list(c(3,3,3,2),c(4,2,3,3)) -> list(c(1,2,3,2),c(1,2,3,3)) ## for x=1:4 |
| 66 | + lapply(n, align, FUN = trimnadaptive) |
| 67 | + } |
| 68 | + } |
| 69 | +} |
| 70 | + |
| 71 | +# internal helper for handling give.names=TRUE |
| 72 | +make.roll.names = function(x.len, n.len, n, x.nm, n.nm, fun, adaptive) { |
| 73 | + if (is.null(n.nm)) { |
| 74 | + if (!adaptive) { |
| 75 | + if (!is.numeric(n)) |
| 76 | + stopf("internal error: misuse of make.roll.names, n must be numeric for !adaptive") ## nocov |
| 77 | + n.nm = paste0("roll", fun, as.character(as.integer(n))) |
| 78 | + } else { |
| 79 | + n.nm = paste0("aroll", fun, seq_len(n.len)) |
| 80 | + } |
| 81 | + } else if (!length(n.nm) && !adaptive) |
| 82 | + stopf("internal error: misuse of make.roll.names, non-null length 0 n is not possible for !adaptive") ## nocov |
| 83 | + if (is.null(x.nm)) { |
| 84 | + x.nm = paste0("V", seq_len(x.len)) |
| 85 | + } |
| 86 | + ans = if (length(x.nm)) { ## is.list(x) && !is.data.frame(x) |
| 87 | + if (length(n.nm)) { ## !adaptive || is.list(n) |
| 88 | + paste(rep(x.nm, each=length(n.nm)), n.nm, sep="_") |
| 89 | + } else { ## adaptive && is.numeric(n) |
| 90 | + x.nm |
| 91 | + } |
| 92 | + } else { ## (by.column && is.atomic(x)) || (!by.column && is.data.frame(x)) |
| 93 | + if (length(n.nm)) { ## !adaptive || is.list(n) |
| 94 | + n.nm |
| 95 | + } else { ## adaptive && is.numeric(n) |
| 96 | + 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 |
| 97 | + } |
| 98 | + } |
| 99 | + if (!is.null(ans) && length(ans) != x.len*n.len) |
| 100 | + stopf("internal error: make.roll.names generated names of wrong length") ## nocov |
| 101 | + ans |
| 102 | +} |
| 103 | + |
| 104 | +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) { |
4 | 105 | align = match.arg(align) |
5 | | - ans = .Call(CfrollfunR, fun, x, n, fill, algo, align, na.rm, hasNA, adaptive) |
| 106 | + if (isTRUE(give.names)) { |
| 107 | + orig = list(n=n, adaptive=adaptive) |
| 108 | + xnam = if (is.list(x)) names(x) else character() |
| 109 | + nnam = if (isTRUE(adaptive)) { |
| 110 | + if (is.list(n)) names(n) else character() |
| 111 | + } else names(n) |
| 112 | + nx = if (is.list(x)) length(x) else 1L |
| 113 | + nn = if (isTRUE(adaptive)) { |
| 114 | + if (is.list(n)) length(n) else 1L |
| 115 | + } else length(n) |
| 116 | + } |
| 117 | + if (isTRUE(partial)) { |
| 118 | + n = partial2adaptive(x, n, align, adaptive) |
| 119 | + adaptive = TRUE |
| 120 | + } |
| 121 | + leftadaptive = isTRUE(adaptive) && align=="left" |
| 122 | + if (leftadaptive) { |
| 123 | + verbose = getOption("datatable.verbose") |
| 124 | + rev2 = function(x) if (is.list(x)) lapply(x, rev) else rev(x) |
| 125 | + if (verbose) |
| 126 | + catf("froll: adaptive=TRUE && align='left' pre-processing for align='right'\n") |
| 127 | + x = rev2(x) |
| 128 | + n = rev2(n) |
| 129 | + align = "right" |
| 130 | + } ## support for left adaptive added in #5441 |
| 131 | + if (missing(FUN)) |
| 132 | + ans = .Call(CfrollfunR, fun, x, n, fill, algo, align, na.rm, has.nf, adaptive) |
| 133 | + else |
| 134 | + ans = .Call(CfrollapplyR, FUN, x, n, fill, align, adaptive, rho) |
| 135 | + if (leftadaptive) { |
| 136 | + if (verbose) |
| 137 | + catf("froll: adaptive=TRUE && align='left' post-processing from align='right'\n") |
| 138 | + ans = rev2(ans) |
| 139 | + } |
| 140 | + if (isTRUE(give.names) && is.list(ans)) { |
| 141 | + nms = make.roll.names(x.len=nx, n.len=nn, n=orig$n, x.nm=xnam, n.nm=nnam, fun=fun, adaptive=orig$adaptive) |
| 142 | + setattr(ans, "names", nms) |
| 143 | + } |
6 | 144 | ans |
7 | 145 | } |
8 | 146 |
|
9 | | -frollmean = function(x, n, fill=NA, algo=c("fast", "exact"), align=c("right", "left", "center"), na.rm=FALSE, hasNA=NA, adaptive=FALSE) { |
10 | | - froll(fun="mean", x=x, n=n, fill=fill, algo=algo, align=align, na.rm=na.rm, hasNA=hasNA, adaptive=adaptive) |
| 147 | +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) { |
| 148 | + stopifnot(!missing(fun), is.character(fun), length(fun)==1L, !is.na(fun)) |
| 149 | + if (!missing(hasNA)) { |
| 150 | + if (!is.na(has.nf)) |
| 151 | + stopf("hasNA is deprecated, use has.nf instead") |
| 152 | + warningf("hasNA is deprecated, use has.nf instead") |
| 153 | + has.nf = hasNA |
| 154 | + } # remove check on next major release |
| 155 | + algo = match.arg(algo) |
| 156 | + 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) |
| 157 | +} |
| 158 | + |
| 159 | +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) { |
| 160 | + 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) |
11 | 161 | } |
12 | | -frollsum = function(x, n, fill=NA, algo=c("fast","exact"), align=c("right", "left", "center"), na.rm=FALSE, hasNA=NA, adaptive=FALSE) { |
13 | | - froll(fun="sum", x=x, n=n, fill=fill, algo=algo, align=align, na.rm=na.rm, hasNA=hasNA, adaptive=adaptive) |
| 162 | +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) { |
| 163 | + 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) |
14 | 164 | } |
15 | | -frollapply = function(x, n, FUN, ..., fill=NA, align=c("right", "left", "center")) { |
| 165 | +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) { |
| 166 | + 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) |
| 167 | +} |
| 168 | + |
| 169 | +frollapply = function(x, n, FUN, ..., fill=NA, align=c("right","left","center"), adaptive=FALSE, partial=FALSE, give.names=FALSE) { |
16 | 170 | FUN = match.fun(FUN) |
17 | | - align = match.arg(align) |
18 | 171 | rho = new.env() |
19 | | - ans = .Call(CfrollapplyR, FUN, x, n, fill, align, rho) |
20 | | - ans |
| 172 | + froll(FUN=FUN, rho=rho, x=x, n=n, fill=fill, align=align, adaptive=adaptive, partial=partial, give.names=give.names) |
21 | 173 | } |
0 commit comments