R version 4.4.0 alpha (2024-03-26 r86209 ucrt)
Copyright (C) 2024 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> source("incl/start.R")
Loading required package: future
[15:32:42.841] plan(): Setting new future strategy stack:
[15:32:42.843] List of future strategies:
[15:32:42.843] 1. sequential:
[15:32:42.843]    - args: function (..., envir = parent.frame(), workers = "<NULL>")
[15:32:42.843]    - tweaked: FALSE
[15:32:42.843]    - call: future::plan("sequential")
[15:32:42.864] plan(): nbrOfWorkers() = 1
> 
> library("datasets") ## warpbreaks, iris
> 
> options(future.debug = FALSE)
> message("*** future_tapply() ...")
*** future_tapply() ...
> 
> for (strategy in supportedStrategies()[1]) {
+   message(sprintf("*** strategy = %s ...", sQuote(strategy)))
+   plan(strategy)
+ 
+   message("- From example(tapply) ...")
+ 
+   message("  - Example #1")
+   library("stats")  ## rbinom()
+   groups <- as.factor(stats::rbinom(32, n = 5, prob = 0.4))
+   t <- table(groups)
+   print(t)
+   y0 <- tapply(groups, INDEX = groups, FUN = length)
+   print(y0)
+   y1 <- future_tapply(groups, INDEX = groups, FUN = length)
+   print(y1)
+   stopifnot(all.equal(y1, y0))
+   y2 <- future_tapply(groups, INDEX = groups, FUN = "length")
+   print(y2)
+   stopifnot(all.equal(y2, y0))
+ 
+   message("  - Example #2")
+   ## contingency table from data.frame : array with named dimnames
+   y0 <- tapply(warpbreaks$breaks, INDEX = warpbreaks[,-1], FUN = sum)
+   print(y0)
+   y1 <- future_tapply(warpbreaks$breaks, INDEX = warpbreaks[,-1], FUN = sum)
+   print(y1)
+   stopifnot(all.equal(y1, y0))
+ 
+   message("  - Example #3")
+   y0 <- tapply(warpbreaks$breaks, warpbreaks[, 3, drop = FALSE], sum)
+   print(y0)
+   y1 <- future_tapply(warpbreaks$breaks, warpbreaks[, 3, drop = FALSE], sum)
+   print(y1)
+   stopifnot(all.equal(y1, y0))
+   
+   message("  - Example #4")
+   n <- 17
+   fac <- factor(rep_len(1:3, n), levels = 1:5)
+   t <- table(fac)  
+   y0 <- tapply(1:n, fac, sum)
+   print(y0)
+   y1 <- future_tapply(1:n, fac, sum)
+   print(y1)
+   stopifnot(all.equal(y1, y0))
+   
+   message("  - Example #5")
+   if ("default" %in% names(formals(tapply))) {
+     y0 <- tapply(1:n, fac, sum, default = 0) # maybe more desirable
+     print(y0)
+     y1 <- future_tapply(1:n, fac, sum, default = 0) # maybe more desirable
+     print(y1)
+     stopifnot(all.equal(y1, y0))
+   }
+   
+   message("  - Example #6")
+   y0 <- tapply(1:n, fac, sum, simplify = FALSE)
+   print(y0)
+   y1 <- future_tapply(1:n, fac, sum, simplify = FALSE)
+   print(y1)
+   stopifnot(all.equal(y1, y0))
+   
+   message("  - Example #7")
+   y0 <- tapply(1:n, fac, range)
+   print(y0)
+   y1 <- future_tapply(1:n, fac, range)
+   print(y1)
+   stopifnot(all.equal(y1, y0))
+   
+   message("  - Example #8")
+   y0 <- tapply(1:n, fac, quantile)
+   print(y0)
+   y1 <- future_tapply(1:n, fac, quantile)
+   print(y1)
+   stopifnot(all.equal(y1, y0))
+   
+   message("  - Example #9")
+   y0 <- tapply(1:n, fac, length) ## NA's
+   print(y0)
+   y1 <- future_tapply(1:n, fac, length) ## NA's
+   print(y1)
+   stopifnot(all.equal(y1, y0))
+   
+   message("  - Example #10")
+   if ("default" %in% names(formals(tapply))) {
+     y0 <- tapply(1:n, fac, length, default = 0) # == table(fac)
+     print(y0)
+     y1 <- future_tapply(1:n, fac, length, default = 0) # == table(fac)
+     print(y1)
+     stopifnot(all.equal(y1, y0))
+   }
+   
+   message("  - Example #11")
+   ## example of ... argument: find quarterly means
+   y0 <- tapply(presidents, cycle(presidents), mean, na.rm = TRUE)
+   print(y0)
+   y1 <- future_tapply(presidents, cycle(presidents), mean, na.rm = TRUE)
+   print(y1)
+   stopifnot(all.equal(y1, y0))
+   
+   message("  - Example #12")
+   ind <- list(c(1, 2, 2), c("A", "A", "B"))
+   t <- table(ind)
+   print(t)
+   y0 <- tapply(1:3, ind) #-> the split vector
+   print(y0)
+   y1 <- future_tapply(1:3, ind) #-> the split vector
+   print(y1)
+   stopifnot(all.equal(y1, y0))
+   
+   message("  - Example #13")
+   y0 <- tapply(1:3, ind, sum)
+   print(y0)
+   y1 <- future_tapply(1:3, ind, sum)
+   print(y1)
+   stopifnot(all.equal(y1, y0))
+   
+   ## Some assertions (not held by all patch propsals):
+   message("  - Example #14")
+   nq <- names(quantile(1:5))
+   y_truth <- c(1L, 2L, 4L)
+   stopifnot(identical(tapply(1:3, ind), y_truth))
+   stopifnot(identical(future_tapply(1:3, ind), y_truth))
+   
+   message("  - Example #15")
+   y_truth <- matrix(c(1L, 2L, NA, 3L), nrow = 2L,
+                     dimnames = list(c("1", "2"), c("A", "B")))
+   stopifnot(identical(tapply(1:3, ind, sum), y_truth))
+   stopifnot(identical(future_tapply(1:3, ind, sum), y_truth))
+   
+   message("  - Example #16")
+   y_truth <- array(list(
+     `2` = structure(c(2, 5.75, 9.5, 13.25, 17), .Names = nq),
+     `3` = structure(c(3, 6, 9, 12, 15), .Names = nq),
+     `4` = NULL, `5` = NULL),
+     dim = 4L, dimnames = list(as.character(2:5)))
+   stopifnot(identical(tapply(1:n, fac, quantile)[-1], y_truth))
+   stopifnot(identical(future_tapply(1:n, fac, quantile)[-1], y_truth))
+ 
+   if (getRversion() >= "4.3.0") {
+     data <- iris[, c("Sepal.Length", "Sepal.Width")]
+     y_truth <- tapply(data, INDEX = iris$Species, FUN = sum)
+     y <- future_tapply(data, INDEX = iris$Species, FUN = sum)
+     stopifnot(identical(y, y_truth))
+     
+     y_truth2 <- tapply(data, INDEX = ~ iris$Species + iris$Petal.Width, FUN = sum)
+     y2 <- future_tapply(data, INDEX = ~ iris$Species + iris$Petal.Width, FUN = sum)
+     stopifnot(identical(y2, y_truth2))
+   }
+ 
+   plan(sequential)
+   message(sprintf("*** strategy = %s ... done", sQuote(strategy)))
+ } ## for (strategy in ...) 
*** strategy = 'sequential' ...
- From example(tapply) ...
  - Example #1
groups
 9 12 13 14 
 1  1  2  1 
 9 12 13 14 
 1  1  2  1 
 9 12 13 14 
 1  1  2  1 
 9 12 13 14 
 1  1  2  1 
  - Example #2
    tension
wool   L   M   H
   A 401 216 221
   B 254 259 169
    tension
wool   L   M   H
   A 401 216 221
   B 254 259 169
  - Example #3
tension
  L   M   H 
655 475 390 
tension
  L   M   H 
655 475 390 
  - Example #4
 1  2  3  4  5 
51 57 45 NA NA 
 1  2  3  4  5 
51 57 45 NA NA 
  - Example #5
 1  2  3  4  5 
51 57 45  0  0 
 1  2  3  4  5 
51 57 45  0  0 
  - Example #6
$`1`
[1] 51

$`2`
[1] 57

$`3`
[1] 45

$`4`
NULL

$`5`
NULL

$`1`
[1] 51

$`2`
[1] 57

$`3`
[1] 45

$`4`
NULL

$`5`
NULL

  - Example #7
$`1`
[1]  1 16

$`2`
[1]  2 17

$`3`
[1]  3 15

$`4`
NULL

$`5`
NULL

$`1`
[1]  1 16

$`2`
[1]  2 17

$`3`
[1]  3 15

$`4`
NULL

$`5`
NULL

  - Example #8
$`1`
   0%   25%   50%   75%  100% 
 1.00  4.75  8.50 12.25 16.00 

$`2`
   0%   25%   50%   75%  100% 
 2.00  5.75  9.50 13.25 17.00 

$`3`
  0%  25%  50%  75% 100% 
   3    6    9   12   15 

$`4`
NULL

$`5`
NULL

$`1`
   0%   25%   50%   75%  100% 
 1.00  4.75  8.50 12.25 16.00 

$`2`
   0%   25%   50%   75%  100% 
 2.00  5.75  9.50 13.25 17.00 

$`3`
  0%  25%  50%  75% 100% 
   3    6    9   12   15 

$`4`
NULL

$`5`
NULL

  - Example #9
 1  2  3  4  5 
 6  6  5 NA NA 
 1  2  3  4  5 
 6  6  5 NA NA 
  - Example #10
1 2 3 4 5 
6 6 5 0 0 
1 2 3 4 5 
6 6 5 0 0 
  - Example #11
       1        2        3        4 
58.44828 56.43333 57.22222 53.07143 
       1        2        3        4 
58.44828 56.43333 57.22222 53.07143 
  - Example #12
     ind.2
ind.1 A B
    1 1 0
    2 1 1
[1] 1 2 4
[1] 1 2 4
  - Example #13
  A  B
1 1 NA
2 2  3
  A  B
1 1 NA
2 2  3
  - Example #14
  - Example #15
  - Example #16
*** strategy = 'sequential' ... done
> 
> 
> message("*** exceptions ...")
*** exceptions ...
> 
> ## Error: 'INDEX' is of length zero
> res <- tryCatch({
+   y <- future_tapply(1L, INDEX = list())
+ }, error = identity)
> stopifnot(inherits(res, "error"))
> 
> ## Error: total number of levels >= 2^31
> res <- tryCatch({
+   y <- future_tapply(1:216, INDEX = rep(list(1:216), times = 4L))
+ }, error = identity)
> stopifnot(inherits(res, "error"))
> 
> ## Error: arguments must have same length
> res <- tryCatch({
+   y <- future_tapply(1L, INDEX = list(1:2))
+ }, error = identity)
> stopifnot(inherits(res, "error"))
> 
> message("*** future_tapply() ... DONE")
*** future_tapply() ... DONE
> 
> source("incl/end.R")
> 
> proc.time()
   user  system elapsed 
   0.84    0.17    0.96