doSNOW/0000755000175100001440000000000012607405016011402 5ustar hornikusersdoSNOW/inst/0000755000175100001440000000000012607266433012367 5ustar hornikusersdoSNOW/inst/examples/0000755000175100001440000000000012607266433014205 5ustar hornikusersdoSNOW/inst/examples/boot.R0000644000175100001440000000467512150662431015276 0ustar hornikuserssuppressMessages(library(doSNOW)) cl <- makeSOCKcluster(4) registerDoSNOW(cl) cat(sprintf('doSNOW %s\n', packageVersion('doSNOW'))) junk <- matrix(0, 1000000, 8) cat(sprintf('Size of extra junk data: %d bytes\n', object.size(junk))) x <- iris[which(iris[,5] != "setosa"), c(1,5)] trials <- 10000 ptime <- system.time({ r <- foreach(icount(trials), .combine=cbind, .export='junk') %dopar% { ind <- sample(100, 100, replace=TRUE) result1 <- glm(x[ind,2]~x[ind,1], family=binomial(logit)) coefficients(result1) } })[3] cat(sprintf('parallel foreach: %6.1f sec\n', ptime)) ptime2 <- system.time({ snowopts <- list(preschedule=TRUE) r <- foreach(icount(trials), .combine=cbind, .export='junk', .options.snow=snowopts) %dopar% { ind <- sample(100, 100, replace=TRUE) result1 <- glm(x[ind,2]~x[ind,1], family=binomial(logit)) coefficients(result1) } })[3] cat(sprintf('parallel foreach with prescheduling: %6.1f sec\n', ptime2)) ptime3 <- system.time({ chunks <- getDoParWorkers() r <- foreach(n=idiv(trials, chunks=chunks), .combine=cbind, .export='junk') %dopar% { y <- lapply(seq_len(n), function(i) { ind <- sample(100, 100, replace=TRUE) result1 <- glm(x[ind,2]~x[ind,1], family=binomial(logit)) coefficients(result1) }) do.call('cbind', y) } })[3] cat(sprintf('chunked parallel foreach: %6.1f sec\n', ptime3)) ptime4 <- system.time({ mkworker <- function(x, junk) { force(x) force(junk) function(i) { ind <- sample(100, 100, replace=TRUE) result1 <- glm(x[ind,2]~x[ind,1], family=binomial(logit)) coefficients(result1) } } y <- parLapply(cl, seq_len(trials), mkworker(x, junk)) r <- do.call('cbind', y) })[3] cat(sprintf('parLapply: %6.1f sec\n', ptime4)) stime <- system.time({ y <- lapply(seq_len(trials), function(i) { ind <- sample(100, 100, replace=TRUE) result1 <- glm(x[ind,2]~x[ind,1], family=binomial(logit)) coefficients(result1) }) r <- do.call('cbind', y) })[3] cat(sprintf('sequential lapply: %6.1f sec\n', stime)) stime2 <- system.time({ r <- foreach(icount(trials), .combine=cbind) %do% { ind <- sample(100, 100, replace=TRUE) result1 <- glm(x[ind,2]~x[ind,1], family=binomial(logit)) coefficients(result1) } })[3] cat(sprintf('sequential foreach: %6.1f sec\n', stime2)) stopCluster(cl) doSNOW/inst/unitTests/0000755000175100001440000000000012607266433014371 5ustar hornikusersdoSNOW/inst/unitTests/options.R0000644000175100001440000000343612277006212016203 0ustar hornikuserstest.preschedule <- function() { x <- list(1:3, 1:9, 1:19) cs <- 1:20 for (chunkSize in cs) { ## preschedule is by default ## FALSE for SNOW, so we test by setting it otherwise opts <- list(preschedule=TRUE) for (y in x) { actual <- foreach(i=y, .options.snow=opts) %dopar% i checkEquals(actual, as.list(y)) actual <- foreach(i=y, .combine="c", .options.snow=opts) %dopar% i checkEquals(actual, y) } } } test.attach <- function() { myFun <- function(x){ myFun1(x+1) } myFun1 <- function(x){ 2*x } testFun <- function(){ inRes1 <- checkTrue("exportEnv" %in% search()) if (!inRes1) { stop("Attaching exportEnv failed") } inRes2 <- checkTrue(exists("myFun1", where=2)) if (!inRes1) { stop("myFun1 not found in exportEnv") } myFun(1) } res <- suppressWarnings(foreach(i=1:4, .combine="c", .packages="RUnit", .export="myFun1", .options.snow=list(attachExportEnv=TRUE)) %dopar% testFun()) checkEquals(res, c(4,4, 4, 4)) } pkgname.test.stress <- function() { if (!require(caret, quietly=TRUE)) { return(TRUE) } else { library(mlbench) data(BostonHousing) lmFit <- train(medv ~ . + rm:lstat, data = BostonHousing, "lm") library(rpart) rpartFit <- train(medv ~ ., data = BostonHousing, "rpart", tuneLength = 9) } } "test.pkgname.test.stress" <- function() { res <- try(pkgname.test.stress()) checkTrue(!is(res, "try-error"), msg="pkgname stress test failed") }doSNOW/tests/0000755000175100001440000000000012607266433012554 5ustar hornikusersdoSNOW/tests/doRUnit.R0000644000175100001440000000537712277006212014265 0ustar hornikusers## unit tests will not be done if RUnit is not available if(require("RUnit", quietly=TRUE)) { ## --- Setup --- pkg <- "doSNOW" # <-- Change to package name! if(Sys.getenv("RCMDCHECK") == "FALSE") { ## Path to unit tests for standalone running under Makefile (not R CMD check) ## PKG/tests/../inst/unitTests path <- file.path(getwd(), "..", "inst", "unitTests") } else { ## Path to unit tests for R CMD check ## PKG.Rcheck/tests/../PKG/unitTests path <- system.file(package=pkg, "unitTests") } cat("\nRunning unit tests\n") print(list(pkg=pkg, getwd=getwd(), pathToUnitTests=path)) library(package=pkg, character.only=TRUE) ################################################################ ## BEGIN PACKAGE SPECIFIC CONFIGURATION # ################################################################ cl <- makeSOCKcluster(2) registerDoSNOW(cl) ################################################################ ## END PACKAGE SPECIFIC CONFIGURATION # ################################################################ ## If desired, load the name space to allow testing of private functions ## if (is.element(pkg, loadedNamespaces())) ## attach(loadNamespace(pkg), name=paste("namespace", pkg, sep=":"), pos=3) ## ## or simply call PKG:::myPrivateFunction() in tests ## --- Testing --- ## Define tests testSuite <- defineTestSuite(name=paste(pkg, "unit testing"), dirs=path, testFileRegexp = "^options\\.R$") ## Run tests <- runTestSuite(testSuite) ## Default report name pathReport <- file.path(path, "report") ## Report to stdout and text files cat("------------------- UNIT TEST SUMMARY ---------------------\n\n") printTextProtocol(tests, showDetails=FALSE) printTextProtocol(tests, showDetails=FALSE, fileName=paste(pathReport, "Summary.txt", sep="")) printTextProtocol(tests, showDetails=TRUE, fileName=paste(pathReport, ".txt", sep="")) ## Report to HTML file printHTMLProtocol(tests, fileName=paste(pathReport, ".html", sep="")) # printHTMLProtocol(tests, fileName=file.path(dirname(dirname(getwd())),pkg,"gsDesign-RUnit-Test-Summary.html")) #paste(pathReport, ".html", sep="")) ## Return stop() to cause R CMD check stop in case of ## - failures i.e. FALSE to unit tests or ## - errors i.e. R errors tmp <- getErrors(tests) if(tmp$nFail > 0 | tmp$nErr > 0) { stop(paste("\n\nunit testing failed (#test failures: ", tmp$nFail, ", #R errors: ", tmp$nErr, ")\n\n", sep="")) } } else { warning("cannot run unit tests -- package RUnit is not available") } doSNOW/NAMESPACE0000644000175100001440000000016112607265065012627 0ustar hornikusersexport(registerDoSNOW) importFrom("utils", "packageDescription", "packageName") import(foreach, iterators, snow) doSNOW/NEWS0000644000175100001440000000135612277006212012104 0ustar hornikusersNEWS/ChangeLog for doSNOW ----------------------------- 1.0.11 2014-02-01 o Modified to work better when a foreach loop is executed in a package (courtesy of Steve Weston) o Added unit tests and a minimal working example o Added NEWS file 1.0.9 2013-10-28 o Changed foreach, iterators, and parallel from Depends to Imports (request of Steve Weston and Stefan Schlager) 1.0.8 2013-09-01 o New attachExportEnv option for doSNOW 1.0.7 2013-05-26 o New preschedule option for doSNOW, courtesy of Steve Weston o Efficiency improvements courtesy of Steve Weston 1.0.6 2012-04-09 o Changes to support RevoScaleR's rxExec function. 1.0.5 2011-04-15 o Added support for compiler package doSNOW/R/0000755000175100001440000000000012607266433011613 5ustar hornikusersdoSNOW/R/doSNOW.R0000644000175100001440000002707212464225232013050 0ustar hornikusers# # Copyright (c) 2008-2010, Revolution Analytics # # This is free software; you can redistribute it and/or # modify it under the terms of the GNU General Public License as published # by the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 # USA registerDoSNOW <- function(cl) { setDoPar(doSNOW, cl, info) } info <- function(data, item) { switch(item, workers=length(data), # XXX is this right? name='doSNOW', version=packageDescription('doSNOW', fields='Version'), NULL) } makeDotsEnv <- function(...) { list(...) function() NULL } .doSnowGlobals <- new.env(parent=emptyenv()) getparentenv <- function(pkgname) { parenv <- NULL # if anything goes wrong, print the error object and return # the global environment tryCatch({ # pkgname is NULL in many cases, as when the foreach loop # is executed interactively or in an R script if (is.character(pkgname)) { # load the specified package if (require(pkgname, character.only=TRUE)) { # search for any function in the package pkgenv <- as.environment(paste0('package:', pkgname)) for (sym in ls(pkgenv)) { fun <- get(sym, pkgenv, inherits=FALSE) if (is.function(fun)) { env <- environment(fun) if (is.environment(env)) { parenv <- env break } } } if (is.null(parenv)) { stop('loaded ', pkgname, ', but parent search failed', call.=FALSE) } else { message('loaded ', pkgname, ' and set parent environment') } } } }, error=function(e) { cat(sprintf('Error getting parent environment: %s\n', conditionMessage(e))) }) # return the global environment by default if (is.null(parenv)) globalenv() else parenv } workerInit <- function(expr, exportenv, pkgname, packages, attach=FALSE) { assign('expr', expr, .doSnowGlobals) assign('exportenv', exportenv, .doSnowGlobals) exportEnv <- .doSnowGlobals$exportenv parent.env(exportEnv) <- getparentenv(pkgname) if (attach) { attach(exportEnv) } tryCatch({ for (p in packages) library(p, character.only=TRUE) NULL # indicates success }, error=function(e) { # a character string indicates an error conditionMessage(e) }) } evalWrapper <- function(args) { exportEnv <- .doSnowGlobals$exportenv lapply(names(args), function(n) assign(n, args[[n]], pos=.doSnowGlobals$exportenv)) tryCatch(eval(.doSnowGlobals$expr, envir=.doSnowGlobals$exportenv), error=function(e) e) } workerCleanup <- function() { if ("exportEnv" %in% search()) { detach(exportEnv) } } # This function takes the place of workerInit and evalWrapper when # preschedule is enabled. It is executed by the master via clusterApply # such that there is a single chunked task for each worker in the # cluster, rather than using clusterCall to initialize the workers and # clusterApplyLB to compute the tasks one-by-one. This strategy can be # significantly more efficient when there are many small tasks, and is # very similar to the default behavior of mclapply. workerPreschedule <- function(largs, expr, exportenv, pkgname, packages) { parent.env(exportenv) <- getparentenv(pkgname) task <- function(args) { lapply(names(args), function(n) assign(n, args[[n]], pos=exportenv)) eval(expr, envir=exportenv) } tryCatch({ # load all necessary packages for (p in packages) library(p, character.only=TRUE) # execute all of the tasks lapply(largs, task) }, error=function(e) { # only one exception was thrown, but we don't know which one, # so we'll return it for all of the tasks lapply(seq_along(largs), function(i) e) }) } comp <- if (getRversion() < "2.13.0") { function(expr, ...) expr } else { compiler::compile } doSNOW <- function(obj, expr, envir, data) { cl <- data preschedule <- FALSE attachExportEnv <- FALSE progressWrapper <- function(...) NULL if (!inherits(obj, 'foreach')) stop('obj must be a foreach object') it <- iter(obj) accumulator <- makeAccum(it) # check for snow-specific options options <- obj$options$snow if (!is.null(options)) { nms <- names(options) recog <- nms %in% c('preschedule', 'attachExportEnv', 'progress') if (any(!recog)) warning(sprintf('ignoring unrecognized snow option(s): %s', paste(nms[!recog], collapse=', ')), call.=FALSE) if (!is.null(options$preschedule)) { if (!is.logical(options$preschedule) || length(options$preschedule) != 1) { warning('preschedule must be logical value', call.=FALSE) } else { if (obj$verbose) cat(sprintf('bundling all tasks into %d chunks\n', length(cl))) preschedule <- options$preschedule } } if (!is.null(options$attachExportEnv)) { if (!is.logical(options$attachExportEnv) || length(options$attachExportEnv) != 1) { warning('attachExportEnv must be logical value', call.=FALSE) } else { if (obj$verbose) cat("attaching export environment\n") attachExportEnv <- options$attachExportEnv } } if (!is.null(options$progress)) { makeProgressWrapper <- function() { tryCatch({ progress <- match.fun(options$progress) if (obj$verbose) cat("progress will be called as each result is returned\n") iargs <- seq_along(formals(progress)) function(...) { tryCatch({ do.call('progress', list(...)[iargs]) }, error=function(e) { warning('progress function failed: ', conditionMessage(e), immediate.=TRUE, call.=FALSE) }) } }, error=function(e) { warning('unable to create progress function: ', conditionMessage(e), immediate.=TRUE, call.=FALSE) function(...) NULL }) } progressWrapper <- makeProgressWrapper() } } # setup the parent environment by first attempting to create an environment # that has '...' defined in it with the appropriate values exportenv <- tryCatch({ qargs <- quote(list(...)) args <- eval(qargs, envir) environment(do.call(makeDotsEnv, args)) }, error=function(e) { new.env(parent=emptyenv()) }) noexport <- union(obj$noexport, obj$argnames) getexports(expr, exportenv, envir, bad=noexport) vars <- ls(exportenv) if (obj$verbose) { if (length(vars) > 0) { cat('automatically exporting the following variables', 'from the local environment:\n') cat(' ', paste(vars, collapse=', '), '\n') } else { cat('no variables are automatically exported\n') } } # compute list of variables to export export <- unique(obj$export) ignore <- intersect(export, vars) if (length(ignore) > 0) { warning(sprintf('already exporting variable(s): %s', paste(ignore, collapse=', '))) export <- setdiff(export, ignore) } # add explicitly exported variables to exportenv if (length(export) > 0) { if (obj$verbose) cat(sprintf('explicitly exporting variables(s): %s\n', paste(export, collapse=', '))) for (sym in export) { if (!exists(sym, envir, inherits=TRUE)) stop(sprintf('unable to find variable "%s"', sym)) val <- get(sym, envir, inherits=TRUE) if (is.function(val) && (identical(environment(val), .GlobalEnv) || identical(environment(val), envir))) { # Changing this function's environment to exportenv allows it to # access/execute any other functions defined in exportenv. This # has always been done for auto-exported functions, and not # doing so for explicitly exported functions results in # functions defined in exportenv that can't call each other. environment(val) <- exportenv } assign(sym, val, pos=exportenv, inherits=FALSE) } } # compile the expression if we're using R 2.13.0 or greater xpr <- comp(expr, env=envir, options=list(suppressUndefined=TRUE)) # packageName function added in R 3.0.0 pkgname <- if (exists('packageName', mode='function')) packageName(envir) else NULL if (! preschedule) { # send exports to workers r <- clusterCall(cl, workerInit, xpr, exportenv, pkgname, obj$packages, attachExportEnv) for (emsg in r) { if (!is.null(emsg)) stop('worker initialization failed: ', emsg) } # execute the tasks nsub <- 0 nfin <- 0 tryCatch({ # send a task to each of the workers to get them started while (nsub < length(cl)) { sendCall(cl[[nsub+1]], evalWrapper, list(nextElem(it)), tag=nsub+1) nsub <- nsub + 1 } # loop until we run out of tasks repeat { # wait for a result d <- recvOneResult(cl) nfin <- nfin + 1 # submit another task to the worker that returned the result sendCall(cl[[d$node]], evalWrapper, list(nextElem(it)), tag=nsub+1) nsub <- nsub + 1 # process the result tryCatch(accumulate(it, d$value, d$tag), error=function(e) { cat('error calling combine function:\n') print(e) }) # call the user's progress function progressWrapper(nfin, d$tag) } }, error=function(e) { # check for StopIteration if (!identical(conditionMessage(e), 'StopIteration')) stop(e) }) # process the last received result (if we received any) if (nfin > 0) { tryCatch(accumulate(it, d$value, d$tag), error=function(e) { cat('error calling combine function:\n') print(e) }) # call the user's progress function progressWrapper(nfin, d$tag) } # wait for and process all remaining results while (nfin < nsub) { d <- recvOneResult(cl) nfin <- nfin + 1 tryCatch(accumulate(it, d$value, d$tag), error=function(e) { cat('error calling combine function:\n') print(e) }) # call the user's progress function progressWrapper(nfin, d$tag) } # clean up the workers if (attachExportEnv) { clusterCall(cl, workerCleanup) } } else { # convert argument iterator into a list of lists argsList <- splitList(as.list(it), length(cl)) # execute the tasks results <- do.call(c, clusterApply(cl, argsList, workerPreschedule, xpr, exportenv, pkgname, obj$packages)) # call the accumulator with all of the results tryCatch(accumulator(results, seq(along=results)), error=function(e) { cat('error calling combine function:\n') print(e) }) } # check for errors errorValue <- getErrorValue(it) errorIndex <- getErrorIndex(it) # throw an error or return the combined results if (identical(obj$errorHandling, 'stop') && !is.null(errorValue)) { msg <- sprintf('task %d failed - "%s"', errorIndex, conditionMessage(errorValue)) stop(simpleError(msg, call=expr)) } else { getResult(it) } } doSNOW/MD50000644000175100001440000000061212607405016011711 0ustar hornikusersb1e72644bb3761ac69d4b55b4c758dac *DESCRIPTION cf16374e6be19fe2f3eca95d4afdfadb *NAMESPACE a5710f7696c510782841a66b493b2026 *NEWS cbf59d25712e02bfd825d6395a002bc0 *R/doSNOW.R e45c2ef63f7283eb4ab97e2cc19f4adb *inst/examples/boot.R 17029f2363a768b483bb8a1a0c1f465a *inst/unitTests/options.R cf5fa97eac969a9a6da91524973dbf15 *man/registerDoSNOW.Rd c9db472cd4f48eb03b81fd6c24fe6159 *tests/doRUnit.R doSNOW/DESCRIPTION0000644000175100001440000000166112607405016013114 0ustar hornikusersPackage: doSNOW Type: Package Title: Foreach Parallel Adaptor for the 'snow' Package Version: 1.0.14 Authors@R: c(person("Rich", "Calaway", role="cre", email = "richcala@microsoft.com"), person("Revolution Analytics", role=c("aut","cph")), person("Stephen", "Weston", role="aut")) Description: Provides a parallel backend for the %dopar% function using Luke Tierney's snow package. Depends: R (>= 2.5.0), foreach(>= 1.2.0), iterators(>= 1.0.0), snow(>= 0.3.0), utils Suggests: compiler, RUnit, caret, mlbench, rpart License: GPL-2 Author: Rich Calaway [cre], Revolution Analytics [aut, cph], Stephen Weston [aut] Maintainer: Rich Calaway Repository: CRAN Repository/R-Forge/Project: dosnow Repository/R-Forge/Revision: 27 Repository/R-Forge/DateTimeStamp: 2015-10-13 20:31:49 Date/Publication: 2015-10-14 09:53:50 NeedsCompilation: no Packaged: 2015-10-13 20:45:25 UTC; rforge doSNOW/man/0000755000175100001440000000000012607266433012165 5ustar hornikusersdoSNOW/man/registerDoSNOW.Rd0000644000175100001440000000115712606056075015274 0ustar hornikusers\name{registerDoSNOW} \alias{registerDoSNOW} \title{registerDoSNOW} \description{ The \code{registerDoSNOW} function is used to register the SNOW parallel backend with the foreach package. } \usage{ registerDoSNOW(cl) } \arguments{ \item{cl}{The cluster object to use for parallel execution.} } \seealso{ \code{\link[snow]{makeCluster}} } % donttest added; may fail due to closed ports. Tested via doRUnit.R \examples{\donttest{ cl <- makeCluster(2, type="SOCK") registerDoSNOW(cl) m <- matrix(rnorm(9), 3, 3) foreach(i=1:nrow(m), .combine=rbind) \%dopar\% (m[i,] / mean(m[i,])) stopCluster(cl) }} \keyword{utilities}