R Under development (unstable) (2025-06-05 r88281 ucrt) -- "Unsuffered Consequences" Copyright (C) 2025 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: parallelly Loading required package: future > > if (requireNamespace("future.apply", quietly = TRUE)) { + future_lapply <- future.apply::future_lapply + library("listenv") + + ## Setup all strategies including custom once for testing on HPC environments + print(all_strategies()) + + message("All HPC strategies:") + strategies <- c("batchtools_lsf", "batchtools_openlava", "batchtools_sge", + "batchtools_slurm", "batchtools_torque") + mprint(strategies, debug = TRUE) + + message("Supported HPC strategies:") + strategies <- strategies[sapply(strategies, FUN = test_strategy)] + mprint(strategies, debug = TRUE) + + strategies <- c("batchtools_local", strategies) + + if (fullTest) { + strategies <- c("batchtools_interactive", strategies) + + batchtools_custom_local <- function(expr, substitute = TRUE, + cluster.functions = batchtools::makeClusterFunctionsInteractive(external = TRUE), ...) { + if (substitute) expr <- substitute(expr) + batchtools_custom(expr, substitute = FALSE, ..., + cluster.functions = cluster.functions) + } + class(batchtools_custom_local) <- c("batchtools_custom_local", + class(batchtools_custom)) + strategies <- c("batchtools_custom_local", strategies) + } + + ## CRAN processing times: Don't run these tests on Windows 32-bit + if (!fullTest && isWin32) strategies <- character(0L) + + message("Strategies to test with:") + mprint(strategies, debug = TRUE) + + + message("*** future_lapply() ...") + + message("- future_lapply(x, FUN = vector, ...) ...") + + x <- list(a = "integer", c = "character", c = "list") + str(list(x = x)) + + y0 <- lapply(x, FUN = vector, length = 2L) + str(list(y0 = y0)) + + for (strategy in strategies) { + mprintf("- plan('%s') ...\n", strategy) + plan(strategy) + mprint(plan, debug = TRUE) + if (nbrOfWorkers() > 2) plan(strategy, workers = 2L) + stopifnot(nbrOfWorkers() < Inf) + + for (scheduling in list(FALSE, TRUE)) { + y <- future_lapply(x, FUN = vector, length = 2L, + future.scheduling = scheduling) + str(list(y = y)) + stopifnot(identical(y, y0)) + } + } + + + message("- future_lapply(x, FUN = base::vector, ...) ...") + + x <- list(a = "integer", c = "character", c = "list") + str(list(x = x)) + + y0 <- lapply(x, FUN = base::vector, length = 2L) + str(list(y0 = y0)) + + for (strategy in strategies) { + mprintf("- plan('%s') ...\n", strategy) + plan(strategy) + mprint(plan, debug = TRUE) + if (nbrOfWorkers() > 2) plan(strategy, workers = 2L) + stopifnot(nbrOfWorkers() < Inf) + + for (scheduling in list(FALSE, TRUE)) { + y <- future_lapply(x, FUN = base::vector, length = 2L, + future.scheduling = scheduling) + str(list(y = y)) + stopifnot(identical(y, y0)) + } + } + + message("- future_lapply(x, FUN = future:::hpaste, ...) ...") + + x <- list(a = c("hello", b = 1:100)) + str(list(x = x)) + + y0 <- lapply(x, FUN = future:::hpaste, collapse = "; ", maxHead = 3L) + str(list(y0 = y0)) + + for (strategy in strategies) { + mprintf("- plan('%s') ...\n", strategy) + plan(strategy) + mprint(plan, debug = TRUE) + if (nbrOfWorkers() > 2) plan(strategy, workers = 2L) + stopifnot(nbrOfWorkers() < Inf) + + for (scheduling in list(FALSE, TRUE)) { + y <- future_lapply(x, FUN = future:::hpaste, collapse = "; ", + maxHead = 3L, future.scheduling = scheduling) + str(list(y = y)) + stopifnot(identical(y, y0)) + } + } + + + message("- future_lapply(x, FUN = listenv::listenv, ...) ...") + + x <- list() + + y <- listenv() + y$A <- 3L + x$a <- y + + y <- listenv() + y$A <- 3L + y$B <- c("hello", b = 1:100) + x$b <- y + + print(x) + + y0 <- lapply(x, FUN = listenv::mapping) + str(list(y0 = y0)) + + for (strategy in strategies) { + mprintf("- plan('%s') ...\n", strategy) + plan(strategy) + if (nbrOfWorkers() > 2) plan(strategy, workers = 2L) + stopifnot(nbrOfWorkers() < Inf) + + for (scheduling in list(FALSE, TRUE)) { + y <- future_lapply(x, FUN = listenv::mapping, future.scheduling = scheduling) + str(list(y = y)) + stopifnot(identical(y, y0)) + } + } + + + message("- future_lapply(x, FUN, ...) for large length(x) ...") + a <- 3.14 + x <- 1:1e5 + + y <- future_lapply(x, FUN = function(z) sqrt(z + a)) + y <- unlist(y, use.names = FALSE) + + stopifnot(all.equal(y, sqrt(x + a))) + + + message("- future_lapply() with global in non-attached package ...") + library("tools") + my_ext <- function(x) file_ext(x) + y_truth <- lapply("abc.txt", FUN = my_ext) + + for (strategy in strategies) { + plan(strategy) + if (nbrOfWorkers() > 2) plan(strategy, workers = 2L) + stopifnot(nbrOfWorkers() < Inf) + y <- future_lapply("abc.txt", FUN = my_ext) + stopifnot(identical(y, y_truth)) + } + + message("*** future_lapply() ... DONE") + } [1] "sequential" "multisession" "cluster" All HPC strategies: [04:40:01.390] [1] "batchtools_lsf" "batchtools_openlava" "batchtools_sge" [04:40:01.390] [4] "batchtools_slurm" "batchtools_torque" Supported HPC strategies: [04:40:01.400] character(0) Strategies to test with: [04:40:01.402] [1] "batchtools_local" *** future_lapply() ... - future_lapply(x, FUN = vector, ...) ... List of 1 $ x:List of 3 ..$ a: chr "integer" ..$ c: chr "character" ..$ c: chr "list" List of 1 $ y0:List of 3 ..$ a: int [1:2] 0 0 ..$ c: chr [1:2] "" "" ..$ c:List of 2 .. ..$ : NULL .. ..$ : NULL - plan('batchtools_local') ... [04:40:01.435] function (strategy = NULL, ..., substitute = TRUE, .skip = FALSE, [04:40:01.435] .call = TRUE, .cleanup = NA, .init = TRUE) [04:40:01.435] { [04:40:01.435] if (substitute) [04:40:01.435] strategy <- substitute(strategy) [04:40:01.435] if (is.logical(.skip)) [04:40:01.435] stop_if_not(length(.skip) == 1L, !is.na(.skip)) [04:40:01.435] if (is.logical(.call)) [04:40:01.435] stop_if_not(length(.call) == 1L, !is.na(.call)) [04:40:01.435] debug <- isTRUE(getOption("future.debug")) [04:40:01.435] if (debug) { [04:40:01.435] mdebugf_push("plan(<%s>, .skip = %s, .cleanup = %s, .init = %s) ...", [04:40:01.435] class(strategy)[1], .skip, .cleanup, .init) [04:40:01.435] on.exit(mdebug_pop()) [04:40:01.435] } [04:40:01.435] if (is.null(stack)) { [04:40:01.435] stack <<- plan_default_stack() [04:40:01.435] if (debug) [04:40:01.435] mdebug("Created default stack") [04:40:01.435] } [04:40:01.435] if (identical(strategy, "backend")) { [04:40:01.435] strategy <- stack[[1L]] [04:40:01.435] backend <- attr(strategy, "backend") [04:40:01.435] if (is.null(backend)) { [04:40:01.435] strategy <- plan_init(strategy, debug = debug) [04:40:01.435] stack[[1L]] <<- strategy [04:40:01.435] backend <- attr(strategy, "backend") [04:40:01.435] } [04:40:01.435] return(backend) [04:40:01.435] } [04:40:01.435] else if (is.null(strategy) || identical(strategy, "next")) { [04:40:01.435] strategy <- stack[[1L]] [04:40:01.435] if (!inherits(strategy, "FutureStrategy")) { [04:40:01.435] class(strategy) <- c("FutureStrategy", class(strategy)) [04:40:01.435] } [04:40:01.435] stop_if_not(is.function(strategy)) [04:40:01.435] if (debug) [04:40:01.435] mdebugf("Getting current (\"next\") strategy: %s", [04:40:01.435] commaq(class(strategy))) [04:40:01.435] return(strategy) [04:40:01.435] } [04:40:01.435] else if (identical(strategy, "default")) { [04:40:01.435] strategy <- getOption("future.plan") [04:40:01.435] if (is.null(strategy)) [04:40:01.435] strategy <- sequential [04:40:01.435] if (debug) [04:40:01.435] mdebugf("Getting default stack: %s", commaq(class(strategy))) [04:40:01.435] } [04:40:01.435] else if (identical(strategy, "list")) { [04:40:01.435] if (debug) [04:40:01.435] mdebugf("Getting full stack: [n=%d] %s", length(stack), [04:40:01.435] commaq(sapply(stack, FUN = class))) [04:40:01.435] if (all(c("codalm", "testthat") %in% loadedNamespaces())) { [04:40:01.435] ignore <- c("init", "backend") [04:40:01.435] class <- class(stack) [04:40:01.435] stack <- lapply(stack, FUN = function(s) { [04:40:01.435] for (name in ignore) attr(s, name) <- NULL [04:40:01.435] s [04:40:01.435] }) [04:40:01.435] class(stack) <- class [04:40:01.435] } [04:40:01.435] return(stack) [04:40:01.435] } [04:40:01.435] else if (identical(strategy, "tail")) { [04:40:01.435] stack <- stack[-1] [04:40:01.435] if (debug) [04:40:01.435] mdebugf("Getting stack without first backend: [n=%d] %s", [04:40:01.435] length(stack), commaq(sapply(stack, FUN = class))) [04:40:01.435] return(stack) [04:40:01.435] } [04:40:01.435] else if (identical(strategy, "reset")) { [04:40:01.435] if (debug) [04:40:01.435] mdebug_push("Resetting stack ...") [04:40:01.435] plan_cleanup(stack[[1]], cleanup = .cleanup, debug = debug) [04:40:01.435] stack <<- plan_default_stack() [04:40:01.435] if (debug) [04:40:01.435] mdebug_pop() [04:40:01.435] return(stack) [04:40:01.435] } [04:40:01.435] else if (identical(strategy, "pop")) { [04:40:01.435] if (debug) [04:40:01.435] mdebug_push("Popping stack ...") [04:40:01.435] oldStack <- stack [04:40:01.435] stack <<- stack[-1L] [04:40:01.435] if (length(stack) == 0L) [04:40:01.435] stack <<- plan_default_stack() [04:40:01.435] if (debug) [04:40:01.435] mdebug_pop() [04:40:01.435] return(oldStack) [04:40:01.435] } [04:40:01.435] oldStack <- stack [04:40:01.435] newStack <- NULL [04:40:01.435] targs <- list(...) [04:40:01.435] if (is.function(strategy)) { [04:40:01.435] if (length(targs) > 0) { [04:40:01.435] args <- c(list(strategy), targs, penvir = parent.frame()) [04:40:01.435] strategy <- do.call(tweak, args = args) [04:40:01.435] } [04:40:01.435] strategy <- list(strategy) [04:40:01.435] } [04:40:01.435] if (is.list(strategy)) { [04:40:01.435] oldStack <- plan_set(strategy, skip = .skip, cleanup = .cleanup, [04:40:01.435] init = .init, debug = debug) [04:40:01.435] return(invisible(oldStack)) [04:40:01.435] } [04:40:01.435] if (is.language(strategy)) { [04:40:01.435] first <- as.list(strategy)[[1]] [04:40:01.435] if (is.symbol(first)) { [04:40:01.435] if (is.call(strategy)) { [04:40:01.435] first <- get(as.character(first), mode = "function", [04:40:01.435] envir = parent.frame(), inherits = TRUE) [04:40:01.435] } [04:40:01.435] else { [04:40:01.435] first <- eval(first, envir = parent.frame(), [04:40:01.435] enclos = baseenv()) [04:40:01.435] } [04:40:01.435] if (is.list(first)) { [04:40:01.435] strategies <- first [04:40:01.435] res <- plan(strategies, substitute = FALSE, .cleanup = .cleanup, [04:40:01.435] .init = .init) [04:40:01.435] return(invisible(res)) [04:40:01.435] } [04:40:01.435] if (is.function(first) && !inherits(first, "future")) { [04:40:01.435] strategies <- eval(strategy, envir = parent.frame(), [04:40:01.435] enclos = baseenv()) [04:40:01.435] if (is.list(strategies)) { [04:40:01.435] for (kk in seq_along(strategies)) { [04:40:01.435] strategy_kk <- strategies[[kk]] [04:40:01.435] if (is.character(strategy_kk)) { [04:40:01.435] strategy_kk <- tweak(strategy_kk, penvir = parent.frame()) [04:40:01.435] strategies[[kk]] <- strategy_kk [04:40:01.435] } [04:40:01.435] } [04:40:01.435] newStack <- strategies [04:40:01.435] stop_if_not(!is.null(newStack), is.list(newStack), [04:40:01.435] length(newStack) >= 1L) [04:40:01.435] } [04:40:01.435] else if (is.function(strategies) && !inherits(strategies, [04:40:01.435] "future")) { [04:40:01.435] strategies <- list(strategies) [04:40:01.435] newStack <- strategies [04:40:01.435] stop_if_not(!is.null(newStack), is.list(newStack), [04:40:01.435] length(newStack) >= 1L) [04:40:01.435] } [04:40:01.435] } [04:40:01.435] } [04:40:01.435] } [04:40:01.435] if (is.null(newStack)) { [04:40:01.435] if (is.symbol(strategy)) { [04:40:01.435] strategy <- eval(strategy, envir = parent.frame(), [04:40:01.435] enclos = baseenv()) [04:40:01.435] } [04:40:01.435] else if (is.language(strategy)) { [04:40:01.435] strategyT <- as.list(strategy) [04:40:01.435] if (strategyT[[1]] == as.symbol("tweak")) { [04:40:01.435] strategy <- eval(strategy, envir = parent.frame(), [04:40:01.435] enclos = baseenv()) [04:40:01.435] } [04:40:01.435] else { [04:40:01.435] isSymbol <- sapply(strategyT, FUN = is.symbol) [04:40:01.435] if (!all(isSymbol)) { [04:40:01.435] strategy <- eval(strategyT[[1L]], envir = parent.frame(), [04:40:01.435] enclos = baseenv()) [04:40:01.435] if (length(strategyT) > 1L) { [04:40:01.435] args <- c(list(strategy), strategyT[-1L], [04:40:01.435] penvir = parent.frame()) [04:40:01.435] strategy <- do.call(tweak, args = args) [04:40:01.435] } [04:40:01.435] } [04:40:01.435] else { [04:40:01.435] strategy <- eval(strategy, envir = parent.frame(), [04:40:01.435] enclos = baseenv()) [04:40:01.435] } [04:40:01.435] } [04:40:01.435] } [04:40:01.435] args <- c(list(strategy), targs, penvir = parent.frame()) [04:40:01.435] tstrategy <- do.call(tweak, args = args, quote = TRUE) [04:40:01.435] newStack <- list(tstrategy) [04:40:01.435] stop_if_not(!is.null(newStack), is.list(newStack), length(newStack) >= [04:40:01.435] 1L) [04:40:01.435] } [04:40:01.435] if (!is.null(.call)) { [04:40:01.435] call <- if (isTRUE(.call)) [04:40:01.435] sys.call() [04:40:01.435] else .call [04:40:01.435] for (kk in seq_along(newStack)) { [04:40:01.435] strategy <- newStack[[kk]] [04:40:01.435] if (!is.null(attr(strategy, "call", exact = TRUE))) [04:40:01.435] next [04:40:01.435] attr(strategy, "call") <- call [04:40:01.435] newStack[[kk]] <- strategy [04:40:01.435] } [04:40:01.435] stop_if_not(!is.null(newStack), is.list(newStack), length(newStack) >= [04:40:01.435] 1L) [04:40:01.435] } [04:40:01.435] oldStack <- plan_set(newStack, skip = .skip, cleanup = .cleanup, [04:40:01.435] init = .init, debug = debug) [04:40:01.435] invisible(oldStack) [04:40:01.435] } [04:40:01.435] [04:40:01.435] [04:40:03.102] Launched future #1 [04:40:04.855] Launched future #1 [04:40:06.386] Launched future #1 List of 1 $ y:List of 3 ..$ a: int [1:2] 0 0 ..$ c: chr [1:2] "" "" ..$ c:List of 2 .. ..$ : NULL .. ..$ : NULL [04:40:08.354] Launched future #1 List of 1 $ y:List of 3 ..$ a: int [1:2] 0 0 ..$ c: chr [1:2] "" "" ..$ c:List of 2 .. ..$ : NULL .. ..$ : NULL - future_lapply(x, FUN = base::vector, ...) ... List of 1 $ x:List of 3 ..$ a: chr "integer" ..$ c: chr "character" ..$ c: chr "list" List of 1 $ y0:List of 3 ..$ a: int [1:2] 0 0 ..$ c: chr [1:2] "" "" ..$ c:List of 2 .. ..$ : NULL .. ..$ : NULL - plan('batchtools_local') ... [04:40:08.453] function (strategy = NULL, ..., substitute = TRUE, .skip = FALSE, [04:40:08.453] .call = TRUE, .cleanup = NA, .init = TRUE) [04:40:08.453] { [04:40:08.453] if (substitute) [04:40:08.453] strategy <- substitute(strategy) [04:40:08.453] if (is.logical(.skip)) [04:40:08.453] stop_if_not(length(.skip) == 1L, !is.na(.skip)) [04:40:08.453] if (is.logical(.call)) [04:40:08.453] stop_if_not(length(.call) == 1L, !is.na(.call)) [04:40:08.453] debug <- isTRUE(getOption("future.debug")) [04:40:08.453] if (debug) { [04:40:08.453] mdebugf_push("plan(<%s>, .skip = %s, .cleanup = %s, .init = %s) ...", [04:40:08.453] class(strategy)[1], .skip, .cleanup, .init) [04:40:08.453] on.exit(mdebug_pop()) [04:40:08.453] } [04:40:08.453] if (is.null(stack)) { [04:40:08.453] stack <<- plan_default_stack() [04:40:08.453] if (debug) [04:40:08.453] mdebug("Created default stack") [04:40:08.453] } [04:40:08.453] if (identical(strategy, "backend")) { [04:40:08.453] strategy <- stack[[1L]] [04:40:08.453] backend <- attr(strategy, "backend") [04:40:08.453] if (is.null(backend)) { [04:40:08.453] strategy <- plan_init(strategy, debug = debug) [04:40:08.453] stack[[1L]] <<- strategy [04:40:08.453] backend <- attr(strategy, "backend") [04:40:08.453] } [04:40:08.453] return(backend) [04:40:08.453] } [04:40:08.453] else if (is.null(strategy) || identical(strategy, "next")) { [04:40:08.453] strategy <- stack[[1L]] [04:40:08.453] if (!inherits(strategy, "FutureStrategy")) { [04:40:08.453] class(strategy) <- c("FutureStrategy", class(strategy)) [04:40:08.453] } [04:40:08.453] stop_if_not(is.function(strategy)) [04:40:08.453] if (debug) [04:40:08.453] mdebugf("Getting current (\"next\") strategy: %s", [04:40:08.453] commaq(class(strategy))) [04:40:08.453] return(strategy) [04:40:08.453] } [04:40:08.453] else if (identical(strategy, "default")) { [04:40:08.453] strategy <- getOption("future.plan") [04:40:08.453] if (is.null(strategy)) [04:40:08.453] strategy <- sequential [04:40:08.453] if (debug) [04:40:08.453] mdebugf("Getting default stack: %s", commaq(class(strategy))) [04:40:08.453] } [04:40:08.453] else if (identical(strategy, "list")) { [04:40:08.453] if (debug) [04:40:08.453] mdebugf("Getting full stack: [n=%d] %s", length(stack), [04:40:08.453] commaq(sapply(stack, FUN = class))) [04:40:08.453] if (all(c("codalm", "testthat") %in% loadedNamespaces())) { [04:40:08.453] ignore <- c("init", "backend") [04:40:08.453] class <- class(stack) [04:40:08.453] stack <- lapply(stack, FUN = function(s) { [04:40:08.453] for (name in ignore) attr(s, name) <- NULL [04:40:08.453] s [04:40:08.453] }) [04:40:08.453] class(stack) <- class [04:40:08.453] } [04:40:08.453] return(stack) [04:40:08.453] } [04:40:08.453] else if (identical(strategy, "tail")) { [04:40:08.453] stack <- stack[-1] [04:40:08.453] if (debug) [04:40:08.453] mdebugf("Getting stack without first backend: [n=%d] %s", [04:40:08.453] length(stack), commaq(sapply(stack, FUN = class))) [04:40:08.453] return(stack) [04:40:08.453] } [04:40:08.453] else if (identical(strategy, "reset")) { [04:40:08.453] if (debug) [04:40:08.453] mdebug_push("Resetting stack ...") [04:40:08.453] plan_cleanup(stack[[1]], cleanup = .cleanup, debug = debug) [04:40:08.453] stack <<- plan_default_stack() [04:40:08.453] if (debug) [04:40:08.453] mdebug_pop() [04:40:08.453] return(stack) [04:40:08.453] } [04:40:08.453] else if (identical(strategy, "pop")) { [04:40:08.453] if (debug) [04:40:08.453] mdebug_push("Popping stack ...") [04:40:08.453] oldStack <- stack [04:40:08.453] stack <<- stack[-1L] [04:40:08.453] if (length(stack) == 0L) [04:40:08.453] stack <<- plan_default_stack() [04:40:08.453] if (debug) [04:40:08.453] mdebug_pop() [04:40:08.453] return(oldStack) [04:40:08.453] } [04:40:08.453] oldStack <- stack [04:40:08.453] newStack <- NULL [04:40:08.453] targs <- list(...) [04:40:08.453] if (is.function(strategy)) { [04:40:08.453] if (length(targs) > 0) { [04:40:08.453] args <- c(list(strategy), targs, penvir = parent.frame()) [04:40:08.453] strategy <- do.call(tweak, args = args) [04:40:08.453] } [04:40:08.453] strategy <- list(strategy) [04:40:08.453] } [04:40:08.453] if (is.list(strategy)) { [04:40:08.453] oldStack <- plan_set(strategy, skip = .skip, cleanup = .cleanup, [04:40:08.453] init = .init, debug = debug) [04:40:08.453] return(invisible(oldStack)) [04:40:08.453] } [04:40:08.453] if (is.language(strategy)) { [04:40:08.453] first <- as.list(strategy)[[1]] [04:40:08.453] if (is.symbol(first)) { [04:40:08.453] if (is.call(strategy)) { [04:40:08.453] first <- get(as.character(first), mode = "function", [04:40:08.453] envir = parent.frame(), inherits = TRUE) [04:40:08.453] } [04:40:08.453] else { [04:40:08.453] first <- eval(first, envir = parent.frame(), [04:40:08.453] enclos = baseenv()) [04:40:08.453] } [04:40:08.453] if (is.list(first)) { [04:40:08.453] strategies <- first [04:40:08.453] res <- plan(strategies, substitute = FALSE, .cleanup = .cleanup, [04:40:08.453] .init = .init) [04:40:08.453] return(invisible(res)) [04:40:08.453] } [04:40:08.453] if (is.function(first) && !inherits(first, "future")) { [04:40:08.453] strategies <- eval(strategy, envir = parent.frame(), [04:40:08.453] enclos = baseenv()) [04:40:08.453] if (is.list(strategies)) { [04:40:08.453] for (kk in seq_along(strategies)) { [04:40:08.453] strategy_kk <- strategies[[kk]] [04:40:08.453] if (is.character(strategy_kk)) { [04:40:08.453] strategy_kk <- tweak(strategy_kk, penvir = parent.frame()) [04:40:08.453] strategies[[kk]] <- strategy_kk [04:40:08.453] } [04:40:08.453] } [04:40:08.453] newStack <- strategies [04:40:08.453] stop_if_not(!is.null(newStack), is.list(newStack), [04:40:08.453] length(newStack) >= 1L) [04:40:08.453] } [04:40:08.453] else if (is.function(strategies) && !inherits(strategies, [04:40:08.453] "future")) { [04:40:08.453] strategies <- list(strategies) [04:40:08.453] newStack <- strategies [04:40:08.453] stop_if_not(!is.null(newStack), is.list(newStack), [04:40:08.453] length(newStack) >= 1L) [04:40:08.453] } [04:40:08.453] } [04:40:08.453] } [04:40:08.453] } [04:40:08.453] if (is.null(newStack)) { [04:40:08.453] if (is.symbol(strategy)) { [04:40:08.453] strategy <- eval(strategy, envir = parent.frame(), [04:40:08.453] enclos = baseenv()) [04:40:08.453] } [04:40:08.453] else if (is.language(strategy)) { [04:40:08.453] strategyT <- as.list(strategy) [04:40:08.453] if (strategyT[[1]] == as.symbol("tweak")) { [04:40:08.453] strategy <- eval(strategy, envir = parent.frame(), [04:40:08.453] enclos = baseenv()) [04:40:08.453] } [04:40:08.453] else { [04:40:08.453] isSymbol <- sapply(strategyT, FUN = is.symbol) [04:40:08.453] if (!all(isSymbol)) { [04:40:08.453] strategy <- eval(strategyT[[1L]], envir = parent.frame(), [04:40:08.453] enclos = baseenv()) [04:40:08.453] if (length(strategyT) > 1L) { [04:40:08.453] args <- c(list(strategy), strategyT[-1L], [04:40:08.453] penvir = parent.frame()) [04:40:08.453] strategy <- do.call(tweak, args = args) [04:40:08.453] } [04:40:08.453] } [04:40:08.453] else { [04:40:08.453] strategy <- eval(strategy, envir = parent.frame(), [04:40:08.453] enclos = baseenv()) [04:40:08.453] } [04:40:08.453] } [04:40:08.453] } [04:40:08.453] args <- c(list(strategy), targs, penvir = parent.frame()) [04:40:08.453] tstrategy <- do.call(tweak, args = args, quote = TRUE) [04:40:08.453] newStack <- list(tstrategy) [04:40:08.453] stop_if_not(!is.null(newStack), is.list(newStack), length(newStack) >= [04:40:08.453] 1L) [04:40:08.453] } [04:40:08.453] if (!is.null(.call)) { [04:40:08.453] call <- if (isTRUE(.call)) [04:40:08.453] sys.call() [04:40:08.453] else .call [04:40:08.453] for (kk in seq_along(newStack)) { [04:40:08.453] strategy <- newStack[[kk]] [04:40:08.453] if (!is.null(attr(strategy, "call", exact = TRUE))) [04:40:08.453] next [04:40:08.453] attr(strategy, "call") <- call [04:40:08.453] newStack[[kk]] <- strategy [04:40:08.453] } [04:40:08.453] stop_if_not(!is.null(newStack), is.list(newStack), length(newStack) >= [04:40:08.453] 1L) [04:40:08.453] } [04:40:08.453] oldStack <- plan_set(newStack, skip = .skip, cleanup = .cleanup, [04:40:08.453] init = .init, debug = debug) [04:40:08.453] invisible(oldStack) [04:40:08.453] } [04:40:08.453] [04:40:08.453] [04:40:09.684] Launched future #1 [04:40:11.326] Launched future #1 [04:40:12.748] Launched future #1 List of 1 $ y:List of 3 ..$ a: int [1:2] 0 0 ..$ c: chr [1:2] "" "" ..$ c:List of 2 .. ..$ : NULL .. ..$ : NULL [04:40:14.822] Launched future #1 List of 1 $ y:List of 3 ..$ a: int [1:2] 0 0 ..$ c: chr [1:2] "" "" ..$ c:List of 2 .. ..$ : NULL .. ..$ : NULL - future_lapply(x, FUN = future:::hpaste, ...) ... List of 1 $ x:List of 1 ..$ a: Named chr [1:101] "hello" "1" "2" "3" ... .. ..- attr(*, "names")= chr [1:101] "" "b1" "b2" "b3" ... List of 1 $ y0:List of 1 ..$ a: chr "hello; 1; 2; ...; 100" - plan('batchtools_local') ... [04:40:14.899] function (strategy = NULL, ..., substitute = TRUE, .skip = FALSE, [04:40:14.899] .call = TRUE, .cleanup = NA, .init = TRUE) [04:40:14.899] { [04:40:14.899] if (substitute) [04:40:14.899] strategy <- substitute(strategy) [04:40:14.899] if (is.logical(.skip)) [04:40:14.899] stop_if_not(length(.skip) == 1L, !is.na(.skip)) [04:40:14.899] if (is.logical(.call)) [04:40:14.899] stop_if_not(length(.call) == 1L, !is.na(.call)) [04:40:14.899] debug <- isTRUE(getOption("future.debug")) [04:40:14.899] if (debug) { [04:40:14.899] mdebugf_push("plan(<%s>, .skip = %s, .cleanup = %s, .init = %s) ...", [04:40:14.899] class(strategy)[1], .skip, .cleanup, .init) [04:40:14.899] on.exit(mdebug_pop()) [04:40:14.899] } [04:40:14.899] if (is.null(stack)) { [04:40:14.899] stack <<- plan_default_stack() [04:40:14.899] if (debug) [04:40:14.899] mdebug("Created default stack") [04:40:14.899] } [04:40:14.899] if (identical(strategy, "backend")) { [04:40:14.899] strategy <- stack[[1L]] [04:40:14.899] backend <- attr(strategy, "backend") [04:40:14.899] if (is.null(backend)) { [04:40:14.899] strategy <- plan_init(strategy, debug = debug) [04:40:14.899] stack[[1L]] <<- strategy [04:40:14.899] backend <- attr(strategy, "backend") [04:40:14.899] } [04:40:14.899] return(backend) [04:40:14.899] } [04:40:14.899] else if (is.null(strategy) || identical(strategy, "next")) { [04:40:14.899] strategy <- stack[[1L]] [04:40:14.899] if (!inherits(strategy, "FutureStrategy")) { [04:40:14.899] class(strategy) <- c("FutureStrategy", class(strategy)) [04:40:14.899] } [04:40:14.899] stop_if_not(is.function(strategy)) [04:40:14.899] if (debug) [04:40:14.899] mdebugf("Getting current (\"next\") strategy: %s", [04:40:14.899] commaq(class(strategy))) [04:40:14.899] return(strategy) [04:40:14.899] } [04:40:14.899] else if (identical(strategy, "default")) { [04:40:14.899] strategy <- getOption("future.plan") [04:40:14.899] if (is.null(strategy)) [04:40:14.899] strategy <- sequential [04:40:14.899] if (debug) [04:40:14.899] mdebugf("Getting default stack: %s", commaq(class(strategy))) [04:40:14.899] } [04:40:14.899] else if (identical(strategy, "list")) { [04:40:14.899] if (debug) [04:40:14.899] mdebugf("Getting full stack: [n=%d] %s", length(stack), [04:40:14.899] commaq(sapply(stack, FUN = class))) [04:40:14.899] if (all(c("codalm", "testthat") %in% loadedNamespaces())) { [04:40:14.899] ignore <- c("init", "backend") [04:40:14.899] class <- class(stack) [04:40:14.899] stack <- lapply(stack, FUN = function(s) { [04:40:14.899] for (name in ignore) attr(s, name) <- NULL [04:40:14.899] s [04:40:14.899] }) [04:40:14.899] class(stack) <- class [04:40:14.899] } [04:40:14.899] return(stack) [04:40:14.899] } [04:40:14.899] else if (identical(strategy, "tail")) { [04:40:14.899] stack <- stack[-1] [04:40:14.899] if (debug) [04:40:14.899] mdebugf("Getting stack without first backend: [n=%d] %s", [04:40:14.899] length(stack), commaq(sapply(stack, FUN = class))) [04:40:14.899] return(stack) [04:40:14.899] } [04:40:14.899] else if (identical(strategy, "reset")) { [04:40:14.899] if (debug) [04:40:14.899] mdebug_push("Resetting stack ...") [04:40:14.899] plan_cleanup(stack[[1]], cleanup = .cleanup, debug = debug) [04:40:14.899] stack <<- plan_default_stack() [04:40:14.899] if (debug) [04:40:14.899] mdebug_pop() [04:40:14.899] return(stack) [04:40:14.899] } [04:40:14.899] else if (identical(strategy, "pop")) { [04:40:14.899] if (debug) [04:40:14.899] mdebug_push("Popping stack ...") [04:40:14.899] oldStack <- stack [04:40:14.899] stack <<- stack[-1L] [04:40:14.899] if (length(stack) == 0L) [04:40:14.899] stack <<- plan_default_stack() [04:40:14.899] if (debug) [04:40:14.899] mdebug_pop() [04:40:14.899] return(oldStack) [04:40:14.899] } [04:40:14.899] oldStack <- stack [04:40:14.899] newStack <- NULL [04:40:14.899] targs <- list(...) [04:40:14.899] if (is.function(strategy)) { [04:40:14.899] if (length(targs) > 0) { [04:40:14.899] args <- c(list(strategy), targs, penvir = parent.frame()) [04:40:14.899] strategy <- do.call(tweak, args = args) [04:40:14.899] } [04:40:14.899] strategy <- list(strategy) [04:40:14.899] } [04:40:14.899] if (is.list(strategy)) { [04:40:14.899] oldStack <- plan_set(strategy, skip = .skip, cleanup = .cleanup, [04:40:14.899] init = .init, debug = debug) [04:40:14.899] return(invisible(oldStack)) [04:40:14.899] } [04:40:14.899] if (is.language(strategy)) { [04:40:14.899] first <- as.list(strategy)[[1]] [04:40:14.899] if (is.symbol(first)) { [04:40:14.899] if (is.call(strategy)) { [04:40:14.899] first <- get(as.character(first), mode = "function", [04:40:14.899] envir = parent.frame(), inherits = TRUE) [04:40:14.899] } [04:40:14.899] else { [04:40:14.899] first <- eval(first, envir = parent.frame(), [04:40:14.899] enclos = baseenv()) [04:40:14.899] } [04:40:14.899] if (is.list(first)) { [04:40:14.899] strategies <- first [04:40:14.899] res <- plan(strategies, substitute = FALSE, .cleanup = .cleanup, [04:40:14.899] .init = .init) [04:40:14.899] return(invisible(res)) [04:40:14.899] } [04:40:14.899] if (is.function(first) && !inherits(first, "future")) { [04:40:14.899] strategies <- eval(strategy, envir = parent.frame(), [04:40:14.899] enclos = baseenv()) [04:40:14.899] if (is.list(strategies)) { [04:40:14.899] for (kk in seq_along(strategies)) { [04:40:14.899] strategy_kk <- strategies[[kk]] [04:40:14.899] if (is.character(strategy_kk)) { [04:40:14.899] strategy_kk <- tweak(strategy_kk, penvir = parent.frame()) [04:40:14.899] strategies[[kk]] <- strategy_kk [04:40:14.899] } [04:40:14.899] } [04:40:14.899] newStack <- strategies [04:40:14.899] stop_if_not(!is.null(newStack), is.list(newStack), [04:40:14.899] length(newStack) >= 1L) [04:40:14.899] } [04:40:14.899] else if (is.function(strategies) && !inherits(strategies, [04:40:14.899] "future")) { [04:40:14.899] strategies <- list(strategies) [04:40:14.899] newStack <- strategies [04:40:14.899] stop_if_not(!is.null(newStack), is.list(newStack), [04:40:14.899] length(newStack) >= 1L) [04:40:14.899] } [04:40:14.899] } [04:40:14.899] } [04:40:14.899] } [04:40:14.899] if (is.null(newStack)) { [04:40:14.899] if (is.symbol(strategy)) { [04:40:14.899] strategy <- eval(strategy, envir = parent.frame(), [04:40:14.899] enclos = baseenv()) [04:40:14.899] } [04:40:14.899] else if (is.language(strategy)) { [04:40:14.899] strategyT <- as.list(strategy) [04:40:14.899] if (strategyT[[1]] == as.symbol("tweak")) { [04:40:14.899] strategy <- eval(strategy, envir = parent.frame(), [04:40:14.899] enclos = baseenv()) [04:40:14.899] } [04:40:14.899] else { [04:40:14.899] isSymbol <- sapply(strategyT, FUN = is.symbol) [04:40:14.899] if (!all(isSymbol)) { [04:40:14.899] strategy <- eval(strategyT[[1L]], envir = parent.frame(), [04:40:14.899] enclos = baseenv()) [04:40:14.899] if (length(strategyT) > 1L) { [04:40:14.899] args <- c(list(strategy), strategyT[-1L], [04:40:14.899] penvir = parent.frame()) [04:40:14.899] strategy <- do.call(tweak, args = args) [04:40:14.899] } [04:40:14.899] } [04:40:14.899] else { [04:40:14.899] strategy <- eval(strategy, envir = parent.frame(), [04:40:14.899] enclos = baseenv()) [04:40:14.899] } [04:40:14.899] } [04:40:14.899] } [04:40:14.899] args <- c(list(strategy), targs, penvir = parent.frame()) [04:40:14.899] tstrategy <- do.call(tweak, args = args, quote = TRUE) [04:40:14.899] newStack <- list(tstrategy) [04:40:14.899] stop_if_not(!is.null(newStack), is.list(newStack), length(newStack) >= [04:40:14.899] 1L) [04:40:14.899] } [04:40:14.899] if (!is.null(.call)) { [04:40:14.899] call <- if (isTRUE(.call)) [04:40:14.899] sys.call() [04:40:14.899] else .call [04:40:14.899] for (kk in seq_along(newStack)) { [04:40:14.899] strategy <- newStack[[kk]] [04:40:14.899] if (!is.null(attr(strategy, "call", exact = TRUE))) [04:40:14.899] next [04:40:14.899] attr(strategy, "call") <- call [04:40:14.899] newStack[[kk]] <- strategy [04:40:14.899] } [04:40:14.899] stop_if_not(!is.null(newStack), is.list(newStack), length(newStack) >= [04:40:14.899] 1L) [04:40:14.899] } [04:40:14.899] oldStack <- plan_set(newStack, skip = .skip, cleanup = .cleanup, [04:40:14.899] init = .init, debug = debug) [04:40:14.899] invisible(oldStack) [04:40:14.899] } [04:40:14.899] [04:40:14.899] [04:40:15.309] Attaching 1 packages ('future') ... [04:40:15.321] Attaching 1 packages ('future') ... done [04:40:16.668] Launched future #1 List of 1 $ y:List of 1 ..$ a: chr "hello; 1; 2; ...; 100" [04:40:16.995] Attaching 1 packages ('future') ... [04:40:17.005] Attaching 1 packages ('future') ... done [04:40:18.998] Launched future #1 List of 1 $ y:List of 1 ..$ a: chr "hello; 1; 2; ...; 100" - future_lapply(x, FUN = listenv::listenv, ...) ... $a A 'listenv' vector with 1 element ('A'). $b A 'listenv' vector with 2 elements ('A', 'B'). List of 1 $ y0:List of 2 ..$ a: Named chr "A" .. ..- attr(*, "names")= chr "A" ..$ b: Named chr [1:2] "A" "B" .. ..- attr(*, "names")= chr [1:2] "A" "B" - plan('batchtools_local') ... [04:40:19.163] Attaching 1 packages ('listenv') ... [04:40:19.176] Attaching 1 packages ('listenv') ... done [04:40:20.514] Launched future #1 [04:40:20.588] Attaching 1 packages ('listenv') ... [04:40:20.600] Attaching 1 packages ('listenv') ... done [04:40:22.043] Launched future #1 List of 1 $ y:List of 2 ..$ a: Named chr "A" .. ..- attr(*, "names")= chr "A" ..$ b: Named chr [1:2] "A" "B" .. ..- attr(*, "names")= chr [1:2] "A" "B" [04:40:22.238] Attaching 1 packages ('listenv') ... [04:40:22.247] Attaching 1 packages ('listenv') ... done [04:40:23.496] Launched future #1 List of 1 $ y:List of 2 ..$ a: Named chr "A" .. ..- attr(*, "names")= chr "A" ..$ b: Named chr [1:2] "A" "B" .. ..- attr(*, "names")= chr [1:2] "A" "B" - future_lapply(x, FUN, ...) for large length(x) ... [04:40:27.811] Launched future #1 - future_lapply() with global in non-attached package ... [04:40:28.289] Attaching 1 packages ('tools') ... [04:40:28.301] Attaching 1 packages ('tools') ... done [04:40:29.512] Launched future #1 *** future_lapply() ... DONE > > source("incl/end.R") > > proc.time() user system elapsed 5.78 1.06 29.68