R/pvec.R

Defines functions pvec

Documented in pvec

pvec <- function(v, FUN, ..., mc.set.seed=TRUE, mc.silent=FALSE, mc.cores=getOption("cores"), mc.cleanup=TRUE) {
  if (!is.vector(v)) stop("v must be a vector")
  
  env <- parent.frame()
  cores <- mc.cores
  if (is.null(cores)) cores <- volatile$detectedCores
  cores <- as.integer(cores)

  n <- length(v)
  l <- if (n < cores) as.list(v) else {
    # compute the scheduling, making it as fair as possible
    il <- as.integer(n / cores)
    xc <- n - il * cores
    sl <- rep(il, cores)
    if (xc) sl[1:xc] <- il + 1
    si <- cumsum(c(1L, sl))
    se <- si + c(sl, 0L) - 1L
    lapply(1:cores, function(ix) v[si[ix]:se[ix]])
  }
  jobs <- NULL
  cleanup <- function() {
    ## kill children if cleanup is requested
    if (length(jobs) && mc.cleanup) {
      ## first take care of uncollected children
      collect(children(jobs), FALSE)
      kill(children(jobs), if (is.integer(mc.cleanup)) mc.cleanup else SIGTERM)
      collect(children(jobs))
    }
    if (length(jobs)) {
      ## just in case there are zombies
      collect(children(jobs), FALSE)
    }
  }
  on.exit(cleanup())
  FUN <- match.fun(FUN)
  jobs <- lapply(seq(cores), function(i) parallel(FUN(l[[i]], ...), name=i, mc.set.seed=mc.set.seed, silent=mc.silent))
  res <- collect(jobs)
  names(res) <- NULL
  res <- do.call(c, res)
  if (length(res) != n) warning("some results may be missing, folded or caused an error")
  res
}
s-u/multicore documentation built on May 25, 2017, 10:18 p.m.