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