1#' Reduce a list to a single value by iteratively applying a binary function 2#' 3#' @description 4#' 5#' `reduce()` is an operation that combines the elements of a vector 6#' into a single value. The combination is driven by `.f`, a binary 7#' function that takes two values and returns a single value: reducing 8#' `f` over `1:3` computes the value `f(f(1, 2), 3)`. 9#' 10#' @inheritParams map 11#' @param .y For `reduce2()` and `accumulate2()`, an additional 12#' argument that is passed to `.f`. If `init` is not set, `.y` 13#' should be 1 element shorter than `.x`. 14#' @param .f For `reduce()`, and `accumulate()`, a 2-argument 15#' function. The function will be passed the accumulated value as 16#' the first argument and the "next" value as the second argument. 17#' 18#' For `reduce2()` and `accumulate2()`, a 3-argument function. The 19#' function will be passed the accumulated value as the first 20#' argument, the next value of `.x` as the second argument, and the 21#' next value of `.y` as the third argument. 22#' 23#' The reduction terminates early if `.f` returns a value wrapped in 24#' a [done()]. 25#' 26#' @param .init If supplied, will be used as the first value to start 27#' the accumulation, rather than using `.x[[1]]`. This is useful if 28#' you want to ensure that `reduce` returns a correct value when `.x` 29#' is empty. If missing, and `.x` is empty, will throw an error. 30#' @param .dir The direction of reduction as a string, one of 31#' `"forward"` (the default) or `"backward"`. See the section about 32#' direction below. 33#' 34#' @section Direction: 35#' 36#' When `.f` is an associative operation like `+` or `c()`, the 37#' direction of reduction does not matter. For instance, reducing the 38#' vector `1:3` with the binary function `+` computes the sum `((1 + 39#' 2) + 3)` from the left, and the same sum `(1 + (2 + 3))` from the 40#' right. 41#' 42#' In other cases, the direction has important consequences on the 43#' reduced value. For instance, reducing a vector with `list()` from 44#' the left produces a left-leaning nested list (or tree), while 45#' reducing `list()` from the right produces a right-leaning list. 46#' 47#' @section Life cycle: 48#' 49#' `reduce_right()` is soft-deprecated as of purrr 0.3.0. Please use 50#' the `.dir` argument of `reduce()` instead. Note that the algorithm 51#' has changed. Whereas `reduce_right()` computed `f(f(3, 2), 1)`, 52#' `reduce(.dir = \"backward\")` computes `f(1, f(2, 3))`. This is the 53#' standard way of reducing from the right. 54#' 55#' To update your code with the same reduction as `reduce_right()`, 56#' simply reverse your vector and use a left reduction: 57#' 58#' ```r 59#' # Before: 60#' reduce_right(1:3, f) 61#' 62#' # After: 63#' reduce(rev(1:3), f) 64#' ``` 65#' 66#' `reduce2_right()` is soft-deprecated as of purrr 0.3.0 without 67#' replacement. It is not clear what algorithmic properties should a 68#' right reduction have in this case. Please reach out if you know 69#' about a use case for a right reduction with a ternary function. 70#' 71#' @seealso [accumulate()] for a version that returns all intermediate 72#' values of the reduction. 73#' @examples 74#' # Reducing `+` computes the sum of a vector while reducing `*` 75#' # computes the product: 76#' 1:3 %>% reduce(`+`) 77#' 1:10 %>% reduce(`*`) 78#' 79#' # When the operation is associative, the direction of reduction 80#' # does not matter: 81#' reduce(1:4, `+`) 82#' reduce(1:4, `+`, .dir = "backward") 83#' 84#' # However with non-associative operations, the reduced value will 85#' # be different as a function of the direction. For instance, 86#' # `list()` will create left-leaning lists when reducing from the 87#' # right, and right-leaning lists otherwise: 88#' str(reduce(1:4, list)) 89#' str(reduce(1:4, list, .dir = "backward")) 90#' 91#' # reduce2() takes a ternary function and a second vector that is 92#' # one element smaller than the first vector: 93#' paste2 <- function(x, y, sep = ".") paste(x, y, sep = sep) 94#' letters[1:4] %>% reduce(paste2) 95#' letters[1:4] %>% reduce2(c("-", ".", "-"), paste2) 96#' 97#' x <- list(c(0, 1), c(2, 3), c(4, 5)) 98#' y <- list(c(6, 7), c(8, 9)) 99#' reduce2(x, y, paste) 100#' 101#' 102#' # You can shortcircuit a reduction and terminate it early by 103#' # returning a value wrapped in a done(). In the following example 104#' # we return early if the result-so-far, which is passed on the LHS, 105#' # meets a condition: 106#' paste3 <- function(out, input, sep = ".") { 107#' if (nchar(out) > 4) { 108#' return(done(out)) 109#' } 110#' paste(out, input, sep = sep) 111#' } 112#' letters %>% reduce(paste3) 113#' 114#' # Here the early return branch checks the incoming inputs passed on 115#' # the RHS: 116#' paste4 <- function(out, input, sep = ".") { 117#' if (input == "j") { 118#' return(done(out)) 119#' } 120#' paste(out, input, sep = sep) 121#' } 122#' letters %>% reduce(paste4) 123#' @export 124reduce <- function(.x, .f, ..., .init, .dir = c("forward", "backward")) { 125 reduce_impl(.x, .f, ..., .init = .init, .dir = .dir) 126} 127#' @rdname reduce 128#' @export 129reduce2 <- function(.x, .y, .f, ..., .init) { 130 reduce2_impl(.x, .y, .f, ..., .init = .init, .left = TRUE) 131} 132 133reduce_impl <- function(.x, .f, ..., .init, .dir, .acc = FALSE) { 134 left <- arg_match(.dir, c("forward", "backward")) == "forward" 135 136 out <- reduce_init(.x, .init, left = left) 137 idx <- reduce_index(.x, .init, left = left) 138 139 if (.acc) { 140 acc_out <- accum_init(out, idx, left = left) 141 acc_idx <- accum_index(acc_out, left = left) 142 } 143 144 .f <- as_mapper(.f, ...) 145 146 # Left-reduce passes the result-so-far on the left, right-reduce 147 # passes it on the right. A left-reduce produces left-leaning 148 # computation trees while right-reduce produces right-leaning trees. 149 if (left) { 150 fn <- .f 151 } else { 152 fn <- function(x, y, ...) .f(y, x, ...) 153 } 154 155 for (i in seq_along(idx)) { 156 prev <- out 157 elt <- .x[[idx[[i]]]] 158 159 if (has_force_and_call) { 160 out <- forceAndCall(2, fn, out, elt, ...) 161 } else { 162 out <- fn(out, elt, ...) 163 } 164 165 if (is_done_box(out)) { 166 return(reduce_early(out, prev, .acc, acc_out, acc_idx[[i]], left)) 167 } 168 169 if (.acc) { 170 acc_out[[acc_idx[[i]]]] <- out 171 } 172 } 173 174 if (.acc) { 175 acc_out 176 } else { 177 out 178 } 179} 180 181reduce_early <- function(out, prev, acc, acc_out, acc_idx, left = TRUE) { 182 if (is_done_box(out, empty = TRUE)) { 183 out <- prev 184 offset <- if (left) -1L else 1L 185 } else { 186 out <- unbox(out) 187 offset <- 0L 188 } 189 190 if (!acc) { 191 return(out) 192 } 193 194 acc_idx <- acc_idx + offset 195 acc_out[[acc_idx]] <- out 196 197 if (left) { 198 acc_out[seq_len(acc_idx)] 199 } else { 200 acc_out[seq(acc_idx, length(acc_out))] 201 } 202} 203 204reduce_init <- function(x, init, left = TRUE) { 205 if (!missing(init)) { 206 init 207 } else { 208 if (is_empty(x)) { 209 stop("`.x` is empty, and no `.init` supplied", call. = FALSE) 210 } else if (left) { 211 x[[1]] 212 } else { 213 x[[length(x)]] 214 } 215 } 216} 217reduce_index <- function(x, init, left = TRUE) { 218 n <- length(x) 219 220 if (left) { 221 if (missing(init)) { 222 seq_len2(2L, n) 223 } else { 224 seq_len(n) 225 } 226 } else { 227 if (missing(init)) { 228 rev(seq_len(n - 1L)) 229 } else { 230 rev(seq_len(n)) 231 } 232 } 233} 234 235accum_init <- function(first, idx, left) { 236 len <- length(idx) + 1L 237 out <- new_list(len) 238 239 if (left) { 240 out[[1]] <- first 241 } else { 242 out[[len]] <- first 243 } 244 245 out 246} 247accum_index <- function(out, left) { 248 n <- length(out) 249 250 if (left) { 251 seq_len2(2, n) 252 } else { 253 rev(seq_len(n - 1L)) 254 } 255} 256 257reduce2_impl <- function(.x, .y, .f, ..., .init, .left = TRUE, .acc = FALSE) { 258 out <- reduce_init(.x, .init, left = .left) 259 x_idx <- reduce_index(.x, .init, left = .left) 260 y_idx <- reduce_index(.y, NULL, left = .left) 261 262 if (length(x_idx) != length(y_idx)) { 263 stop("`.y` does not have length ", length(x_idx)) 264 } 265 266 .f <- as_mapper(.f, ...) 267 268 if (.acc) { 269 acc_out <- accum_init(out, x_idx, left = .left) 270 acc_idx <- accum_index(acc_out, left = .left) 271 } 272 273 for (i in seq_along(x_idx)) { 274 prev <- out 275 276 x_i <- x_idx[[i]] 277 y_i <- y_idx[[i]] 278 279 if (has_force_and_call) { 280 out <- forceAndCall(3, .f, out, .x[[x_i]], .y[[y_i]], ...) 281 } else { 282 out <- .f(out, .x[[x_i]], .y[[y_i]], ...) 283 } 284 285 if (is_done_box(out)) { 286 return(reduce_early(out, prev, .acc, acc_out, acc_idx[[i]])) 287 } 288 289 if (.acc) { 290 acc_out[[acc_idx[[i]]]] <- out 291 } 292 } 293 294 if (.acc) { 295 acc_out 296 } else { 297 out 298 } 299} 300 301seq_len2 <- function(start, end) { 302 if (start > end) { 303 return(integer(0)) 304 } 305 306 start:end 307} 308 309#' Accumulate intermediate results of a vector reduction 310#' 311#' @description 312#' 313#' `accumulate()` sequentially applies a 2-argument function to elements of a 314#' vector. Each application of the function uses the initial value or result 315#' of the previous application as the first argument. The second argument is 316#' the next value of the vector. The results of each application are 317#' returned in a list. The accumulation can optionally terminate before 318#' processing the whole vector in response to a `done()` signal returned by 319#' the accumulation function. 320#' 321#' By contrast to `accumulate()`, `reduce()` applies a 2-argument function in 322#' the same way, but discards all results except that of the final function 323#' application. 324#' 325#' `accumulate2()` sequentially applies a function to elements of two lists, `.x` and `.y`. 326#' 327#' @inheritParams map 328#' 329#' @param .y For `accumulate2()` `.y` is the second argument of the pair. It 330#' needs to be 1 element shorter than the vector to be accumulated (`.x`). 331#' If `.init` is set, `.y` needs to be one element shorted than the 332#' concatenation of the initial value and `.x`. 333#' 334#' @param .f For `accumulate()` `.f` is 2-argument function. The function will 335#' be passed the accumulated result or initial value as the first argument. 336#' The next value in sequence is passed as the second argument. 337#' 338#' For `accumulate2()`, a 3-argument function. The 339#' function will be passed the accumulated result as the first 340#' argument. The next value in sequence from `.x` is passed as the second argument. The 341#' next value in sequence from `.y` is passed as the third argument. 342#' 343#' The accumulation terminates early if `.f` returns a value wrapped in 344#' a [done()]. 345#' 346#' @param .init If supplied, will be used as the first value to start 347#' the accumulation, rather than using `.x[[1]]`. This is useful if 348#' you want to ensure that `reduce` returns a correct value when `.x` 349#' is empty. If missing, and `.x` is empty, will throw an error. 350#' 351#' @param .dir The direction of accumulation as a string, one of 352#' `"forward"` (the default) or `"backward"`. See the section about 353#' direction below. 354#' 355#' @return A vector the same length of `.x` with the same names as `.x`. 356#' 357#' If `.init` is supplied, the length is extended by 1. If `.x` has 358#' names, the initial value is given the name `".init"`, otherwise 359#' the returned vector is kept unnamed. 360#' 361#' If `.dir` is `"forward"` (the default), the first element is the 362#' initial value (`.init` if supplied, or the first element of `.x`) 363#' and the last element is the final reduced value. In case of a 364#' right accumulation, this order is reversed. 365#' 366#' The accumulation terminates early if `.f` returns a value wrapped 367#' in a [done()]. If the done box is empty, the last value is 368#' used instead and the result is one element shorter (but always 369#' includes the initial value, even when terminating at the first 370#' iteration). 371#' 372#' @inheritSection reduce Direction 373#' 374#' @section Life cycle: 375#' 376#' `accumulate_right()` is soft-deprecated in favour of the `.dir` 377#' argument as of rlang 0.3.0. Note that the algorithm has 378#' slightly changed: the accumulated value is passed to the right 379#' rather than the left, which is consistent with a right reduction. 380#' 381#' @seealso [reduce()] when you only need the final reduced value. 382#' @examples 383#' # With an associative operation, the final value is always the 384#' # same, no matter the direction. You'll find it in the last element for a 385#' # backward (left) accumulation, and in the first element for forward 386#' # (right) one: 387#' 1:5 %>% accumulate(`+`) 388#' 1:5 %>% accumulate(`+`, .dir = "backward") 389#' 390#' # The final value is always equal to the equivalent reduction: 391#' 1:5 %>% reduce(`+`) 392#' 393#' # It is easier to understand the details of the reduction with 394#' # `paste()`. 395#' accumulate(letters[1:5], paste, sep = ".") 396#' 397#' # Note how the intermediary reduced values are passed to the left 398#' # with a left reduction, and to the right otherwise: 399#' accumulate(letters[1:5], paste, sep = ".", .dir = "backward") 400#' 401#' # `accumulate2()` is a version of `accumulate()` that works with 402#' # 3-argument functions and one additional vector: 403#' paste2 <- function(x, y, sep = ".") paste(x, y, sep = sep) 404#' letters[1:4] %>% accumulate(paste2) 405#' letters[1:4] %>% accumulate2(c("-", ".", "-"), paste2) 406#' 407#' 408#' # You can shortcircuit an accumulation and terminate it early by 409#' # returning a value wrapped in a done(). In the following example 410#' # we return early if the result-so-far, which is passed on the LHS, 411#' # meets a condition: 412#' paste3 <- function(out, input, sep = ".") { 413#' if (nchar(out) > 4) { 414#' return(done(out)) 415#' } 416#' paste(out, input, sep = sep) 417#' } 418#' letters %>% accumulate(paste3) 419#' 420#' # Note how we get twice the same value in the accumulation. That's 421#' # because we have returned it twice. To prevent this, return an empty 422#' # done box to signal to accumulate() that it should terminate with the 423#' # value of the last iteration: 424#' paste3 <- function(out, input, sep = ".") { 425#' if (nchar(out) > 4) { 426#' return(done()) 427#' } 428#' paste(out, input, sep = sep) 429#' } 430#' letters %>% accumulate(paste3) 431#' 432#' # Here the early return branch checks the incoming inputs passed on 433#' # the RHS: 434#' paste4 <- function(out, input, sep = ".") { 435#' if (input == "f") { 436#' return(done()) 437#' } 438#' paste(out, input, sep = sep) 439#' } 440#' letters %>% accumulate(paste4) 441#' 442#' 443#' # Simulating stochastic processes with drift 444#' \dontrun{ 445#' library(dplyr) 446#' library(ggplot2) 447#' 448#' rerun(5, rnorm(100)) %>% 449#' set_names(paste0("sim", 1:5)) %>% 450#' map(~ accumulate(., ~ .05 + .x + .y)) %>% 451#' map_dfr(~ tibble(value = .x, step = 1:100), .id = "simulation") %>% 452#' ggplot(aes(x = step, y = value)) + 453#' geom_line(aes(color = simulation)) + 454#' ggtitle("Simulations of a random walk with drift") 455#' } 456#' @export 457accumulate <- function(.x, .f, ..., .init, .dir = c("forward", "backward")) { 458 .dir <- arg_match(.dir, c("forward", "backward")) 459 .f <- as_mapper(.f, ...) 460 461 res <- reduce_impl(.x, .f, ..., .init = .init, .dir = .dir, .acc = TRUE) 462 names(res) <- accumulate_names(names(.x), .init, .dir) 463 464 # FIXME vctrs: This simplification step is for compatibility with 465 # the `base::Reduce()` implementation in earlier purrr versions 466 if (all(map_int(res, length) == 1L)) { 467 res <- unlist(res, recursive = FALSE) 468 } 469 470 res 471} 472#' @rdname accumulate 473#' @export 474accumulate2 <- function(.x, .y, .f, ..., .init) { 475 reduce2_impl(.x, .y, .f, ..., .init = .init, .acc = TRUE) 476} 477 478accumulate_names <- function(nms, init, dir) { 479 if (is_null(nms)) { 480 return(NULL) 481 } 482 483 if (!missing(init)) { 484 nms <- c(".init", nms) 485 } 486 if (dir == "backward") { 487 nms <- rev(nms) 488 } 489 490 nms 491} 492 493#' Reduce from the right (retired) 494#' 495#' @description 496#' 497#' \Sexpr[results=rd, stage=render]{purrr:::lifecycle("soft-deprecated")} 498#' 499#' These functions are retired as of purrr 0.3.0. Please use the 500#' `.dir` argument of [reduce()] instead, or reverse your vectors 501#' and use a left reduction. 502#' 503#' @inheritParams reduce 504#' 505#' @keywords internal 506#' @export 507reduce_right <- function(.x, .f, ..., .init) { 508 signal_soft_deprecated(paste_line( 509 "`reduce_right()` is soft-deprecated as of purrr 0.3.0.", 510 "Please use the new `.dir` argument of `reduce()` instead.", 511 "", 512 " # Before:", 513 " reduce_right(1:3, f)", 514 "", 515 " # After:", 516 " reduce(1:3, f, .dir = \"backward\") # New algorithm", 517 " reduce(rev(1:3), f) # Same algorithm as reduce_right()", 518 "" 519 )) 520 .x <- rev(.x) # Compatibility 521 reduce_impl(.x, .f, ..., .dir = "forward", .init = .init) 522} 523#' @rdname reduce_right 524#' @export 525reduce2_right <- function(.x, .y, .f, ..., .init) { 526 signal_soft_deprecated(paste_line( 527 "`reduce2_right()` is soft-deprecated as of purrr 0.3.0.", 528 "Please reverse your vectors and use `reduce2()` instead.", 529 "", 530 " # Before:", 531 " reduce2_right(x, y, f)", 532 "", 533 " # After:", 534 " reduce2(rev(x), rev(y), f)", 535 "" 536 )) 537 reduce2_impl(.x, .y, .f, ..., .init = .init, .left = FALSE) 538} 539 540#' @rdname reduce_right 541#' @export 542accumulate_right <- function(.x, .f, ..., .init) { 543 signal_soft_deprecated(paste_line( 544 "`accumulate_right()` is soft-deprecated as of purrr 0.3.0.", 545 "Please use the new `.dir` argument of `accumulate()` instead.", 546 "", 547 " # Before:", 548 " accumulate_right(x, f)", 549 "", 550 " # After:", 551 " accumulate(x, f, .dir = \"backward\")", 552 "" 553 )) 554 555 # Note the order of arguments is switched 556 f <- function(y, x) { 557 .f(x, y, ...) 558 } 559 560 accumulate(.x, f, .init = .init, .dir = "backward") 561} 562