1#  File src/library/parallel/R/unix/mcmapply.R
2#  Part of the R package, https://www.R-project.org
3#
4#  Copyright (C) 1995-2020 The R Core Team
5#
6#  This program is free software; you can redistribute it and/or modify
7#  it under the terms of the GNU General Public License as published by
8#  the Free Software Foundation; either version 2 of the License, or
9#  (at your option) any later version.
10#
11#  This program is distributed in the hope that it will be useful,
12#  but WITHOUT ANY WARRANTY; without even the implied warranty of
13#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14#  GNU General Public License for more details.
15#
16#  A copy of the GNU General Public License is available at
17#  https://www.R-project.org/Licenses/
18
19mcmapply <-
20    function(FUN, ..., MoreArgs = NULL, SIMPLIFY = TRUE, USE.NAMES = TRUE,
21             mc.preschedule = TRUE, mc.set.seed = TRUE,
22             mc.silent = FALSE, mc.cores = getOption("mc.cores", 2L),
23             mc.cleanup = TRUE, affinity.list = NULL)
24{
25    FUN <- match.fun(FUN)
26    dots <- list(...)
27    if(!length(dots)) return(list())
28    lens <- lengths(dots)
29    n <- max(lens)
30    if(n && min(lens) == 0L)
31        stop("Zero-length inputs cannot be mixed with those of non-zero length")
32    answer <- if(n < 2L){
33      ## ensure that it runs on the right core
34      if(!is.null(affinity.list)){
35        save <- mcaffinity()
36        mcaffinity(affinity.list[[1]])
37      }
38      answer <- .mapply(FUN, dots, MoreArgs)
39        # .mapply will not catch errors thrown by FUN
40      if(!is.null(affinity.list)) mcaffinity(save)
41      answer
42    } else {
43        ## recycle shorter vectors
44        X <- if (!all(lens == n))
45            lapply(dots, function(x) rep(x, length.out = n))
46        else dots
47        do_one <- function(indices, ...) {
48            dots <- lapply(X, function(x) x[indices])
49            .mapply(FUN, dots, MoreArgs)
50        }
51        answer <- mclapply(seq_len(n), do_one, mc.preschedule = mc.preschedule,
52                           mc.set.seed = mc.set.seed, mc.silent = mc.silent,
53                           mc.cores = mc.cores, mc.cleanup = mc.cleanup,
54                           affinity.list = affinity.list)
55        answer <- lapply(answer, function(x) {
56            if (inherits(x, "try-error")) {
57                SIMPLIFY <<- FALSE # protect attributes from simplify2array()
58                list(x) # protect attributes from c()
59            } else
60                x
61        })
62        do.call(c, answer)
63    }
64    if (USE.NAMES && length(dots)) {
65        if (is.null(names1 <- names(dots[[1L]])) && is.character(dots[[1L]]))
66            names(answer) <- dots[[1L]]
67        else if (!is.null(names1))
68            names(answer) <- names1
69    }
70    if (!identical(SIMPLIFY, FALSE))
71        simplify2array(answer, higher = (SIMPLIFY == "array"))
72    else answer
73}
74
75mcMap <- function (f, ...)
76{
77    f <- match.fun(f)
78    mcmapply(f, ..., SIMPLIFY = FALSE, mc.silent = TRUE)
79}
80