# tests/future_lapply,RNG.R In HenrikBengtsson/future.apply: Apply Function to Elements in Parallel using Futures

```source("incl/start.R")

message("*** future_lapply() and RNGs ...")

options(future.debug = FALSE)

message("* future_lapply(x, ..., future.seed = <invalid>) ...")

res <- tryCatch({
y <- future_lapply(1:3, FUN = identity, future.seed = as.list(1:2))
}, error = identity)
print(res)
stopifnot(inherits(res, "simpleError"))

res <- tryCatch({
y <- future_lapply(1:3, FUN = identity, future.seed = list(1, 2, 3:4))
}, error = identity)
print(res)
stopifnot(inherits(res, "simpleError"))

res <- tryCatch({
y <- future_lapply(1:3, FUN = identity, future.seed = as.list(1:3))
}, error = identity)
print(res)
stopifnot(inherits(res, "simpleError"))

seeds <- lapply(1:3, FUN = as_lecyer_cmrg_seed)
res <- tryCatch({
y <- future_lapply(1:3, FUN = identity, future.seed = lapply(seeds, FUN = as.numeric))
}, error = identity)
print(res)
stopifnot(inherits(res, "simpleError"))

seeds[[1]][1] <- seeds[[1]][1] + 1L
res <- tryCatch({
y <- future_lapply(1:3, FUN = identity, future.seed = seeds)
}, error = identity)
print(res)
stopifnot(inherits(res, "simpleError"))

message("* future_lapply(x, ..., future.seed = <invalid>) ... DONE")

## Iterate of the same set in all tests
x <- 1:5

message("* future_lapply(x, ..., future.seed = FALSE) ...")

y0 <- y0_nested <- seed00 <- NULL
for (cores in 1:availCores) {
message(sprintf("  - Testing with %d cores ...", cores))
options(mc.cores = cores)

for (strategy in supportedStrategies(cores)) {
message(sprintf("* plan('%s') ...", strategy))
plan(strategy)

set.seed(0xBEEF)
seed0 <- get_random_seed()
y <- future_lapply(x, FUN = function(i) i, future.seed = FALSE)
y <- unlist(y)
seed <- get_random_seed()
if (is.null(y0)) {
y0 <- y
seed00 <- seed
}
str(list(y = y))
stopifnot(identical(seed, seed0), identical(seed, seed00))
## NOTE: We cannot guarantee the same random numbers, because
## future.seed = FALSE.

message(sprintf("* plan('%s') ... DONE", strategy))
}  ## for (strategy ...)
message(sprintf("  - Testing with %d cores ... DONE", cores))
} ## for (core ...)

message("* future_lapply(x, ..., future.seed = FALSE) ... DONE")

seed_sets <- list(
A = TRUE,
B = NA,
C = 42L,
D = as_lecyer_cmrg_seed(42L),
E = list(),
F = vector("list", length = length(x)),
G = NULL
)

## Generate sequence of seeds of the current RNGkind()
## NOTE: This is NOT a good way to generate random seeds!!!
seeds <- lapply(seq_along(x), FUN = function(i) {
set.seed(i)
globalenv()\$.Random.seed
})
seed_sets\$E <- seeds

## Generate sequence of L'Ecyer CMRG seeds
seeds <- seed_sets\$F
seeds[[1]] <- seed_sets\$D
for (kk in 2:length(x)) seeds[[kk]] <- parallel::nextRNGStream(seeds[[kk - 1]])
seed_sets\$F <- seeds
seed_sets\$G <- seed_sets\$A

rm(list = "seeds")

for (name in names(seed_sets)) {
future.seed <- seed_sets[[name]]

if (is.list(future.seed)) {
label <- sprintf("<list of %d seeds each being a %d-int seed>",
length(future.seed), length(future.seed[[1]]))
} else {
label <- hpaste(future.seed)
}
message(sprintf("* future_lapply(x, ..., future.seed = %s) ...", label))

set.seed(0xBEEF)
y0 <- seed00 <- NULL

for (cores in 1:availCores) {
message(sprintf("  - Testing with %d cores ...", cores))
options(mc.cores = cores)

for (strategy in supportedStrategies(cores)) {
message(sprintf("* plan('%s') ...", strategy))
plan(strategy)

set.seed(0xBEEF)
seed0 <- get_random_seed()
y <- future_lapply(x, FUN = function(i) {
rnorm(1L)
}, future.seed = future.seed)
y <- unlist(y)
seed <- get_random_seed()
if (is.null(y0)) {
y0 <- y
seed00 <- seed
}
str(list(y = y))
stopifnot(!identical(seed, seed0), identical(seed, seed00),
identical(y, y0))

## RNG-based results should also be identical regardless of
for (scheduling in list(FALSE, TRUE, 0, 0.5, 2.0, Inf)) {
set.seed(0xBEEF)
seed0 <- get_random_seed()
y <- future_lapply(x, FUN = function(i) {
rnorm(1L)
}, future.seed = future.seed, future.scheduling = scheduling)
seed <- get_random_seed()
y <- unlist(y)
str(list(y = y))
stopifnot(!identical(seed, seed0), identical(seed, seed00),
identical(y, y0))
}

## Nested future_lapply():s
for (scheduling in list(FALSE, TRUE)) {
y <- future_lapply(x, FUN = function(i) {
.seed <- globalenv()\$.Random.seed

z <- future_lapply(1:3, FUN = function(j) {
list(j = j, seed = globalenv()\$.Random.seed)
}, future.seed = .seed)

## Assert that all future seeds are unique
seeds <- lapply(z, FUN = function(x) x\$seed)
for (kk in 2:length(seeds)) stopifnot(!all(seeds[[kk]] == seeds[[1]]))

list(i = i, seed = .seed, sample = rnorm(1L), z = z)
}, future.seed = 42L, future.scheduling = scheduling)

if (is.null(y0_nested)) y0_nested <- y
str(list(y = y))

## Assert that all future seeds (also nested ones) are unique
seeds <- Reduce(c, lapply(y, FUN = function(x) {
c(list(seed = x\$seed), lapply(x\$z, FUN = function(x) x\$seed))
}))
for (kk in 2:length(seeds)) stopifnot(!all(seeds[[kk]] == seeds[[1]]))

stopifnot(identical(y, y0_nested))
}

message(sprintf("* plan('%s') ... DONE", strategy))
} ## for (strategy ...)
message(sprintf("  - Testing with %d cores ... DONE", cores))
} ## for (cores ...)

message(sprintf("* future_lapply(x, ..., future.seed = %s) ... DONE", label))

} ## for (name ...)

message("*** future_lapply() and RNGs ... DONE")

source("incl/end.R")
```
HenrikBengtsson/future.apply documentation built on Dec. 10, 2019, 7:05 p.m.