Now all future_nnn() functions set a label on each future [#15]

NEWS

@@ -3,6 +3,12 @@ Package: future.apply
 
 Version: 1.3.0-9000 [2019-12-28]
 
+NEW FEATURES:
+
+ * Now all future_nnn() functions set a label on each future that reflects the
+   name of the future_nnn() function and the index of the chunk. The format
+   can be controlled by argument 'future.label'.
+
 BUG FIXES:
 
  * future_lapply(X) and future_mapply(FUN, X) would drop 'names' argument of

R/future_Map.R

@@ -16,7 +16,7 @@
 #' GPL (>= 2) with 'The R Core Team' as the copyright holder.
 #' 
 #' @rdname future_mapply
-future_Map <- function(f, ...) {
+future_Map <- function(f, ..., future.label = "future_Map-%d") {
   f <- match.fun(f)
-  future_mapply(FUN = f, ..., SIMPLIFY = FALSE)
+  future_mapply(FUN = f, ..., SIMPLIFY = FALSE, future.label = future.label)
 }

R/future_apply.R

@@ -32,8 +32,7 @@
 #' @example incl/future_apply.R
 #' 
 #' @export
-future_apply <- function(X, MARGIN, FUN, ...)
-{
+future_apply <- function(X, MARGIN, FUN, ..., future.label = "future_apply-%d") {
     FUN <- match.fun(FUN)
 
     ## Ensure that X is an array object
@@ -86,7 +85,7 @@ future_apply <- function(X, MARGIN, FUN, ...)
     } else
         newX <- lapply(1L:d2, FUN = function(i)
                        array(newX[,i], dim = d.call, dimnames = dn.call))
-    ans <- future_lapply(newX, FUN = FUN, ...)
+    ans <- future_lapply(newX, FUN = FUN, ..., future.label = future.label)
 
     ## answer dims and dimnames
 

R/future_by.R

@@ -63,7 +63,7 @@ future_by.data.frame <- function(data, INDICES, FUN, ..., simplify = TRUE) {
 
 
 
-future_by_internal <- function(data, INDICES, FUN, ..., simplify = TRUE, .SUBSETTER, .CALL, .INDICES.NAME) {
+future_by_internal <- function(data, INDICES, FUN, ..., simplify = TRUE, .SUBSETTER, .CALL, .INDICES.NAME, future.label = "future_by-%d") {
   FUN <- if (!is.null(FUN)) match.fun(FUN)
   stop_if_not(is.function(.SUBSETTER))
 
@@ -108,7 +108,7 @@ future_by_internal <- function(data, INDICES, FUN, ..., simplify = TRUE, .SUBSET
   group <- NULL ## Not needed anymore
 
   grouped_data <- lapply(X = ans[index], FUN = .SUBSETTER)
-  ans <- future_lapply(X = grouped_data, FUN = FUN, ...)
+  ans <- future_lapply(X = grouped_data, FUN = FUN, ..., future.label = future.label)
   grouped_data <- NULL  ## Not needed anymore
 
   ansmat <- array({

R/future_eapply.R

@@ -12,9 +12,9 @@
 #'
 #' @rdname future_lapply
 #' @export
-future_eapply <- function(env, FUN, ..., all.names = FALSE, USE.NAMES = TRUE) {
+future_eapply <- function(env, FUN, ..., all.names = FALSE, USE.NAMES = TRUE, future.label = "future_eapply-%d") {
   names <- ls(envir = env, all.names = all.names, sorted = FALSE)
   X <- mget(names, envir = env, inherits = FALSE)
   if (!USE.NAMES) names(X) <- NULL
-  future_lapply(X = X, FUN = FUN, ...)
+  future_lapply(X = X, FUN = FUN, ..., future.label = future.label)
 }

R/future_lapply.R

@@ -51,6 +51,11 @@
 #'        If `Inf`, then all elements are processed in a single future.
 #'        If `NULL`, then argument `future.scheduling` is used.
 #' 
+#' @param future.label If a character string, then each future is assigned
+#'        a label `sprintf(future.label, chunk_idx)`.  If TRUE, then the
+#'        same as `future.label = "future_lapply-%d"`.  If FALSE, no labels
+#'        are assigned.
+#'
 #' @return
 #' For `future_lapply()`, a list with same length and names as `X`.
 #' See [base::lapply()] for details.
@@ -134,7 +139,7 @@
 #' @importFrom future future resolve values as.FutureGlobals nbrOfWorkers getGlobalsAndPackages FutureError
 #' @importFrom utils head str
 #' @export
-future_lapply <- function(X, FUN, ..., future.stdout = TRUE, future.conditions = NULL, future.globals = TRUE, future.packages = NULL, future.lazy = FALSE, future.seed = FALSE, future.scheduling = 1.0, future.chunk.size = NULL) {
+future_lapply <- function(X, FUN, ..., future.stdout = TRUE, future.conditions = NULL, future.globals = TRUE, future.packages = NULL, future.lazy = FALSE, future.seed = FALSE, future.scheduling = 1.0, future.chunk.size = NULL, future.label = "future_lapply-%d") {
   stop_if_not(is.function(FUN))
 
   stop_if_not(is.logical(future.stdout), length(future.stdout) == 1L)
@@ -149,6 +154,9 @@ future_lapply <- function(X, FUN, ..., future.stdout = TRUE, future.conditions =
   stop_if_not(length(future.scheduling) == 1L, !is.na(future.scheduling),
             is.numeric(future.scheduling) || is.logical(future.scheduling))
 
+  stop_if_not(length(future.label) == 1L, !is.na(future.label),
+              is.logical(future.label) || is.character(future.label))
+
   ## Coerce to as.list()?
   if (!is.vector(X) || is.object(X)) X <- as.list(X)
 
@@ -247,6 +255,17 @@ future_lapply <- function(X, FUN, ..., future.stdout = TRUE, future.conditions =
   nchunks <- length(chunks)
   fs <- vector("list", length = nchunks)
   if (debug) mdebugf("Number of futures (= number of chunks): %d", nchunks)
+
+  ## Create labels?
+  if (isTRUE(future.label)) {
+    future.label <- "future_lapply-%d"
+  }
+  if (is.character(future.label)) {
+    labels <- sprintf(future.label, seq_len(nchunks))
+    stopifnot(length(labels) == nchunks)
+  } else {
+    labels <- NULL
+  }
 
   if (debug) mdebugf("Launching %d futures (chunks) ...", nchunks)
   for (ii in seq_along(chunks)) {
@@ -304,7 +323,7 @@ future_lapply <- function(X, FUN, ..., future.stdout = TRUE, future.conditions =
       if (debug) mdebugf(" - Adjusted option 'future.globals.maxSize': %g -> %d * %g = %g (bytes)", globals.maxSize.default, length(chunk), globals.maxSize.default, getOption("future.globals.maxSize"))
       on.exit(options(future.globals.maxSize = globals.maxSize), add = TRUE)
     }
-
+        
     ## Using RNG seeds or not?
     if (is.null(seeds)) {
       if (debug) mdebug(" - seeds: <none>")
@@ -323,7 +342,8 @@ future_lapply <- function(X, FUN, ..., future.stdout = TRUE, future.conditions =
          conditions = future.conditions,
          globals = globals_ii, packages = packages_ii,
          seed = future.seed,
-         lazy = future.lazy)
+         lazy = future.lazy,
+	 label = labels[[ii]])
     } else {
       if (debug) mdebugf(" - seeds: [%d] <seeds>", length(chunk))
       globals_ii[["...future.seeds_ii"]] <- seeds[chunk]
@@ -343,7 +363,8 @@ future_lapply <- function(X, FUN, ..., future.stdout = TRUE, future.conditions =
          conditions = future.conditions,
          globals = globals_ii, packages = packages_ii,
          seed = NULL,  ## As seed=FALSE but without the RNG check
-         lazy = future.lazy)
+         lazy = future.lazy,
+	 label = labels[[ii]])
     }
 
     ## Not needed anymore

R/future_mapply.R

@@ -45,7 +45,7 @@
 #' @importFrom future Future future resolve values as.FutureGlobals nbrOfWorkers getGlobalsAndPackages FutureError
 #' @importFrom utils head str
 #' @export
-future_mapply <- function(FUN, ..., MoreArgs = NULL, SIMPLIFY = TRUE, USE.NAMES = TRUE, future.stdout = TRUE, future.conditions = NULL, future.globals = TRUE, future.packages = NULL, future.lazy = FALSE, future.seed = FALSE, future.scheduling = 1.0, future.chunk.size = NULL) {
+future_mapply <- function(FUN, ..., MoreArgs = NULL, SIMPLIFY = TRUE, USE.NAMES = TRUE, future.stdout = TRUE, future.conditions = NULL, future.globals = TRUE, future.packages = NULL, future.lazy = FALSE, future.seed = FALSE, future.scheduling = 1.0, future.chunk.size = NULL, future.label = "future_mapply-%d") {
   FUN <- match.fun(FUN)
   stop_if_not(is.function(FUN))
 
@@ -92,6 +92,9 @@ future_mapply <- function(FUN, ..., MoreArgs = NULL, SIMPLIFY = TRUE, USE.NAMES
   stop_if_not(length(future.scheduling) == 1L, !is.na(future.scheduling),
             is.numeric(future.scheduling) || is.logical(future.scheduling))
 
+  stop_if_not(length(future.label) == 1L, !is.na(future.label),
+              is.logical(future.label) || is.character(future.label))
+
   debug <- getOption("future.debug", FALSE)
 
   if (debug) mdebug("future_mapply() ...")
@@ -182,7 +185,18 @@ future_mapply <- function(FUN, ..., MoreArgs = NULL, SIMPLIFY = TRUE, USE.NAMES
   nchunks <- length(chunks)
   fs <- vector("list", length = nchunks)
   if (debug) mdebugf("Number of futures (= number of chunks): %d", nchunks)
-
+
+  ## Create labels?
+  if (isTRUE(future.label)) {
+    future.label <- "future_mapply-%d"
+  }
+  if (is.character(future.label)) {
+    labels <- sprintf(future.label, seq_len(nchunks))
+    stopifnot(length(labels) == nchunks)
+  } else {
+    labels <- NULL
+  }
+
   if (debug) mdebugf("Launching %d futures (chunks) ...", nchunks)
   for (ii in seq_along(chunks)) {
     chunk <- chunks[[ii]]
@@ -256,7 +270,8 @@ future_mapply <- function(FUN, ..., MoreArgs = NULL, SIMPLIFY = TRUE, USE.NAMES
          conditions = future.conditions,
          globals = globals_ii, packages = packages_ii,
          seed = future.seed,
-         lazy = future.lazy)
+         lazy = future.lazy,
+	 label = labels[ii])
     } else {
       if (debug) mdebugf(" - seeds: [%d] <seeds>", length(chunk))
       globals_ii[["...future.seeds_ii"]] <- seeds[chunk]
@@ -277,7 +292,8 @@ future_mapply <- function(FUN, ..., MoreArgs = NULL, SIMPLIFY = TRUE, USE.NAMES
          conditions = future.conditions,
          globals = globals_ii, packages = packages_ii,
          seed = NULL,  ## As seed=FALSE but without the RNG check
-         lazy = future.lazy)
+         lazy = future.lazy,
+	 label = labels[ii])
     }
 
     ## Not needed anymore

R/future_replicate.R

@@ -16,8 +16,9 @@
 #'
 #' @rdname future_lapply
 future_replicate <- function(n, expr, simplify = "array",
-                             future.seed = TRUE, ...)
+                             future.seed = TRUE, ...,
+			     future.label = "future_replicate-%d")
   future_sapply(X = integer(n),
                 FUN = eval.parent(substitute(function(...)expr)),
                 simplify = simplify,
-                future.seed = future.seed, ...)
+                future.seed = future.seed, ..., future.label = future.label)

R/future_sapply.R

@@ -17,8 +17,8 @@
 #' 'The R Core Team' as the copyright holder.
 #' 
 #' @rdname future_lapply
-future_sapply <- function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE) {
-  answer <- future_lapply(X = X, FUN = FUN, ...)
+future_sapply <- function(X, FUN, ..., simplify = TRUE, USE.NAMES = TRUE, future.label = "future_sapply-%d") {
+  answer <- future_lapply(X = X, FUN = FUN, ..., future.label = future.label)
   if (USE.NAMES && is.character(X) && is.null(names(answer)))
     names(answer) <- X
 

R/future_tapply.R

@@ -15,7 +15,8 @@
 #' @rdname future_lapply
 #' @export
 future_tapply <- function(X, INDEX, FUN = NULL, ...,
-                          default = NA, simplify = TRUE) {
+                          default = NA, simplify = TRUE,
+			  future.label = "future_tapply-%d") {
   FUN <- if (!is.null(FUN)) 
     match.fun(FUN)
   if (!is.list(INDEX)) 
@@ -49,7 +50,7 @@ future_tapply <- function(X, INDEX, FUN = NULL, ...,
   ans <- split(X, f = group)
   names(ans) <- NULL
   index <- as.logical(lengths(ans))
-  ans <- future_lapply(X = ans[index], FUN = FUN, ...)
+  ans <- future_lapply(X = ans[index], FUN = FUN, ..., future.label = future.label)
 
   ansmat <- array({
     if (simplify && all(lengths(ans) == 1L)) {

R/future_vapply.R

@@ -13,7 +13,7 @@
 #' @export
 #'
 #' @rdname future_lapply
-future_vapply <- function(X, FUN, FUN.VALUE, ..., USE.NAMES = TRUE) {
+future_vapply <- function(X, FUN, FUN.VALUE, ..., USE.NAMES = TRUE, future.label = "future_vapply-%d") {
   ## Coerce to as.list()?
   if (!is.vector(X) || is.object(X)) X <- as.list(X)
 
@@ -44,7 +44,7 @@ future_vapply <- function(X, FUN, FUN.VALUE, ..., USE.NAMES = TRUE) {
     }
     stop_if_not(all(dim(value) == dim), typeof(value) %in% valid_types)
     value
-  }, ...)
+  }, ..., future.label = future.label)
 
   if (!is.null(dim)) {
     dim_res <- c(dim, n)