1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
|
#' Efficient Fold, Reduce, Accumulate, Combine of a Vector
#'
#' @param x A vector.
#'
#' @param f A binary function, i.e. a function take takes two arguments.
#'
#' @param left If `TRUE`, vector is combined from the left (the first element),
#' otherwise the right (the last element).
#'
#' @param unname If `TRUE`, function `f` is called as
#' \code{f(unname(y), x[[ii]])}, otherwise as \code{f(y, x[[ii]])},
#' which may introduce name `"y"`.
#'
#' @param threshold An integer (>= 2) specifying the length where the
#' recursive divide-and-conquer call will stop and incremental building of
#' the partial value is performed. Using `threshold = +Inf` will disable
#' recursive folding.
#'
#' @return A vector.
#'
#' @details
#' In order for recursive folding to give the same results as non-recursive
#' folding, binary function `f` must be _associative_ with itself, i.e.
#' \code{f(f(x[[1]], x[[2]]), x[[3]])} equals
#' \code{f(x[[1]], f(x[[2]]), x[[3]])}.
#'
#' This function is a more efficient (memory and speed) of
#' \code{\link[base:funprog]{Reduce(f, x, right = !left, accumulate = FALSE)}},
#' especially when `x` is long.
#'
#' @keywords internal
fold <- function(x, f, left = TRUE, unname = TRUE, threshold = 1000L) {
f <- match.fun(f)
n <- length(x)
if (n == 0L) return(NULL)
if (!is.vector(x) || is.object(x)) x <- as.list(x)
if (n == 1L) return(x[[1]])
stop_if_not(length(left) == 1, is.logical(left), !is.na(left))
stop_if_not(length(threshold) == 1, is.numeric(threshold),
!is.na(threshold), threshold >= 2)
if (n >= threshold) {
## Divide and conquer, i.e. split, build the two parts, and merge
n_mid <- n %/% 2
y_left <- Recall(f = f, x = x[ 1:n_mid], left = left,
unname = unname, threshold = threshold)
y_right <- Recall(f = f, x = x[(n_mid+1L):n], left = left,
unname = unname, threshold = threshold)
y <- f(y_left, y_right)
y_left <- y_right <- NULL
} else {
## Incrementally build result vector
if (left) {
y <- x[[1L]]
if (unname) {
for (ii in 2:n)
y <- forceAndCall(n = 2L, FUN = f, unname(y), x[[ii]])
} else {
for (ii in 2:n)
y <- forceAndCall(n = 2L, FUN = f, y, x[[ii]])
}
} else {
y <- x[[n]]
if (unname) {
for (ii in (n-1):1)
y <- forceAndCall(n = 2L, FUN = f, x[[ii]], unname(y))
} else {
for (ii in (n-1):1)
y <- forceAndCall(n = 2L, FUN = f, x[[ii]], y)
}
}
}
y
}
|
