diff -Nru rmpi-0.6-9.2/debian/changelog rmpi-0.7-1/debian/changelog --- rmpi-0.6-9.2/debian/changelog 2022-01-03 16:57:22.000000000 +0000 +++ rmpi-0.7-1/debian/changelog 2023-06-25 14:42:35.000000000 +0000 @@ -1,3 +1,21 @@ +rmpi (0.7-1-2) unstable; urgency=medium + + * Rebuilding for unstable following bookworm release + + * debian/control: Set Build-Depends: to current R version + + -- Dirk Eddelbuettel Sun, 25 Jun 2023 09:42:35 -0500 + +rmpi (0.7-1-1) experimental; urgency=medium + + * New upstream release (into 'experimental' while Debian is frozen) + + * debian/control: Set Standards-Version: to current version + * debian/control: Set Standards-Version: to current version + * debian/control: Switch to virtual debhelper-compat (= 12) + + -- Dirk Eddelbuettel Sun, 26 Mar 2023 18:05:09 -0500 + rmpi (0.6-9.2-2) unstable; urgency=medium * debian/control: Set Build-Depends: to current R version diff -Nru rmpi-0.6-9.2/debian/control rmpi-0.7-1/debian/control --- rmpi-0.6-9.2/debian/control 2021-12-23 15:19:44.000000000 +0000 +++ rmpi-0.7-1/debian/control 2023-06-25 14:42:17.000000000 +0000 @@ -2,8 +2,8 @@ Section: gnu-r Priority: optional Maintainer: Dirk Eddelbuettel -Build-Depends: debhelper-compat (= 11), dh-r, r-base-dev (>= 4.1.2), mpi-default-dev, mpi-default-bin, pkg-config -Standards-Version: 4.6.0 +Build-Depends: debhelper-compat (= 12), dh-r, r-base-dev (>= 4.3.1), mpi-default-dev, mpi-default-bin, pkg-config +Standards-Version: 4.6.2 Vcs-Browser: https://salsa.debian.org/edd/r-cran-rmpi Vcs-Git: https://salsa.debian.org/edd/r-cran-rmpi.git Homepage: https://cran.r-project.org/package=Rmpi diff -Nru rmpi-0.6-9.2/DESCRIPTION rmpi-0.7-1/DESCRIPTION --- rmpi-0.6-9.2/DESCRIPTION 2021-10-25 18:10:02.000000000 +0000 +++ rmpi-0.7-1/DESCRIPTION 2023-03-18 08:50:02.000000000 +0000 @@ -1,6 +1,6 @@ Package: Rmpi -Version: 0.6-9.2 -Date: 2021-10-25 +Version: 0.7-1 +Date: 2023-03-17 Title: Interface (Wrapper) to MPI (Message-Passing Interface) Depends: R (>= 2.15.1) Imports: parallel @@ -9,8 +9,8 @@ License: GPL (>= 2) URL: http://fisher.stats.uwo.ca/faculty/yu/Rmpi/ Maintainer: Hao Yu -Packaged: 2021-10-25 17:40:20 UTC; hyu +Packaged: 2023-03-18 01:12:07 UTC; hyu Author: Hao Yu [aut] NeedsCompilation: yes Repository: CRAN -Date/Publication: 2021-10-25 18:10:02 UTC +Date/Publication: 2023-03-18 08:50:02 UTC diff -Nru rmpi-0.6-9.2/inst/CITATION rmpi-0.7-1/inst/CITATION --- rmpi-0.6-9.2/inst/CITATION 2018-04-06 01:50:37.000000000 +0000 +++ rmpi-0.7-1/inst/CITATION 2023-03-17 15:23:49.000000000 +0000 @@ -1,7 +1,7 @@ citHeader("To cite Rmpi in a publication use:") -citEntry( - entry = "Article", +bibentry( + bibtype = "Article", title = "Rmpi: Parallel Statistical Computing in R", author = "Hao Yu", journal = "R News", diff -Nru rmpi-0.6-9.2/man/internal.Rd rmpi-0.7-1/man/internal.Rd --- rmpi-0.6-9.2/man/internal.Rd 2012-08-13 18:05:17.000000000 +0000 +++ rmpi-0.7-1/man/internal.Rd 2023-03-17 18:31:58.000000000 +0000 @@ -1,22 +1,59 @@ \name{string} \alias{string} \alias{mpi.comm.is.null} +\alias{.docall} +\alias{.mpi.worker.apply} +\alias{.mpi.worker.applyLB} +\alias{.mpi.worker.exec} +\alias{.mpi.worker.sim} +\alias{.typeindex} +\alias{.simplify} +\alias{.splitIndices} +\alias{.onUnload} +\alias{.mpi.undefined} +\alias{.force.type} \title{Internal functions} -\description{ Internal functions used by other MPI functions. +\description{ Internal and hidden functions used by other MPI functions. -\code{mpi.comm.is.null} is used to test if a comm is MPI\_COMM\_NULL (empty +\code{mpi.comm.is.null} is used to test if a comm is MPI_COMM_NULL (empty members). \code{string} create a string (empty space character) buffer. + +\code{.docall} a wrap to docall function. + +\code{.mpi.worker.apply} apply like function used by workers. + +\code{.mpi.worker.applyLB} apply like function used by workers (load balancing). + +\code{.mpi.worker.exec} real execution by workers when using \link{mpi.remote.exec}. + +\code{.mpi.worker.sim} real simulation by workers when using \link{mpi.parSim}. + +\code{.type.index} identify input data type: integer, numeric, raw, or others. + +\code{.simplify} simplify internal objects. + +\code{.splitIndices} split parall apply jobs evenly. + +\code{.onUnload} clean MPI when Rmpi is unloaded. + +\code{.mpi.undefined} undefined mpi object. + +\code{.force.type} force input data type object specified by type. + } \usage{ mpi.comm.is.null(comm) string(length) +.docall(fun, args) } \arguments{ \item{comm}{a communicator number.} \item{length}{length of a string.} + \item{fun}{ a function object.} + \item{args}{arguments to function.} } \value{ \code{string} returns an empty character string. diff -Nru rmpi-0.6-9.2/man/mpi.abort.Rd rmpi-0.7-1/man/mpi.abort.Rd --- rmpi-0.6-9.2/man/mpi.abort.Rd 2021-02-22 08:06:22.000000000 +0000 +++ rmpi-0.7-1/man/mpi.abort.Rd 2023-03-17 15:28:05.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.abort} -\title{MPI\_Abort API} +\title{MPI_Abort API} \usage{ mpi.abort(comm = 1) } diff -Nru rmpi-0.6-9.2/man/mpi.apply.Rd rmpi-0.7-1/man/mpi.apply.Rd --- rmpi-0.6-9.2/man/mpi.apply.Rd 2014-05-20 13:53:53.000000000 +0000 +++ rmpi-0.7-1/man/mpi.apply.Rd 2023-03-18 00:54:19.000000000 +0000 @@ -35,10 +35,10 @@ \donttest{ #Assume that there are at least 5 slaves running #Otherwise run mpi.spawn.Rslaves(nslaves=5) -x=c(10,20) -mpi.apply(x,runif) -meanx=1:5 -mpi.apply(meanx,rnorm,n=2,sd=4) +#x=c(10,20) +#mpi.apply(x,runif) +#meanx=1:5 +#mpi.apply(meanx,rnorm,n=2,sd=4) } } \keyword{utilities} diff -Nru rmpi-0.6-9.2/man/mpi.barrier.Rd rmpi-0.7-1/man/mpi.barrier.Rd --- rmpi-0.6-9.2/man/mpi.barrier.Rd 2021-02-22 08:15:35.000000000 +0000 +++ rmpi-0.7-1/man/mpi.barrier.Rd 2023-03-17 15:30:14.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.barrier} -\title{MPI\_Barrier API} +\title{MPI_Barrier API} \usage{ mpi.barrier(comm = 1) } diff -Nru rmpi-0.6-9.2/man/mpi.bcast.cmd.Rd rmpi-0.7-1/man/mpi.bcast.cmd.Rd --- rmpi-0.6-9.2/man/mpi.bcast.cmd.Rd 2013-02-22 20:53:35.000000000 +0000 +++ rmpi-0.7-1/man/mpi.bcast.cmd.Rd 2023-03-17 15:31:32.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.bcast.cmd} -\title{Extension of MPI\_Bcast API} +\title{Extension of MPI_Bcast API} \alias{mpi.bcast.cmd} \description{ \code{mpi.bcast.cmd} is an extension of \code{\link{mpi.bcast}}. diff -Nru rmpi-0.6-9.2/man/mpi.bcast.Rd rmpi-0.7-1/man/mpi.bcast.Rd --- rmpi-0.6-9.2/man/mpi.bcast.Rd 2021-02-22 08:15:29.000000000 +0000 +++ rmpi-0.7-1/man/mpi.bcast.Rd 2023-03-17 15:30:54.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.bcast} -\title{MPI\_Bcast API} +\title{MPI_Bcast API} \alias{mpi.bcast} \description{ \code{mpi.bcast} is a collective call among all members in a comm. It diff -Nru rmpi-0.6-9.2/man/mpi.bcast.Robj.Rd rmpi-0.7-1/man/mpi.bcast.Robj.Rd --- rmpi-0.6-9.2/man/mpi.bcast.Robj.Rd 2013-08-15 15:02:44.000000000 +0000 +++ rmpi-0.7-1/man/mpi.bcast.Robj.Rd 2023-03-17 15:31:14.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.bcast.Robj} -\title{Extensions of MPI\_Bcast API} +\title{Extensions of MPI_Bcast API} \alias{mpi.bcast.Robj} \alias{mpi.bcast.Robj2slave} \alias{mpi.bcast.Rfun2slave} diff -Nru rmpi-0.6-9.2/man/mpi.cart.coords.Rd rmpi-0.7-1/man/mpi.cart.coords.Rd --- rmpi-0.6-9.2/man/mpi.cart.coords.Rd 2021-02-22 08:08:06.000000000 +0000 +++ rmpi-0.7-1/man/mpi.cart.coords.Rd 2023-03-18 00:59:25.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.cart.coords} -\title{MPI\_Cart\_coords} +\title{MPI_Cart_coords} \alias{mpi.cart.coords} \description{ \code{mpi.cart.coords} translates a rank to its Cartesian topology coordinate. @@ -32,9 +32,9 @@ \examples{ \donttest{ #Need at least 9 slaves -mpi.bcast.cmd(mpi.cart.create(1,c(3,3),c(F,T))) -mpi.cart.create(1,c(3,3),c(F,T)) -mpi.cart.coords(3,4,2) +#mpi.bcast.cmd(mpi.cart.create(1,c(3,3),c(F,T))) +#mpi.cart.create(1,c(3,3),c(F,T)) +#mpi.cart.coords(3,4,2) } } diff -Nru rmpi-0.6-9.2/man/mpi.cart.create.Rd rmpi-0.7-1/man/mpi.cart.create.Rd --- rmpi-0.6-9.2/man/mpi.cart.create.Rd 2021-02-22 08:08:22.000000000 +0000 +++ rmpi-0.7-1/man/mpi.cart.create.Rd 2023-03-18 00:59:51.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.cart.create} -\title{MPI\_Cart\_create} +\title{MPI_Cart_create} \alias{mpi.cart.create} \description{ \code{mpi.cart.create} creates a Cartesian structure of arbitrary dimension. @@ -35,8 +35,8 @@ \examples{ \donttest{ #Need at least 9 slaves -mpi.bcast.cmd(mpi.cart.create(1,c(3,3),c(F,T))) -mpi.cart.create(1,c(3,3),c(F,T)) +#mpi.bcast.cmd(mpi.cart.create(1,c(3,3),c(F,T))) +#mpi.cart.create(1,c(3,3),c(F,T)) } } diff -Nru rmpi-0.6-9.2/man/mpi.cartdim.get.Rd rmpi-0.7-1/man/mpi.cartdim.get.Rd --- rmpi-0.6-9.2/man/mpi.cartdim.get.Rd 2021-02-22 08:09:19.000000000 +0000 +++ rmpi-0.7-1/man/mpi.cartdim.get.Rd 2023-03-18 01:00:12.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.cartdim.get} -\title{MPI\_Cartdim\_get} +\title{MPI_Cartdim_get} \alias{mpi.cartdim.get} \description{ \code{mpi.cartdim.get} gets dim information about a Cartesian topology. @@ -28,9 +28,9 @@ \examples{ \donttest{ #Need at least 9 slaves -mpi.bcast.cmd(mpi.cart.create(1,c(3,3),c(F,T))) -mpi.cart.create(1,c(3,3),c(F,T)) -mpi.cartdim.get(comm=3) +#mpi.bcast.cmd(mpi.cart.create(1,c(3,3),c(F,T))) +#mpi.cart.create(1,c(3,3),c(F,T)) +#mpi.cartdim.get(comm=3) } } \keyword{interface} diff -Nru rmpi-0.6-9.2/man/mpi.cart.get.Rd rmpi-0.7-1/man/mpi.cart.get.Rd --- rmpi-0.6-9.2/man/mpi.cart.get.Rd 2021-02-22 08:08:38.000000000 +0000 +++ rmpi-0.7-1/man/mpi.cart.get.Rd 2023-03-18 01:00:40.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.cart.get} -\title{MPI\_Cart\_get} +\title{MPI_Cart_get} \alias{mpi.cart.get} \description{ \code{mpi.cart.get} provides the user with information on the Cartesian topology @@ -31,9 +31,9 @@ \examples{ \donttest{ #Need at least 9 slaves -mpi.bcast.cmd(mpi.cart.create(1,c(3,3),c(F,T))) -mpi.cart.create(1,c(3,3),c(F,T)) -mpi.remote.exec(mpi.cart.get(3,2)) +#mpi.bcast.cmd(mpi.cart.create(1,c(3,3),c(F,T))) +#mpi.cart.create(1,c(3,3),c(F,T)) +#mpi.remote.exec(mpi.cart.get(3,2)) } } diff -Nru rmpi-0.6-9.2/man/mpi.cart.rank.Rd rmpi-0.7-1/man/mpi.cart.rank.Rd --- rmpi-0.6-9.2/man/mpi.cart.rank.Rd 2021-02-22 08:08:50.000000000 +0000 +++ rmpi-0.7-1/man/mpi.cart.rank.Rd 2023-03-18 01:01:02.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.cart.rank} -\title{MPI\_Cart\_rank} +\title{MPI_Cart_rank} \alias{mpi.cart.rank} \description{ \code{mpi.cart.rank} translates a Cartesian topology coordinate to its rank. @@ -30,9 +30,9 @@ \examples{ \donttest{ #Need at least 9 slaves -mpi.bcast.cmd(mpi.cart.create(1,c(3,3),c(F,T))) -mpi.cart.create(1,c(3,3),c(F,T)) -mpi.cart.rank(3,c(1,0)) +#mpi.bcast.cmd(mpi.cart.create(1,c(3,3),c(F,T))) +#mpi.cart.create(1,c(3,3),c(F,T)) +#mpi.cart.rank(3,c(1,0)) } } \keyword{interface} diff -Nru rmpi-0.6-9.2/man/mpi.cart.shift.Rd rmpi-0.7-1/man/mpi.cart.shift.Rd --- rmpi-0.6-9.2/man/mpi.cart.shift.Rd 2021-02-22 08:09:06.000000000 +0000 +++ rmpi-0.7-1/man/mpi.cart.shift.Rd 2023-03-18 01:01:24.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.cart.shift} -\title{MPI\_Cart\_shift} +\title{MPI_Cart_shift} \alias{mpi.cart.shift} \description{ \code{mpi.cart.shift} shifts the Cartesian topology in both manners, displacement @@ -36,10 +36,10 @@ \examples{ \donttest{ #Need at least 9 slaves -mpi.bcast.cmd(mpi.cart.create(1,c(3,3),c(F,T))) -mpi.cart.create(1,c(3,3),c(F,T)) -mpi.remote.exec(mpi.cart.shift(3,2,1))#get neighbor ranks -mpi.remote.exec(mpi.cart.shift(3,1,1)) +#mpi.bcast.cmd(mpi.cart.create(1,c(3,3),c(F,T))) +#mpi.cart.create(1,c(3,3),c(F,T)) +#mpi.remote.exec(mpi.cart.shift(3,2,1))#get neighbor ranks +#mpi.remote.exec(mpi.cart.shift(3,1,1)) } } \keyword{interface} diff -Nru rmpi-0.6-9.2/man/mpi.comm.disconnect.Rd rmpi-0.7-1/man/mpi.comm.disconnect.Rd --- rmpi-0.6-9.2/man/mpi.comm.disconnect.Rd 2021-02-22 08:09:49.000000000 +0000 +++ rmpi-0.7-1/man/mpi.comm.disconnect.Rd 2023-03-17 15:42:31.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.comm.disconnect} -\title{MPI\_Comm\_disconnect API} +\title{MPI_Comm_disconnect API} \usage{ mpi.comm.disconnect(comm=1) } @@ -9,7 +9,7 @@ } \description{ \code{mpi.comm.disconnect} disconnects itself from a communicator and then - deallocates the communicator so it points to MPI\_COMM\_NULL. + deallocates the communicator so it points to MPI_COMM_NULL. } \details{ When members associated with a communicator finish jobs or exit, they have to diff -Nru rmpi-0.6-9.2/man/mpi.comm.free.Rd rmpi-0.7-1/man/mpi.comm.free.Rd --- rmpi-0.6-9.2/man/mpi.comm.free.Rd 2021-02-22 08:10:00.000000000 +0000 +++ rmpi-0.7-1/man/mpi.comm.free.Rd 2023-03-17 15:42:51.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.comm.free} -\title{MPI\_Comm\_free API} +\title{MPI_Comm_free API} \usage{ mpi.comm.free(comm=1) } @@ -9,7 +9,7 @@ } \description{ \code{mpi.comm.free} deallocates a communicator so it - points to MPI\_COMM\_NULL. + points to MPI_COMM_NULL. } \details{ When members associated with a communicator finish jobs or exit, they have to diff -Nru rmpi-0.6-9.2/man/mpi.comm.inter.Rd rmpi-0.7-1/man/mpi.comm.inter.Rd --- rmpi-0.6-9.2/man/mpi.comm.inter.Rd 2021-02-22 08:10:08.000000000 +0000 +++ rmpi-0.7-1/man/mpi.comm.inter.Rd 2023-03-17 15:34:22.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.comm.get.parent} -\title{MPI\_Comm\_get\_parent, MPI\_Comm\_remote\_size, MPI\_Comm\_test\_inter +\title{MPI_Comm_get_parent, MPI_Comm_remote_size, MPI_Comm_test_inter APIs} \usage{ mpi.comm.get.parent(comm = 2) diff -Nru rmpi-0.6-9.2/man/mpi.comm.Rd rmpi-0.7-1/man/mpi.comm.Rd --- rmpi-0.6-9.2/man/mpi.comm.Rd 2021-02-22 08:09:53.000000000 +0000 +++ rmpi-0.7-1/man/mpi.comm.Rd 2023-03-18 01:02:04.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.comm.size} -\title{MPI\_Comm\_c2f, MPI\_Comm\_dup, MPI\_Comm\_rank, and MPI\_Comm\_size APIs} +\title{MPI_Comm_c2f, MPI_Comm_dup, MPI_Comm_rank, and MPI_Comm_size APIs} \usage{ mpi.comm.c2f(comm=1) mpi.comm.dup(comm, newcomm) @@ -30,17 +30,17 @@ \examples{ \donttest{ #Assume that there are some slaves running -mpi.comm.size(comm=1) -mpi.comm.size(comm=0) +#mpi.comm.size(comm=1) +#mpi.comm.size(comm=0) -mpi.remote.exec(mpi.comm.rank(comm=1)) -mpi.remote.exec(mpi.comm.rank(comm=0)) +#mpi.remote.exec(mpi.comm.rank(comm=1)) +#mpi.remote.exec(mpi.comm.rank(comm=0)) -mpi.remote.exec(mpi.comm.size(comm=1)) -mpi.remote.exec(mpi.comm.size(comm=0)) +#mpi.remote.exec(mpi.comm.size(comm=1)) +#mpi.remote.exec(mpi.comm.size(comm=0)) -mpi.bcast.cmd(mpi.comm.dup(comm=1,newcomm=5)) -mpi.comm.dup(comm=1,newcomm=5) +#mpi.bcast.cmd(mpi.comm.dup(comm=1,newcomm=5)) +#mpi.comm.dup(comm=1,newcomm=5) } } \keyword{interface} diff -Nru rmpi-0.6-9.2/man/mpi.comm.set.errhandler.Rd rmpi-0.7-1/man/mpi.comm.set.errhandler.Rd --- rmpi-0.6-9.2/man/mpi.comm.set.errhandler.Rd 2021-02-22 08:10:17.000000000 +0000 +++ rmpi-0.7-1/man/mpi.comm.set.errhandler.Rd 2023-03-17 15:43:41.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.comm.set.errhandler} -\title{MPI\_Comm\_set\_errhandler API} +\title{MPI_Comm_set_errhandler API} \usage{ mpi.comm.set.errhandler(comm = 1) } @@ -8,12 +8,12 @@ \item{comm}{a communicator number} } \description{ - \code{mpi.comm.set.errhandler} sets a communicator to MPI\_ERRORS\_RETURN + \code{mpi.comm.set.errhandler} sets a communicator to MPI_ERRORS_RETURN instead of -MPI\_ERRORS\_ARE\_FATAL (default) which crashes R on any type of MPI errors. +MPI_ERRORS_ARE_FATAL (default) which crashes R on any type of MPI errors. Almost all MPI API calls return errcodes which can map to specific MPI error messages. All MPI related error messages come from predefined -MPI\_Error\_string. +MPI_Error_string. } \value{ 1 if success. Otherwise 0. diff -Nru rmpi-0.6-9.2/man/mpi.comm.spawn.Rd rmpi-0.7-1/man/mpi.comm.spawn.Rd --- rmpi-0.6-9.2/man/mpi.comm.spawn.Rd 2021-02-22 08:10:25.000000000 +0000 +++ rmpi-0.7-1/man/mpi.comm.spawn.Rd 2023-03-17 15:46:29.000000000 +0000 @@ -1,12 +1,12 @@ \name{mpi.comm.spawn} \alias{mpi.comm.spawn} -\title{MPI\_Comm\_spawn API } +\title{MPI_Comm_spawn API } \description{ \code{mpi.comm.spawn} tries to start \code{nslaves} identical copies of \code{slaves}, establishing communication with them and returning an intercommunicator. The spawned slaves are referred to as children, and the process that spawned them is called the parent (master). The children have -their own MPI\_COMM\_WORLD represented by comm 0. To make communication +their own MPI_COMM_WORLD represented by comm 0. To make communication possible among master and slaves, all slaves should use \code{\link{mpi.comm.get.parent}} to find their parent and use \code{\link{mpi.intercomm.merge}} to merger an intercomm to a comm. diff -Nru rmpi-0.6-9.2/man/mpi.const.Rd rmpi-0.7-1/man/mpi.const.Rd --- rmpi-0.6-9.2/man/mpi.const.Rd 2021-02-22 08:10:31.000000000 +0000 +++ rmpi-0.7-1/man/mpi.const.Rd 2023-03-17 15:44:13.000000000 +0000 @@ -4,7 +4,7 @@ \alias{mpi.proc.null} \title{MPI Constants} \description{ - Find MPI constants: MPI\_ANY\_SOURCE, MPI\_ANY\_TAG, or MPI\_PROC\_NULL + Find MPI constants: MPI_ANY_SOURCE, MPI_ANY_TAG, or MPI_PROC_NULL } \usage{ mpi.any.source() @@ -22,7 +22,7 @@ \code{\link{mpi.send}}, \code{\link{mpi.recv}}, and \code{\link{mpi.probe}}. Different implementation of MPI may use different - integers for MPI\_ANY\_SOURCE, MPI\_ANY\_TAG, and MPI\_PROC\_NULL. Hence one + integers for MPI_ANY_SOURCE, MPI_ANY_TAG, and MPI_PROC_NULL. Hence one should use these functions instead real integers for MPI communications. } \seealso{ diff -Nru rmpi-0.6-9.2/man/mpi.dims.create.Rd rmpi-0.7-1/man/mpi.dims.create.Rd --- rmpi-0.6-9.2/man/mpi.dims.create.Rd 2021-02-22 08:10:41.000000000 +0000 +++ rmpi-0.7-1/man/mpi.dims.create.Rd 2023-03-18 01:02:26.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.dims.create} -\title{MPI\_Dims\_create} +\title{MPI_Dims_create} \alias{mpi.dims.create} \description{ \code{mpi.dims.create} Create a Cartesian dimension used by \code{mpi.cart.create}. @@ -35,9 +35,10 @@ \examples{ \donttest{ #What is the dim numbers of 2 dim Cartersian topology under a grid of 36 nodes -mpi.dims.create(36,2) #return c(6,6) +#mpi.dims.create(36,2) #return c(6,6) + #Constrained dim numbers -mpi.dims.create(12,2,c(0,4)) #return c(9,4) +#mpi.dims.create(12,2,c(0,4)) #return c(9,4) } } \keyword{interface} diff -Nru rmpi-0.6-9.2/man/mpi.finalize.Rd rmpi-0.7-1/man/mpi.finalize.Rd --- rmpi-0.6-9.2/man/mpi.finalize.Rd 2021-02-22 08:10:48.000000000 +0000 +++ rmpi-0.7-1/man/mpi.finalize.Rd 2023-03-17 15:37:23.000000000 +0000 @@ -1,6 +1,6 @@ \name{mpi.finalize} \alias{mpi.finalize} -\title{MPI\_Finalize API} +\title{MPI_Finalize API} \description{ Terminates MPI execution environment. } diff -Nru rmpi-0.6-9.2/man/mpi.gather.Rd rmpi-0.7-1/man/mpi.gather.Rd --- rmpi-0.6-9.2/man/mpi.gather.Rd 2021-02-22 08:10:55.000000000 +0000 +++ rmpi-0.7-1/man/mpi.gather.Rd 2023-03-18 01:03:28.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.gather} -\title{MPI\_Gather, MPI\_Gatherv, MPI\_Allgather, and MPI\_Allgatherv APIs} +\title{MPI_Gather, MPI_Gatherv, MPI_Allgather, and MPI_Allgatherv APIs} \alias{mpi.gather} \alias{mpi.gatherv} \alias{mpi.allgather} @@ -58,17 +58,18 @@ \donttest{ #Need 3 slaves to run properly #Or use mpi.spawn.Rslaves(nslaves=3) - mpi.bcast.cmd(id <-mpi.comm.rank(.comm), comm=1) -mpi.bcast.cmd(mpi.gather(letters[id],type=3,rdata=string(1))) -mpi.gather(letters[10],type=3,rdata=string(4)) +#mpi.bcast.cmd(id <-mpi.comm.rank(.comm), comm=1) +#mpi.bcast.cmd(mpi.gather(letters[id],type=3,rdata=string(1))) - mpi.bcast.cmd(x<-rnorm(id)) - mpi.bcast.cmd(mpi.gatherv(x,type=2,rdata=double(1),rcounts=1)) - mpi.gatherv(double(1),type=2,rdata=double(sum(1:3)+1),rcounts=c(1,1:3)) +#mpi.gather(letters[10],type=3,rdata=string(4)) -mpi.bcast.cmd(out1<-mpi.allgatherv(x,type=2,rdata=double(sum(1:3)+1), - rcounts=c(1,1:3))) -mpi.allgatherv(double(1),type=2,rdata=double(sum(1:3)+1),rcounts=c(1,1:3)) +# mpi.bcast.cmd(x<-rnorm(id)) +# mpi.bcast.cmd(mpi.gatherv(x,type=2,rdata=double(1),rcounts=1)) +# mpi.gatherv(double(1),type=2,rdata=double(sum(1:3)+1),rcounts=c(1,1:3)) + +#mpi.bcast.cmd(out1<-mpi.allgatherv(x,type=2,rdata=double(sum(1:3)+1), +# rcounts=c(1,1:3))) +#mpi.allgatherv(double(1),type=2,rdata=double(sum(1:3)+1),rcounts=c(1,1:3)) } } \keyword{interface} diff -Nru rmpi-0.6-9.2/man/mpi.gather.Robj.Rd rmpi-0.7-1/man/mpi.gather.Robj.Rd --- rmpi-0.6-9.2/man/mpi.gather.Robj.Rd 2021-02-22 08:11:04.000000000 +0000 +++ rmpi-0.7-1/man/mpi.gather.Robj.Rd 2023-03-18 01:04:07.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.gather.Robj} -\title{Extentions of MPI\_Gather and MPI\_Allgather APIs} +\title{Extentions of MPI_Gather and MPI_Allgather APIs} \alias{mpi.gather.Robj} \alias{mpi.allgather.Robj} \description{ @@ -44,17 +44,17 @@ \examples{ \donttest{ #Assume that there are some slaves running -mpi.bcast.cmd(id<-mpi.comm.rank()) -mpi.bcast.cmd(x<-rnorm(id)) -mpi.bcast.cmd(mpi.gather.Robj(x)) -x<-"test mpi.gather.Robj" -mpi.gather.Robj(x) +#mpi.bcast.cmd(id<-mpi.comm.rank()) +#mpi.bcast.cmd(x<-rnorm(id)) +#mpi.bcast.cmd(mpi.gather.Robj(x)) +#x<-"test mpi.gather.Robj" +#mpi.gather.Robj(x) -mpi.bcast.cmd(obj<-rnorm(id+10)) -mpi.bcast.cmd(nn<-mpi.allgather.Robj(obj)) -obj<-rnorm(5) -mpi.allgather.Robj(obj) -mpi.remote.exec(nn) +#mpi.bcast.cmd(obj<-rnorm(id+10)) +#mpi.bcast.cmd(nn<-mpi.allgather.Robj(obj)) +#obj<-rnorm(5) +#mpi.allgather.Robj(obj) +#mpi.remote.exec(nn) } } \keyword{interface} diff -Nru rmpi-0.6-9.2/man/mpi.get.count.Rd rmpi-0.7-1/man/mpi.get.count.Rd --- rmpi-0.6-9.2/man/mpi.get.count.Rd 2021-02-22 08:11:14.000000000 +0000 +++ rmpi-0.7-1/man/mpi.get.count.Rd 2023-03-17 15:38:07.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.get.count} -\title{MPI\_Get\_count API} +\title{MPI_Get_count API} \usage{ mpi.get.count(type, status = 0) } diff -Nru rmpi-0.6-9.2/man/mpi.get.processor.name.Rd rmpi-0.7-1/man/mpi.get.processor.name.Rd --- rmpi-0.6-9.2/man/mpi.get.processor.name.Rd 2021-02-22 08:11:21.000000000 +0000 +++ rmpi-0.7-1/man/mpi.get.processor.name.Rd 2023-03-17 15:38:24.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.get.processor.name} -\title{MPI\_Get\_processor\_name API} +\title{MPI_Get_processor_name API} \usage{ mpi.get.processor.name(short = TRUE) } diff -Nru rmpi-0.6-9.2/man/mpi.info.Rd rmpi-0.7-1/man/mpi.info.Rd --- rmpi-0.6-9.2/man/mpi.info.Rd 2003-09-25 18:48:09.000000000 +0000 +++ rmpi-0.7-1/man/mpi.info.Rd 2023-03-17 15:44:33.000000000 +0000 @@ -3,7 +3,7 @@ \alias{mpi.info.free} \alias{mpi.info.get} \alias{mpi.info.set} -\title{MPI\_Info\_create, MPI\_Info\_free, MPI\_Info\_get, MPI\_Info\_set APIs} +\title{MPI_Info_create, MPI_Info_free, MPI_Info_get, MPI_Info_set APIs} \description{ Many MPI APIs take an info argument for additional information passing. An info is an object which consists of many (key,value) pairs. Rmpi uses an internal @@ -11,7 +11,7 @@ \code{mpi.info.create} creates a new info object. -\code{mpi.info.free} frees an info object and sets it to MPI\_INFO\_NULL. +\code{mpi.info.free} frees an info object and sets it to MPI_INFO_NULL. \code{mpi.info.get} retrieves the value associated with key in an info. diff -Nru rmpi-0.6-9.2/man/mpi.intercomm.merge.Rd rmpi-0.7-1/man/mpi.intercomm.merge.Rd --- rmpi-0.6-9.2/man/mpi.intercomm.merge.Rd 2021-02-22 08:11:45.000000000 +0000 +++ rmpi-0.7-1/man/mpi.intercomm.merge.Rd 2023-03-17 15:39:28.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.intercomm.merge} -\title{MPI\_Intercomm\_merge API} +\title{MPI_Intercomm_merge API} \usage{ mpi.intercomm.merge(intercomm=2, high=0, comm=1) } diff -Nru rmpi-0.6-9.2/man/mpi.parapply.Rd rmpi-0.7-1/man/mpi.parapply.Rd --- rmpi-0.6-9.2/man/mpi.parapply.Rd 2014-05-20 14:05:36.000000000 +0000 +++ rmpi-0.7-1/man/mpi.parapply.Rd 2023-03-18 01:05:10.000000000 +0000 @@ -73,31 +73,31 @@ #Assume that there are some slaves running #mpi.applyLB -x=1:7 -mpi.applyLB(x,rnorm,mean=2,sd=4) +#x=1:7 +#mpi.applyLB(x,rnorm,mean=2,sd=4) #get the same simulation -mpi.remote.exec(set.seed(111)) -mpi.applyLB(x,rnorm,mean=2,sd=4) -mpi.remote.exec(set.seed(111)) -mpi.applyLB(x,rnorm,mean=2,sd=4,apply.seq=.mpi.applyLB) +#mpi.remote.exec(set.seed(111)) +#mpi.applyLB(x,rnorm,mean=2,sd=4) +#mpi.remote.exec(set.seed(111)) +#mpi.applyLB(x,rnorm,mean=2,sd=4,apply.seq=.mpi.applyLB) #mpi.parApply -x=1:24 -dim(x)=c(2,3,4) -mpi.parApply(x, MARGIN=c(1,2), FUN=mean,job.num = 5) +#x=1:24 +#dim(x)=c(2,3,4) +#mpi.parApply(x, MARGIN=c(1,2), FUN=mean,job.num = 5) #mpi.parLapply -mdat <- matrix(c(1,2,3, 7,8,9), nrow = 2, ncol=3, byrow=TRUE, - dimnames = list(c("R.1", "R.2"), c("C.1", "C.2", "C.3"))) -mpi.parLapply(mdat, rnorm) +#mdat <- matrix(c(1,2,3, 7,8,9), nrow = 2, ncol=3, byrow=TRUE, +# dimnames = list(c("R.1", "R.2"), c("C.1", "C.2", "C.3"))) +#mpi.parLapply(mdat, rnorm) #mpi.parSapply -mpi.parSapply(mdat, rnorm) +#mpi.parSapply(mdat, rnorm) #mpi.parMM -A=matrix(1:1000^2,ncol=1000) -mpi.parMM(A,A) +#A=matrix(1:1000^2,ncol=1000) +#mpi.parMM(A,A) } } \keyword{utilities} diff -Nru rmpi-0.6-9.2/man/mpi.probe.Rd rmpi-0.7-1/man/mpi.probe.Rd --- rmpi-0.6-9.2/man/mpi.probe.Rd 2021-02-22 08:15:06.000000000 +0000 +++ rmpi-0.7-1/man/mpi.probe.Rd 2023-03-17 15:39:48.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.probe} -\title{MPI\_Probe and MPI\_Iprobe APIs} +\title{MPI_Probe and MPI_Iprobe APIs} \usage{ mpi.probe(source, tag, comm = 1, status = 0) mpi.iprobe(source, tag, comm = 1, status = 0) diff -Nru rmpi-0.6-9.2/man/mpi.reduce.Rd rmpi-0.7-1/man/mpi.reduce.Rd --- rmpi-0.6-9.2/man/mpi.reduce.Rd 2021-02-22 08:13:27.000000000 +0000 +++ rmpi-0.7-1/man/mpi.reduce.Rd 2023-03-17 15:40:03.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.reduce} -\title{MPI\_Reduce and MPI\_Allreduce APIs} +\title{MPI_Reduce and MPI_Allreduce APIs} \alias{mpi.allreduce} \alias{mpi.reduce} \description{ diff -Nru rmpi-0.6-9.2/man/mpi.remote.exec.Rd rmpi-0.7-1/man/mpi.remote.exec.Rd --- rmpi-0.6-9.2/man/mpi.remote.exec.Rd 2014-05-20 14:06:48.000000000 +0000 +++ rmpi-0.7-1/man/mpi.remote.exec.Rd 2023-03-18 01:05:32.000000000 +0000 @@ -43,9 +43,9 @@ } \examples{ \donttest{ -mpi.remote.exec(mpi.comm.rank()) - x=5 -mpi.remote.exec(rnorm,x) +#mpi.remote.exec(mpi.comm.rank()) +# x=5 +#mpi.remote.exec(rnorm,x) } } diff -Nru rmpi-0.6-9.2/man/mpi.scatter.Rd rmpi-0.7-1/man/mpi.scatter.Rd --- rmpi-0.6-9.2/man/mpi.scatter.Rd 2021-02-22 08:13:35.000000000 +0000 +++ rmpi-0.7-1/man/mpi.scatter.Rd 2023-03-18 01:06:06.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.scatter} -\title{MPI\_Scatter and MPI\_Scatterv APIs} +\title{MPI_Scatter and MPI_Scatterv APIs} \alias{mpi.scatter} \alias{mpi.scatterv} \description{ @@ -47,14 +47,14 @@ \donttest{ #Need 3 slaves to run properly #Or run mpi.spawn.Rslaves(nslaves=3) - num="123456789abcd" - scounts<-c(2,3,1,7) - mpi.bcast.cmd(strnum<-mpi.scatter(integer(1),type=1,rdata=integer(1),root=0)) - strnum<-mpi.scatter(scounts,type=1,rdata=integer(1),root=0) - mpi.bcast.cmd(ans <- mpi.scatterv(string(1),scounts=0,type=3,rdata=string(strnum), - root=0)) - mpi.scatterv(as.character(num),scounts=scounts,type=3,rdata=string(strnum),root=0) - mpi.remote.exec(ans) +# num="123456789abcd" +# scounts<-c(2,3,1,7) +# mpi.bcast.cmd(strnum<-mpi.scatter(integer(1),type=1,rdata=integer(1),root=0)) +# strnum<-mpi.scatter(scounts,type=1,rdata=integer(1),root=0) +# mpi.bcast.cmd(ans <- mpi.scatterv(string(1),scounts=0,type=3,rdata=string(strnum), +# root=0)) +# mpi.scatterv(as.character(num),scounts=scounts,type=3,rdata=string(strnum),root=0) +# mpi.remote.exec(ans) } } \keyword{interface} diff -Nru rmpi-0.6-9.2/man/mpi.scatter.Robj.Rd rmpi-0.7-1/man/mpi.scatter.Robj.Rd --- rmpi-0.6-9.2/man/mpi.scatter.Robj.Rd 2014-05-20 14:07:52.000000000 +0000 +++ rmpi-0.7-1/man/mpi.scatter.Robj.Rd 2023-03-18 01:06:48.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.scatter.Robj} -\title{Extensions of MPI\_ SCATTER and MPI\_SCATTERV } +\title{Extensions of MPI_ SCATTER and MPI_SCATTERV } \alias{mpi.scatter.Robj} \alias{mpi.scatter.Robj2slave} \description{ @@ -37,19 +37,19 @@ \examples{ \donttest{ #assume that there are three slaves running -mpi.bcast.cmd(x<-mpi.scatter.Robj()) +#mpi.bcast.cmd(x<-mpi.scatter.Robj()) -xx <- list("master",rnorm(3),letters[2],1:10) -mpi.scatter.Robj(obj=xx) +#xx <- list("master",rnorm(3),letters[2],1:10) +#mpi.scatter.Robj(obj=xx) -mpi.remote.exec(x) +#mpi.remote.exec(x) #scatter a matrix to slaves -dat=matrix(1:24,ncol=3) -splitmatrix = function(x, ncl) lapply(.splitIndices(nrow(x), ncl), function(i) x[i,]) -dat2=splitmatrix(dat,3) -mpi.scatter.Robj2slave(dat2) -mpi.remote.exec(dat2) +#dat=matrix(1:24,ncol=3) +#splitmatrix = function(x, ncl) lapply(.splitIndices(nrow(x), ncl), function(i) x[i,]) +#dat2=splitmatrix(dat,3) +#mpi.scatter.Robj2slave(dat2) +#mpi.remote.exec(dat2) } } \keyword{utilities} diff -Nru rmpi-0.6-9.2/man/mpi.send.Rd rmpi-0.7-1/man/mpi.send.Rd --- rmpi-0.6-9.2/man/mpi.send.Rd 2021-02-22 08:13:46.000000000 +0000 +++ rmpi-0.7-1/man/mpi.send.Rd 2023-03-18 01:07:23.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.send} -\title{MPI\_Send, MPI\_Isend, MPI\_Recv, and MPI\_Irecv APIs} +\title{MPI_Send, MPI_Isend, MPI_Recv, and MPI_Irecv APIs} \alias{mpi.send} \alias{mpi.isend} \alias{mpi.recv} @@ -86,14 +86,14 @@ \examples{ \donttest{ #on a slave -mpi.send(1:10,1,0,0) +#mpi.send(1:10,1,0,0) #on master -x <- integer(10) -mpi.irecv(x,1,1,0) -x -mpi.wait() -x +#x <- integer(10) +#mpi.irecv(x,1,1,0) +#x +#mpi.wait() +#x } } \keyword{interface} diff -Nru rmpi-0.6-9.2/man/mpi.sendrecv.Rd rmpi-0.7-1/man/mpi.sendrecv.Rd --- rmpi-0.6-9.2/man/mpi.sendrecv.Rd 2021-02-22 08:14:03.000000000 +0000 +++ rmpi-0.7-1/man/mpi.sendrecv.Rd 2023-03-18 01:07:44.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.sendrecv} -\title{MPI\_Sendrecv and MPI\_Sendrecv\_replace APIs} +\title{MPI_Sendrecv and MPI_Sendrecv_replace APIs} \alias{mpi.sendrecv} \alias{mpi.sendrecv.replace} \description{ @@ -65,8 +65,8 @@ } \examples{ \donttest{ -mpi.sendrecv(as.integer(11:20),1,0,33,integer(10),1,0,33,comm=0) -mpi.sendrecv.replace(seq(1,2,by=0.1),2,0,99,0,99,comm=0) +#mpi.sendrecv(as.integer(11:20),1,0,33,integer(10),1,0,33,comm=0) +#mpi.sendrecv.replace(seq(1,2,by=0.1),2,0,99,0,99,comm=0) } } \keyword{interface} diff -Nru rmpi-0.6-9.2/man/mpi.send.Robj.Rd rmpi-0.7-1/man/mpi.send.Robj.Rd --- rmpi-0.6-9.2/man/mpi.send.Robj.Rd 2021-02-22 08:13:55.000000000 +0000 +++ rmpi-0.7-1/man/mpi.send.Robj.Rd 2023-03-17 15:40:55.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.send.Robj} -\title{Extensions of MPI\_Send and MPI\_Recv APIs} +\title{Extensions of MPI_Send and MPI_Recv APIs} \alias{mpi.send.Robj} \alias{mpi.isend.Robj} \alias{mpi.recv.Robj} diff -Nru rmpi-0.6-9.2/man/mpi.spawn.Rslaves.Rd rmpi-0.7-1/man/mpi.spawn.Rslaves.Rd --- rmpi-0.6-9.2/man/mpi.spawn.Rslaves.Rd 2014-05-20 14:10:00.000000000 +0000 +++ rmpi-0.7-1/man/mpi.spawn.Rslaves.Rd 2023-03-18 01:08:08.000000000 +0000 @@ -85,10 +85,10 @@ } \examples{ \donttest{ -mpi.spawn.Rslaves(nslaves=2) -tailslave.log() -mpi.remote.exec(rnorm(10)) -mpi.close.Rslaves() +#mpi.spawn.Rslaves(nslaves=2) +#tailslave.log() +#mpi.remote.exec(rnorm(10)) +#mpi.close.Rslaves() } } \keyword{utilities} diff -Nru rmpi-0.6-9.2/man/mpi.universe.size.Rd rmpi-0.7-1/man/mpi.universe.size.Rd --- rmpi-0.6-9.2/man/mpi.universe.size.Rd 2021-02-22 08:14:10.000000000 +0000 +++ rmpi-0.7-1/man/mpi.universe.size.Rd 2023-03-17 15:44:50.000000000 +0000 @@ -1,5 +1,5 @@ \name{mpi.universe.size} -\title{MPI\_Universe\_size API} +\title{MPI_Universe_size API} \usage{ mpi.universe.size() } diff -Nru rmpi-0.6-9.2/man/mpi.wait.Rd rmpi-0.7-1/man/mpi.wait.Rd --- rmpi-0.6-9.2/man/mpi.wait.Rd 2021-02-22 08:14:16.000000000 +0000 +++ rmpi-0.7-1/man/mpi.wait.Rd 2023-03-17 14:08:09.000000000 +0000 @@ -66,19 +66,19 @@ otherwise. If TRUE, it is the same as \code{mpi.waitall}. \code{mpi.waitsome} returns a list: count--- number of requests that have -been completed; indices---an integer vector of size \$count of those +been completed; indices---an integer vector of size count of those completed request numbers (in 0, 1 ,..., count-1). In addition, statuses -0, 1, ..., \$count-1 contain corresponding information that can be +0, 1, ..., count-1 contain corresponding information that can be retrieved by \code{mpi.get.count} and \code{mpi.get.sourcetag}. -\code{mpi.testsome} is the same as \code{mpi.waitsome} except that \$count -may be 0 and in this case \$indices is no use. +\code{mpi.testsome} is the same as \code{mpi.waitsome} except that count +may be 0 and in this case indices is no use. } \details{ \code{mpi.wait} and \code{mpi.test} are used to complete a nonblocking send and receive request: use the same request number by \code{mpi.isend} or \code{mpi.irecv}. Once completed, the associated request is set to -MPI\_REQUEST\_NULL and status contains information such as source, tag, +MPI_REQUEST_NULL and status contains information such as source, tag, and length of message. If multiple nonblocking sends or receives are initiated, the following diff -Nru rmpi-0.6-9.2/MD5 rmpi-0.7-1/MD5 --- rmpi-0.6-9.2/MD5 2021-10-25 18:10:02.000000000 +0000 +++ rmpi-0.7-1/MD5 2023-03-18 08:50:02.000000000 +0000 @@ -1,12 +1,12 @@ 48d9165eff0f157e98fe871cdc77f6e8 *ChangeLog -506fec635e04d1d8db0e86acbbaa974f *DESCRIPTION +def3cef97061595cf67fd0489f2a1125 *DESCRIPTION 26cd4ba8a505043c41e6a157440c1f91 *INDEX a2b075414ee02b4d08bfee11bdb77743 *NAMESPACE 31958d10c5ef9ec943b5bb81230b5d73 *R/Rcoll.R 319a9fbcb89c7f079df90653a91906df *R/Rcomm.R -3a58d3466d62acc64112775a894ae274 *R/Rmpi.R +d34937e6699a72fc971c71d41273cb0d *R/Rmpi.R abc8bf1859b8644c495af3a89ac7801e *R/Rng.R -f0a55da7d1cbac75893da8fb1dec2f7e *R/Rparutilities.R +b0a8c3f909fe20a4a7c14f00a505fe96 *R/Rparutilities.R 50ce25c2959c5239685fec62cabb3a15 *R/zzz.R 54229097ac0d8f1af7e8658607401f05 *README cb311b30ce8eb7b9a6805b8286eb0911 *cleanup @@ -20,7 +20,7 @@ 2c479f153bf3f3004604c483bec892cd *demo/simplePI.R a88040efd8871365286c242eb1038a73 *demo/slave1PI.R 8f744c42621ce97c2ea511f129a72270 *demo/slave2PI.R -a1337e731642b8bc504d2ebcc1ee8913 *inst/CITATION +1849e69107b6be7285082ba49b341cbc *inst/CITATION 4569255257bf552a5acafd1151e14570 *inst/MacR64slaves.sh c23a23abf5b0a0afc08883c681ec467f *inst/Rprofile cf25051b76102776342a3e9a2ebb78b7 *inst/Rslaves.sh @@ -29,56 +29,56 @@ c684edd92cbfeaabd5906522eea4da8c *inst/cslavePI.c 0e7acd320d749f1904dc386007dad7ab *inst/slavedaemon.R 43ff2c13d03967db36c0c89446d7cda8 *man/hosts.Rd -cd35af8150da2f3d27b97b79ac1dad83 *man/internal.Rd -43caccb925737215522176f3d79e1fec *man/mpi.abort.Rd -c9061d5e1d815b79f31b60ee76952bc4 *man/mpi.apply.Rd -6427a3eff81ae3f18ea64695ae408453 *man/mpi.barrier.Rd -97ec446c2bbe203ee81dc1f365ddd830 *man/mpi.bcast.Rd -137142c7622f8a5bec4c9e400c4ca27f *man/mpi.bcast.Robj.Rd -ffe20743ccac1a39d9678a746c387fc2 *man/mpi.bcast.cmd.Rd -d963c8d3f5fb71cf0bb8bb70c4583ecb *man/mpi.cart.coords.Rd -22ab6ee97ac26d7d9edff9b426459387 *man/mpi.cart.create.Rd -62b6b658395a9f100f4b831962fb74f6 *man/mpi.cart.get.Rd -7d94b783440eb172f73aee839bdc7007 *man/mpi.cart.rank.Rd -2b1d76ca4628c17f60bb192de08f8ba6 *man/mpi.cart.shift.Rd -222ab2f52447517fb2eb284576ca874c *man/mpi.cartdim.get.Rd -995ba8c1088a97d3322700462cd3f6dd *man/mpi.comm.Rd -53f8486de58d0ec0854627f55e4dfa2a *man/mpi.comm.disconnect.Rd -7301a1cbe33dd169abea258a57992d14 *man/mpi.comm.free.Rd -4ed040d9e24518344e4f9a267394d4fe *man/mpi.comm.inter.Rd -c5f7f22b44450753f4a0d9137784bfd9 *man/mpi.comm.set.errhandler.Rd -985aa4a8c61ff607df1fdb457b5eab8b *man/mpi.comm.spawn.Rd -a5d25f64150fbef1c2ba22df121941d5 *man/mpi.const.Rd -86e0ccdf1e39468144d35e28dba90aa7 *man/mpi.dims.create.Rd +f88356cb787c59647e7e380651ddcce8 *man/internal.Rd +3e392b76f4c072938eb64b54e85dc5b0 *man/mpi.abort.Rd +a4240c9f8ff3117a60ce56de2ad3035d *man/mpi.apply.Rd +b6e7be4a1ec420f1dddbbdef167754f7 *man/mpi.barrier.Rd +1e73cc53d958b186dfc3cc787a85612a *man/mpi.bcast.Rd +1f5669ed5b77ba7a849305e9e9c36497 *man/mpi.bcast.Robj.Rd +af1867a5f2caf93fcffdbbb5b8e80f89 *man/mpi.bcast.cmd.Rd +d79ad9066a703d7508324ac0d8a749d0 *man/mpi.cart.coords.Rd +cc91b26e10909d68b5591274996e94cf *man/mpi.cart.create.Rd +ec76ff5213c57635e30515e62de205cf *man/mpi.cart.get.Rd +a39b51fb72ab398222d2b25a37649917 *man/mpi.cart.rank.Rd +8691a5a6049779bc9045683e4a737c79 *man/mpi.cart.shift.Rd +4dfa0028422710fbc250f8dcb893dbfa *man/mpi.cartdim.get.Rd +e3c2189f9368544a54b0fc99cf4f845c *man/mpi.comm.Rd +1c6b0e9370b869bb71947067c762d684 *man/mpi.comm.disconnect.Rd +c6939735257e3e1f15da021bbd5ca140 *man/mpi.comm.free.Rd +f314a8d379a9ea448e7d4a467f93e4bd *man/mpi.comm.inter.Rd +ae622dd8500c3542b6eeb674ff95c435 *man/mpi.comm.set.errhandler.Rd +ff0016d5eb808959bbca26fd65a1a463 *man/mpi.comm.spawn.Rd +5b19e5946ebace4df962f665df32a01a *man/mpi.const.Rd +94bc63d47236840407be20005d63ac99 *man/mpi.dims.create.Rd e93e6b02a52a3c6bc3af2004bf10c27c *man/mpi.exit.Rd -9e94d149fe07a2b59edaaee734664b03 *man/mpi.finalize.Rd -1887dd5b4445c0b09149998817bada52 *man/mpi.gather.Rd -0817616965e85826eae4567a251eb475 *man/mpi.gather.Robj.Rd -2e357dec045b1e5dd0853ac249ba7e9b *man/mpi.get.count.Rd -cde976b90aa7dc99331572892ff930ba *man/mpi.get.processor.name.Rd +b034973b3f4ba71e3eefe9cefe941a3a *man/mpi.finalize.Rd +dd7ebcf6ad082467a69cc340ec4dc998 *man/mpi.gather.Rd +5dcb2af797154b2926bd96a834144fee *man/mpi.gather.Robj.Rd +c3a9f66b3e84c9ea48827acba703ab72 *man/mpi.get.count.Rd +174a4b20da420bc7b2cd381125a501d8 *man/mpi.get.processor.name.Rd 5e83f57c94ac31cb5515b5a49161a4d1 *man/mpi.get.sourcetag.Rd 3951acabd9aec61ee37dcfba41261443 *man/mpi.iapply.Rd -e0b0366b6118f69da6e70a34bc9b021c *man/mpi.info.Rd -8a262bd64a8022e20ee211e85dbb4331 *man/mpi.intercomm.merge.Rd +fa2d59a7f7260fdd86890c616b5cc167 *man/mpi.info.Rd +5f8c59291d8afc556402db99436db766 *man/mpi.intercomm.merge.Rd 3d5619bbc37edb0ad705fdaaed08ea44 *man/mpi.parSim.Rd -c6f3015d6ff2187b4041f14003301251 *man/mpi.parapply.Rd -cdf8a4672f846dabf25269696f77e0a7 *man/mpi.probe.Rd +0af48a5cc05142012a4fc3b93c2230fb *man/mpi.parapply.Rd +49cbf532fc6e4bef6b1d037f618333b6 *man/mpi.probe.Rd d9ab9049a7c55e41e9bb57f6a4393af7 *man/mpi.realloc.Rd -2380d55a8e0b3b2721f761c09f1adaa9 *man/mpi.reduce.Rd -be38e88b91a37a2567c24f9b396d8f03 *man/mpi.remote.exec.Rd -894671b0f07077148b962493a6aa79ce *man/mpi.scatter.Rd -59b447971c8189a64880d4937b81347d *man/mpi.scatter.Robj.Rd -181bcf6aeaa7d3f3d05007ed545f9ea0 *man/mpi.send.Rd -55f5f81de28f211a1ebf3f0d57a405b3 *man/mpi.send.Robj.Rd -6f766d5d486efbf98feeaf1ed20efb31 *man/mpi.sendrecv.Rd +e291f08afde4f1aad4048fb85f01cdad *man/mpi.reduce.Rd +65ba8fddb67b11a7ee9e0ee8fa46477a *man/mpi.remote.exec.Rd +00f420c499dd3a44c412de129efc3f9b *man/mpi.scatter.Rd +9d2bd6cc9eef2d9c854f9862bc51dc71 *man/mpi.scatter.Robj.Rd +96b3a85bb07a874ff0f9d6ee777dcf58 *man/mpi.send.Rd +aeb1e3f2ad310ebd320087543a3585fa *man/mpi.send.Robj.Rd +1340427c3d04833cecd501990fea3d07 *man/mpi.sendrecv.Rd c1f9ee7a74e349500979a1513962a84d *man/mpi.setup.rng.Rd -f4ad91406137910ac38820766d94c2c3 *man/mpi.spawn.Rslaves.Rd -4dea3c9792392b743b5e0ae315ec3560 *man/mpi.universe.size.Rd -41ac8ab6f15bf95b7907184876876fd5 *man/mpi.wait.Rd +c2a58114521d7c1c2ff6af56e03bd678 *man/mpi.spawn.Rslaves.Rd +d13da087c3f1ba349f0b61cfc4cf15d4 *man/mpi.universe.size.Rd +db568f4b2d3cafbcd72bb0586e7e439e *man/mpi.wait.Rd 49b3b4f4c92b8436d2b9b218a76696d3 *src/Makevars.in cd2b3396214f58838c411a508b97676c *src/Makevars.win -1d06c8bdead74ba978e1815c1870af93 *src/Rmpi.c -5d3bdc99adb8d134e2305ca461bc5232 *src/Rmpi.h -ded21a3dfaa785898ff038db9b476020 *src/conversion.c +245ccee94c51d52a8397fba5fb8d275a *src/Rmpi.c +70faee79a6bf9da0f142044740a4a263 *src/Rmpi.h +c5d36c8c1c0c6c26ea94ba5d77c0ee69 *src/conversion.c 646c8ca543539f998e7e657f0e20c610 *src/internal.c 60517da86e8d9ece7e6464eb1b129c86 *src/msmpi.def diff -Nru rmpi-0.6-9.2/R/Rmpi.R rmpi-0.7-1/R/Rmpi.R --- rmpi-0.6-9.2/R/Rmpi.R 2021-02-22 08:03:16.000000000 +0000 +++ rmpi-0.7-1/R/Rmpi.R 2023-03-17 15:52:17.000000000 +0000 @@ -1,6 +1,5 @@ ### Copyright (C) 2002 Hao Yu mpi.finalize <- function(){ - #if(interactive() && mpi.is.master()) # print("Exiting Rmpi. Rmpi cannot be used unless relaunching R.") .Call("mpi_finalize",PACKAGE = "Rmpi") } diff -Nru rmpi-0.6-9.2/R/Rparutilities.R rmpi-0.7-1/R/Rparutilities.R --- rmpi-0.6-9.2/R/Rparutilities.R 2018-04-06 16:30:09.000000000 +0000 +++ rmpi-0.7-1/R/Rparutilities.R 2023-03-17 14:33:13.000000000 +0000 @@ -1,973 +1,973 @@ -### Copyright (C) 2002 Hao Yu - -mpi.hostinfo <- function(comm=1){ - if (mpi.comm.size(comm)==0){ - err <-paste("It seems no members running on comm", comm) - stop(err) - } - hostname <- mpi.get.processor.name() - rk <- mpi.comm.rank(comm=comm) - size <- mpi.comm.size(comm=comm) - cat("\tHost:",hostname,"\tRank(ID):",rk, "\tof Size:", size, - "on comm", comm, "\n") -} - -slave.hostinfo <- function(comm=1, short=TRUE){ - #if (!mpi.is.master()) - if (mpi.comm.rank(comm)!=0) - stop("cannot run slavehostinfo on slaves") - size <- mpi.comm.size(comm) - if (size==0){ - err <-paste("It seems no slaves running on comm", comm) - stop(err) - } - if (size == 1) - mpi.hostinfo(comm) - else { - master <-mpi.get.processor.name() - slavehost <- unlist(mpi.remote.exec(mpi.get.processor.name(),comm=comm)) - slavecomm <- 1 #as.integer(mpi.remote.exec(.comm,comm=comm)) - ranks <- 1:(size-1) - commm <- paste(comm, ")",sep="") - if (size > 10){ - rank0 <- paste("master (rank 0 , comm", commm) - ranks <- c(paste(ranks[1:9]," ",sep=""), ranks[10:(size-1)]) - } - else - rank0 <- paste("master (rank 0, comm", commm) - cat(rank0, "of size", size, "is running on:",master, "\n") - slavename <- paste("slave", ranks,sep="") - ranks <- paste("(rank ",ranks, ", comm ",slavecomm,")", sep="") - if (short && size > 8){ - for (i in 1:3) { - cat(slavename[i], ranks[i], "of size",size, - "is running on:",slavehost[i], "\n") - } - cat("... ... ...\n") - for (i in (size-2):(size-1)){ - cat(slavename[i], ranks[i], "of size",size, - "is running on:",slavehost[i], "\n") - } - } - else { - for (i in 1:(size-1)){ - cat(slavename[i], ranks[i], "of size",size, - "is running on:",slavehost[i], "\n") - } - } - } -} - -lamhosts <- function(){ - hosts <- system("lamnodes C -c -n", TRUE) - base <-character(0) - for (host in hosts) - base <- c(base, unlist(strsplit(host, "\\."))[1]) - nn <- 0:(length(hosts)-1) - names(nn) <- base - nn -} - -mpi.spawn.Rslaves <- - function(Rscript=system.file("slavedaemon.R", package="Rmpi"), - nslaves=mpi.universe.size(), - root=0, - intercomm=2, - comm=1, - hosts=NULL, - needlog=TRUE, - mapdrive=TRUE, - quiet=FALSE, - nonblock=TRUE, - sleep=0.1) { - if (!is.loaded("mpi_comm_spawn")) - stop("You cannot use MPI_Comm_spawn API") - if (mpi.comm.size(comm) > 0){ - err <-paste("It seems there are some slaves running on comm ", comm) - stop(err) - } - if (.Platform$OS=="windows"){ - #stop("Spawning is not implemented. Please use mpiexec with Rprofile.") - workdrive <- unlist(strsplit(getwd(),":"))[1] - workdir <- unlist(strsplit(getwd(),"/")) - if (length(workdir) > 1) - workdir <-paste(workdir, collapse="\\") - else - workdir <- paste(workdir,"\\") - localhost <- Sys.getenv("COMPUTERNAME") - networkdrive <-NULL #.Call("RegQuery", as.integer(2),paste("NETWORK\\",workdrive,sep=""), - #PACKAGE="Rmpi") - remotepath <-networkdrive[which(networkdrive=="RemotePath")+1] - mapdrive <- as.logical(mapdrive && !is.null(remotepath)) - arg <- c(Rscript, R.home(), workdrive, workdir, localhost, mapdrive, remotepath) - if (.Platform$r_arch == "i386") - realns <- mpi.comm.spawn(slave = system.file("Rslaves32.cmd", - package = "Rmpi"), slavearg = arg, nslaves = nslaves, - info = 0, root = root, intercomm = intercomm, quiet = quiet) - else - realns <- mpi.comm.spawn(slave = system.file("Rslaves64.cmd", - package = "Rmpi"), slavearg = arg, nslaves = nslaves, - info = 0, root = root, intercomm = intercomm, quiet = quiet) - } - else{ - tmp <- paste(Sys.getpid(), "+", comm, sep="") - if (needlog) - arg <- c(Rscript, tmp, "needlog", R.home()) - else - arg <- c(Rscript, tmp , "nolog", R.home()) - if (!is.null(hosts)){ - hosts <- as.integer(hosts) - if (any(is.na(hosts))) - stop("hosts argument contains non-integer object(s).") - if (max(hosts) > mpi.universe.size() -1 ||min(hosts) < 0){ - tmp1 <- paste("hosts number should be within 0 to", - mpi.universe.size()-1) - stop(tmp1) - } - nslaves <- length(hosts) - tmpfile <-paste(tmp, "appschema", sep="") - fileobj <- file(tmpfile,"w") - cat("c", paste(hosts, collapse=","), sep="", file=fileobj) - cat(" ", system.file("Rslaves.sh", package="Rmpi"), file=fileobj) - cat(" ", paste(arg, collapse=" "), file=fileobj) - close(fileobj) - mpi.info.create(0) - mpi.info.set(0,"file",tmpfile) - } - if (length(unlist(strsplit(.Platform$pkgType,"mac"))) ==2 && .Platform$r_arch =="x86_64") - realns<-mpi.comm.spawn(slave=system.file("MacR64slaves.sh", package="Rmpi"), - slavearg=arg, nslaves=nslaves, info=0, root=root, intercomm=intercomm, quiet = quiet) - else - realns<-mpi.comm.spawn(slave=system.file("Rslaves.sh", package="Rmpi"), - slavearg=arg, nslaves=nslaves, info=0, root=root, intercomm=intercomm, quiet = quiet) - } - if (!is.null(hosts)){ - unlink(tmpfile) - mpi.info.free(0) - } - if (realns==0) - stop("It seems no single slave spawned.") - if (mpi.intercomm.merge(intercomm,0,comm)) { - mpi.comm.set.errhandler(comm) - mpi.comm.disconnect(intercomm) - mpi.bcast(nonblock,type=1, rank=0, comm=comm) - mpi.bcast(sleep,type=2, rank=0, comm=comm) - if (!quiet) slave.hostinfo(comm) - } - else - stop("Fail to merge the comm for master and slaves.") -} - -mpi.remote.exec <- function(cmd, ..., simplify=TRUE, comm=1, ret=TRUE){ - if (mpi.comm.size(comm) < 2) - stop("It seems no slaves running.") - tag <- floor(runif(1,20000,30000)) - scmd <- substitute(cmd) - arg <-list(...) - #if (length(arg) > 0) - # deparse(arg) - #tag.ret <- c(tag, ret, simplify) - mpi.bcast.cmd(.mpi.worker.exec, tag=tag, ret=ret, simplify=simplify, comm = comm) - #mpi.bcast(as.integer(tag.ret), type=1, comm=comm) - mpi.bcast.Robj(list(scmd=scmd, arg=arg), comm=comm) - - if (ret){ - size <- mpi.comm.size(comm) - allcode <- mpi.allgather(integer(2), 1, integer(2*size), comm) - type <- allcode[seq(3,2*size,2)] - len <- allcode[seq(4,2*size,2)] - eqlen <- all(len==len[1]) - if (all(type==1)){ - if (eqlen && simplify){ - out <- mpi.gather(integer(len[1]),1,integer(size*len[1]),0,comm) - out <- out[(len[1]+1):(size*len[1])] - dim(out) <- c(len[1], size-1) - out <- data.frame(out) - } - else { - out1<-mpi.gatherv(integer(1),1,integer(1+sum(len)),c(1,len),0,comm) - uplen <- cumsum(len)+1 - lowlen <-c(2, uplen[-(size-1)]+1) - out <- as.list(integer(size-1)) - names(out) <- paste("slave",1:(size-1), sep="") - for (i in 1:(size-1)) - out[[i]]<- out1[lowlen[i]:uplen[i]] - } - } - else if (all(type==2)){ - if (eqlen && simplify){ - out <- mpi.gather(double(len[1]),2,double(size*len[1]),0,comm) - out <- out[(len[1]+1):(size*len[1])] - dim(out) <- c(len[1], size-1) - out <- data.frame(out) - } - else { - out1<-mpi.gatherv(double(1),2,double(1+sum(len)),c(1,len),0,comm) - uplen <- cumsum(len)+1 - lowlen <-c(2, uplen[-(size-1)]+1) - out <- as.list(integer(size-1)) - names(out) <- paste("slave",1:(size-1), sep="") - for (i in 1:(size-1)) - out[[i]]<- out1[lowlen[i]:uplen[i]] - } - } - else if (all(type==4)){ - if (eqlen && simplify){ - out <- mpi.gather(raw(len[1]),4,raw(size*len[1]),0,comm) - out <- out[(len[1]+1):(size*len[1])] - dim(out) <- c(len[1], size-1) - out <- data.frame(out) - } - else { - out1<-mpi.gatherv(raw(1),4,raw(1+sum(len)),c(1,len),0,comm) - uplen <- cumsum(len)+1 - lowlen <-c(2, uplen[-(size-1)]+1) - out <- as.list(integer(size-1)) - names(out) <- paste("slave",1:(size-1), sep="") - for (i in 1:(size-1)) - out[[i]]<- out1[lowlen[i]:uplen[i]] - } - } - - else { - out <- as.list(integer(size-1)) - names(out) <- paste("slave",1:(size-1), sep="") - for (i in 1:(size-1)){ - tmp<- mpi.recv.Robj(mpi.any.source(),tag,comm) - src <- mpi.get.sourcetag()[1] - out[[src]]<- tmp - } - } - out - } -} - -.typeindex <- function (x) { - if(class(x)=="integer") - as.integer(c(1,length(x))) - else if (class(x)=="numeric") - as.integer(c(2,length(x))) - else if (class(x)=="raw") - as.integer(c(4,length(x))) - - else - as.integer(-1) -} - -.mpi.worker.exec <- function(tag, ret, simplify){ - #assign(".mpi.err", FALSE, envir = .GlobalEnv) - assign(".mpi.err", FALSE) - .comm <- 1 - #tag.ret <- mpi.bcast(integer(3), type=1, comm=.comm) - #tag <- tag.ret[1] - #ret <- as.logical(tag.ret[2]) - #simplify <- as.logical(tag.ret[3]) - scmd.arg <- mpi.bcast.Robj(comm=.comm) - - if (ret){ - size <- mpi.comm.size(.comm) - myerrcode <- as.integer(0) - if (length(scmd.arg$arg)>0) - out <- try(do.call(as.character(scmd.arg$scmd), scmd.arg$arg, envir=.GlobalEnv),TRUE) - else - out <- try(eval(scmd.arg$scmd, envir=sys.parent()), TRUE) - - if (get(".mpi.err")){ - print(geterrmessage()) - type <- integer(2) - } - else { - type <- .typeindex(out) - if (is.na(type[2])) - type[2] <- as.integer(0) - } - allcode <- mpi.allgather(type, 1, integer(2*size), .comm) - type <- allcode[seq(3,2*size,2)] - len <- allcode[seq(4,2*size,2)] - eqlen <- all(len==len[1]) - if (all(type==1)) { - if (eqlen && simplify) - mpi.gather(out, 1, integer(1), 0, .comm) - else - mpi.gatherv(out, 1, integer(1), integer(1), 0 ,.comm) - } - else if (all(type==2)) { - if (eqlen && simplify) - mpi.gather(out, 2, double(1), 0, .comm) - else - mpi.gatherv(out, 2, double(1), integer(1), 0, .comm) - } - else if (all(type==4)) { - if (eqlen && simplify) - mpi.gather(out, 4, raw(1), 0, .comm) - else - mpi.gatherv(out, 4, raw(1), integer(1), 0, .comm) - } - - else { - mpi.send.Robj(out,0,tag,.comm) - } - } - else { - if (length(scmd.arg$arg)>0) - out <- try(do.call(as.character(scmd.arg$scmd), scmd.arg$arg)) - else - out <- try(eval(scmd.arg$scmd)) - } -} - -mpi.close.Rslaves <- function(dellog=TRUE, comm=1){ - if (mpi.comm.size(comm) < 2){ - err <-paste("It seems no slaves running on comm", comm) - stop(err) - } - #mpi.break=delay(do.call("break", list(), envir=.GlobalEnv)) - mpi.bcast.cmd(cmd="kaerb", rank=0, comm=comm) - if (.Platform$OS!="windows"){ - if (dellog && mpi.comm.size(0) < mpi.comm.size(comm)){ - tmp <- paste(Sys.getpid(),"+",comm,sep="") - logfile <- paste("*.",tmp,".*.log", sep="") - if (length(system(paste("ls", logfile),TRUE,ignore.stderr=TRUE) )>=1) - system(paste("rm", logfile)) - } - } -# mpi.barrier(comm) - if (comm >0){ - #if (is.loaded("mpi_comm_disconnect")) - #mpi.comm.disconnect(comm) - #else - mpi.comm.free(comm) - } -# mpi.comm.set.errhandler(0) -} - -tailslave.log <- function(nlines=3,comm=1){ - if (mpi.comm.size(comm)==0) - stop ("It seems no slaves running") - tmp <- paste(Sys.getpid(),"+",comm,sep="") - logfile <- paste("*.",tmp,".*.log", sep="") - if (length(system(paste("ls", logfile),TRUE,ignore.stderr=TRUE))==0) - stop("It seems no slave log files.") - system(paste("tail -",nlines," ", logfile,sep="")) -} - -mpi.apply <- function(X, FUN, ..., comm=1){ - n <- length(X) - nslaves <- mpi.comm.size(comm)-1 - if (nslaves < n) - stop("data length must be at most total slave size") - if (!is.function(FUN)) - stop("FUN is not a function") - length(list(...)) #test for any non existing R objects - tag <- floor(runif(1,1,1000)) - mpi.bcast.cmd(.mpi.worker.apply, n=n, tag=tag, comm=comm) - #mpi.bcast(as.integer(c(tag,n)),type=1,comm=comm) - mpi.bcast.Robj(list(FUN=FUN,dot.arg=list(...)),rank=0,comm=comm) - if (n < nslaves) - X=c(X,as.list(integer( nslaves-n))) - mpi.scatter.Robj(c(list("master"),as.list(X)),root=0,comm=comm) - - out <- as.list(integer(n)) - for (i in 1:n){ - tmp<- mpi.recv.Robj(mpi.any.source(),tag,comm) - src <- mpi.get.sourcetag()[1] - out[[src]]<- tmp - } - out -} - -.mpi.worker.apply <- function(n, tag){ - #assign(".mpi.err", FALSE, envir = .GlobalEnv) - .comm <- 1 - #tag.n <- mpi.bcast(integer(2), type=1, comm=.comm) - #tag <- tag.n[1] - #n <- tag.n[2] - tmpfunarg <- mpi.bcast.Robj(rank=0, comm=.comm) - .tmpfun <- tmpfunarg$FUN - dotarg <- tmpfunarg$dot.arg - tmpdata.arg <- list(mpi.scatter.Robj(root=0,comm=.comm)) - if (mpi.comm.rank(.comm) <= n){ - out <- try(do.call(".tmpfun", c(tmpdata.arg, dotarg)),TRUE) - mpi.send.Robj(out,0,tag,.comm) - } -} - -mpi.iapply <- function(X, FUN, ..., comm=1, sleep=0.01){ - n <- length(X) - nslaves <- mpi.comm.size(comm)-1 - if (nslaves < n) - stop("data length must be at most total slave size") - if (!is.function(FUN)) - stop("FUN is not a function") - length(list(...)) #test for any non existing R objects - tag <- floor(runif(1,1,1000)) - mpi.bcast.cmd(.mpi.worker.apply, n=n, tag=tag,comm=comm) - #mpi.bcast(as.integer(c(tag,n)),type=1,comm=comm) - mpi.bcast.Robj(list(FUN=FUN,dot.arg=list(...)),rank=0,comm=comm) - if (n < nslaves) - X=c(X,as.list(integer( nslaves-n))) - mpi.scatter.Robj(c(list("master"),as.list(X)),root=0,comm=comm) - - out <- as.list(integer(n)) - done=0 - anysource=mpi.any.source() - repeat { - if (mpi.iprobe(anysource,tag,comm)){ - srctag <- mpi.get.sourcetag() - charlen <- mpi.get.count(type=4) - tmp <- unserialize(mpi.recv(x = raw(charlen), type = 4, srctag[1], - srctag[2], comm)) - out[[srctag[1]]]<- tmp - done=done+1 - } - if (done < n) - Sys.sleep(sleep) - else break - } - gc() - out -} - -mpi.parSim <- function(n=100,rand.gen=rnorm, rand.arg=NULL, - statistic, nsim=100, run=1, slaveinfo=FALSE, sim.seq=NULL, - simplify=TRUE, comm=1, ...){ - sim.seq=NULL - if (mpi.comm.size(comm) < 2) - stop("It seems no slaves running.") - if (!is.function(rand.gen)) - stop("rand.gen is not a function") - if (!is.function(statistic)) - stop("statistic is not a function") - if (!is.null(rand.arg)) - if (!is.list(rand.arg)) - stop("rand.arg is not a list") - if (length(list(...))>0) - deparse(list(...)) - - slave.num <- mpi.comm.size(comm)-1 - if (!is.null(sim.seq)) - if (!is.integer(sim.seq)) - stop("sim.seq is not an integer vector") - else if (min(sim.seq)<1 && max(sim.seq)>slave.num && - length(sim.seq)!=slave.num*run) - stop("sim.seq is not in right order") - - mpi.bcast.cmd(.mpi.worker.sim, n=n, nsim=nsim, run=run, comm=comm) - mpi.bcast.Robj(list(rand.gen=rand.gen, rand.arg=rand.arg, - stat=statistic, stat.arg=list(...)), comm=comm) - - #nnr <- c(n,nsim,run) - #mpi.bcast(as.integer(nnr),type=1, comm=comm) - result <- as.list(integer(slave.num*run)) - - if (!is.null(sim.seq)){ - for ( i in 1:(slave.num*run)){ - result[[i]] <- mpi.recv.Robj(source=sim.seq[i], tag=8, comm=comm) - mpi.send(as.integer(i), type=1, dest=sim.seq[i], tag=88, comm=comm) - } - return(.simplify(slave.num*run, result, simplify, nsim)) - } - - i <- 0 - anysrc <- mpi.any.source() - anytag <- mpi.any.tag() - mpi.parSim.tmp <- integer(slave.num*run) - while (i < slave.num*run){ - i <- i+1 - result[[i]] <- mpi.recv.Robj(source=anysrc, tag=8, comm=comm) - src <- mpi.get.sourcetag()[1] - mpi.send(as.integer(i), type=1, dest=src, tag=88, comm=comm) - mpi.parSim.tmp[i] <- src - } - if (slaveinfo){ - slavename <- paste("slave",1:slave.num, sep="") - cat("Finished slave jobs summary:\n") - for (i in 1:slave.num){ - if (i < 10) - cat(slavename[i], " finished",sum(mpi.parSim==i), "job(s)\n") - else - cat(slavename[i], "finished",sum(mpi.parSim==i), "job(s)\n") - } - } - #assign(".mpi.parSim", mpi.parSim.tmp, envir = .GlobalEnv) - .simplify(slave.num*run, result, simplify, nsim) -} - -.mpi.worker.sim <- function(n, nsim, run){ - .comm <- 1 - tmpdata <- mpi.bcast.Robj(comm=.comm) - rand.arg <- tmpdata$rand.arg - stat.arg <- tmpdata$stat.arg - - .tmp.rand.gen <- tmpdata$rand.gen - .tmp.statistic <- tmpdata$stat - - #nnr <- mpi.bcast(integer(3), type=1, comm=.comm) - #n <- nnr[1]; nsim <- nnr[2]; run <- nnr[3] - - i <- 0 - slave.num <- mpi.comm.size(.comm)-1 - - while( i < slave.num*(run-1)+1){ - out <- replicate(nsim, do.call(".tmp.statistic", c(list(do.call(".tmp.rand.gen", - c(list(n),rand.arg))), stat.arg))) - - mpi.send.Robj(obj=out, dest=0, tag=8, comm=.comm) - i <- mpi.recv(integer(1), type=1, source=0, tag=88, comm=.comm) - } -} - -#from snow -.docall <- function(fun, args) { - if ((is.character(fun) && length(fun) == 1) || is.name(fun)) - fun <- get(as.character(fun), envir = .GlobalEnv, mode = "function") - enquote <- function(x) as.call(list(as.name("quote"), x)) - do.call("fun", lapply(args, enquote)) -} - -.splitIndices <- function(nx, ncl) { - #i <- 1:nx; - #structure(split(i, cut(i, ncl)), names=NULL) - x <- 1:nx - r <- nx/ncl - ii <- 0:(ncl - 1) * r - if (nx < ncl) - intv <- 0:ncl - else - intv <- c(x[round(1 + ii)]-1,nx) - structure(split(x, cut(x, intv)), names = NULL) -} - -mpi.parMM <- function(A, B, job.num=mpi.comm.size(comm)-1, comm=1){ - splitRows <- function(x, ncl) - lapply(.splitIndices(nrow(x), ncl), function(i) x[i,, drop=FALSE]) - .docall(rbind, mpi.applyLB(splitRows(A, job.num), - get("%*%"), B, comm=comm)) -} - -mpi.iparMM <- function(A, B, comm=1, sleep=0.01){ - splitRows <- function(x, ncl) - lapply(.splitIndices(nrow(x), ncl), function(i) x[i,, drop=FALSE]) - .docall(rbind, mpi.iapply(splitRows(A, mpi.comm.size(comm)-1), - get("%*%"), B, comm=comm, sleep=sleep)) -} - -mpi.applyLB <- function(X, FUN, ..., apply.seq=NULL, comm=1){ - apply.seq=NULL - n <- length(X) - slave.num <- mpi.comm.size(comm)-1 - if (slave.num < 1) - stop("There are no slaves running") - if (n <= slave.num) { - if (exists(".mpi.applyLB")) - rm(".mpi.applyLB", envir=.GlobalEnv) - return (mpi.apply(X,FUN,...,comm=comm)) - } - if (!is.function(FUN)) - stop("FUN is not a function") - length(list(...)) - if (!is.null(apply.seq)) - if (!is.integer(apply.seq)) - stop("apply.seq is not an integer vector") - else if (min(apply.seq)<1 && max(apply.seq)>slave.num && - length(apply.seq)!=n) - stop("apply.seq is not in right order") - - mpi.bcast.cmd(.mpi.worker.applyLB, n=n, comm=comm) - #mpi.bcast(as.integer(n),type=1,comm=comm) - mpi.bcast.Robj(list(FUN=FUN,dot.arg=list(...)),rank=0,comm=comm) - out <- as.list(integer(n)) - mpi.anysource <- mpi.any.source() - mpi.anytag <- mpi.any.tag() - for (i in 1:slave.num) - mpi.send.Robj(list(data.arg=list(X[[i]])), dest=i,tag=i, comm=comm) - - if (!is.null(apply.seq)){ - for ( i in 1:n){ - tmp <- mpi.recv.Robj(source=apply.seq[i], tag=mpi.anytag, comm=comm) - tag <- mpi.get.sourcetag()[2] - out[[tag]]<- tmp - j <- i+slave.num - if (j <= n) - mpi.send.Robj(list(data.arg=list(X[[j]])), dest=apply.seq[i],tag=j, comm=comm) - else - mpi.send.Robj(list(data.arg=list(n)),dest=apply.seq[i],tag=j,comm=comm) - } - return(out) - } - #.mpi.applyLB <<- integer(n) - mpi.seq.tmp <- integer(n) - for (i in 1:n){ - tmp<- mpi.recv.Robj(mpi.anysource,mpi.anytag,comm) - srctag <- mpi.get.sourcetag() - out[[srctag[2]]]<- tmp - mpi.seq.tmp[i] <- srctag[1] - j <- i+slave.num - if (j <= n) - mpi.send.Robj(list(data.arg=list(X[[j]])), dest=srctag[1],tag=j, comm=comm) - else - mpi.send.Robj(list(data.arg=list(n)),dest=srctag[1],tag=j,comm=comm) - } - #assign(".mpi.applyLB",mpi.seq.tmp, envir = .GlobalEnv) - out -} - -.mpi.worker.applyLB <- function(n){ - #assign(".mpi.err", FALSE, envir = .GlobalEnv) - .comm <- 1 - #n <- mpi.bcast(integer(1), type=1, comm=.comm) - tmpfunarg <- mpi.bcast.Robj(rank=0, comm=.comm) - .tmpfun <- tmpfunarg$FUN - dotarg <- tmpfunarg$dot.arg - mpi.anytag <- mpi.any.tag() - repeat { - tmpdata.arg <- mpi.recv.Robj(source=0,tag=mpi.anytag, comm=.comm)$data.arg - tag <- mpi.get.sourcetag()[2] - if (tag > n) - break - out <- try(do.call(".tmpfun", c(tmpdata.arg, dotarg)),TRUE) - #if (.mpi.err) - # print(geterrmessage()) - mpi.send.Robj(out,0,tag,.comm) - } -} - -mpi.iapplyLB <- function(X, FUN, ..., apply.seq=NULL, comm=1, sleep=0.01){ - apply.seq=NULL - n <- length(X) - slave.num <- mpi.comm.size(comm)-1 - if (slave.num < 1) - stop("There are no slaves running") - if (n <= slave.num) { - if (exists(".mpi.applyLB")) - rm(".mpi.applyLB", envir =.GlobalEnv) - return (mpi.iapply(X,FUN,...,comm=comm,sleep=sleep)) - } - if (!is.function(FUN)) - stop("FUN is not a function") - if (slave.num > 2000) - stop("Total slaves are more than nonblock send/receive can handle") - length(list(...)) - if (!is.null(apply.seq)) - if (!is.integer(apply.seq)) - stop("apply.seq is not an integer vector") - else if (min(apply.seq)<1 && max(apply.seq)>slave.num && - length(apply.seq)!=n) - stop("apply.seq is not in right order") - - mpi.bcast.cmd(.mpi.worker.applyLB, n=n, comm=comm) - #mpi.bcast(as.integer(n),type=1,comm=comm) - mpi.bcast.Robj(list(FUN=FUN,dot.arg=list(...)),rank=0,comm=comm) - out <- as.list(integer(n)) - mpi.anysource <- mpi.any.source() - mpi.anytag <- mpi.any.tag() - for (i in 1:slave.num) - mpi.send.Robj(list(data.arg=list(X[[i]])), dest=i,tag=i,comm=comm) - #for (i in 1:slave.num) - # mpi.waitany(slave.num) - - if (!is.null(apply.seq)){ - i=0 - repeat { - if (mpi.iprobe(apply.seq[i+1],mpi.anytag,comm)){ - i=i+1 - j <- i+slave.num - if ( j <= n) - mpi.send.Robj(list(data.arg=list(X[[j]])), dest=apply.seq[i],tag=j, comm=comm) - else - mpi.send.Robj(as.integer(0),dest=apply.seq[i],tag=j,comm=comm) - charlen <- mpi.get.count(type=4) - tag <- mpi.get.sourcetag()[2] - tmp <- unserialize(mpi.recv(x = raw(charlen), type = 4, apply.seq[i], tag, comm)) - out[[tag]]<- tmp - #mpi.wait(0) - } - if (i < n) - Sys.sleep(sleep) - else break - } - return(out) - } - mpi.seq.tmp <- integer(n) - i=0 - repeat { - if (mpi.iprobe(mpi.anysource,mpi.anytag,comm)){ - i=i+1 - srctag <- mpi.get.sourcetag() - src <- srctag[1] - tag <- srctag[2] - j <- i+slave.num - if ( j <= n) - mpi.send.Robj(list(data.arg=list(X[[j]])), dest=src,tag=j, comm=comm) - else - mpi.send.Robj(as.integer(0),dest=src,tag=j,comm=comm) - charlen <- mpi.get.count(type=4) - tmp <- unserialize(mpi.recv(x = raw(charlen), type = 4, src, tag, comm)) - out[[tag]]<- tmp - mpi.seq.tmp[i] <- src - #mpi.wait(src-1) - } - if (i < n) - Sys.sleep(sleep) - else - break - } - #assign(".mpi.applyLB",mpi.seq.tmp, envir = .GlobalEnv) - gc() - out -} - -#.mpi.worker.iapplyLB <- function(){ -# assign(".mpi.err", FALSE, envir = .GlobalEnv) -# n <- mpi.bcast(integer(1), type=1, comm=.comm) -# tmpfunarg <- mpi.bcast.Robj(rank=0, comm=.comm) -# .tmpfun <- tmpfunarg$fun -# dotarg <- tmpfunarg$dot.arg -# mpi.anytag <- mpi.any.tag() -# repeat { -# tmpdata.arg <- mpi.recv.Robj(source=0,tag=mpi.anytag, comm=.comm)$data.arg -# tag <- mpi.get.sourcetag()[2] -# if (tag > n) -# break -# out <- try(do.call(".tmpfun", c(tmpdata.arg, dotarg)),TRUE) -# #if (.mpi.err) -# # print(geterrmessage()) -# mpi.wait(0) -# mpi.isend.Robj(out,0,tag,.comm) -# } -# mpi.wait(0) -#} - -.simplify <- function(n, answer, simplify, len=1, recursive=FALSE){ - if (simplify && length(answer)&&length(common.len <- unique(unlist(lapply(answer, - length)))) == 1 ) { - if (common.len == len) - unlist(answer, recursive = recursive) - else if (common.len > len) - array(unlist(answer, recursive = recursive), - dim = c(common.len/len, n*len), - dimnames = list(names(answer[[1]]), names(answer))) - else answer - } - else answer -} - -mpi.parLapply <- function(X, FUN, ..., job.num=mpi.comm.size(comm)-1, apply.seq=NULL, comm=1){ - if (job.num < 2) - stop("job.num is at least 2.") - splitList <- function(x, ncl) - lapply(.splitIndices(length(X), ncl), function(i) X[i]) - .docall(c, mpi.applyLB(splitList(X, job.num), - lapply, FUN, ..., apply.seq=apply.seq, comm=comm)) -} - -mpi.iparLapply <- function(X, FUN, ..., job.num=mpi.comm.size(comm)-1, apply.seq=NULL, comm=1, sleep=0.01){ - if (job.num < 2) - stop("job.num is at least 2.") - splitList <- function(X, ncl) - lapply(.splitIndices(length(X), ncl), function(i) X[i]) - .docall(c, mpi.iapplyLB(splitList(X, job.num), - lapply, FUN, ..., apply.seq=apply.seq, comm=comm, sleep=sleep)) -} - -mpi.parSapply <- function (X, FUN, ..., job.num=mpi.comm.size(comm)-1, apply.seq=NULL, - simplify = TRUE, USE.NAMES = TRUE, comm=1) -{ - FUN <- match.fun(FUN) - answer <- mpi.parLapply(as.list(X),FUN,...,job.num=job.num,apply.seq=apply.seq,comm=comm) - if (USE.NAMES && is.character(X) && is.null(names(answer))) - names(answer) <- X - .simplify(length(X),answer, simplify) -} - -mpi.iparSapply <- function (X, FUN, ..., job.num=mpi.comm.size(comm)-1, apply.seq=NULL, - simplify = TRUE, USE.NAMES = TRUE, comm=1,sleep=0.01) -{ - FUN <- match.fun(FUN) - answer <- mpi.iparLapply(as.list(X),FUN,...,job.num=job.num,apply.seq=apply.seq,comm=comm,sleep=sleep) - if (USE.NAMES && is.character(X) && is.null(names(answer))) - names(answer) <- X - .simplify(length(X),answer, simplify) -} - -mpi.parReplicate <- function(n, expr, job.num=mpi.comm.size(comm)-1, apply.seq=NULL, - simplify = TRUE, comm=1){ - mpi.parSapply(integer(n), eval.parent(substitute(function(...) expr)), - job.num=job.num, apply.seq=apply.seq, simplify = simplify, comm=comm) -} - -mpi.iparReplicate <- function(n, expr, job.num=mpi.comm.size(comm)-1, apply.seq=NULL, - simplify = TRUE, comm=1,sleep=0.01){ - mpi.iparSapply(integer(n), eval.parent(substitute(function(...) expr)), - job.num=job.num, apply.seq=apply.seq, simplify = simplify, comm=comm,sleep=sleep) -} - -mpi.parRapply <- function(X,FUN,...,job.num=mpi.comm.size(comm)-1,apply.seq=NULL,comm=1){ - if (job.num < 2) - stop("job.num is at least 2.") - splitRows <- function(X, ncl) - lapply(.splitIndices(nrow(X), ncl), function(i) X[i,, drop=FALSE]) - .docall(c, mpi.applyLB(splitRows(X,job.num), apply, 1, FUN, ..., - apply.seq=apply.seq, comm=comm)) -} - -mpi.iparRapply <- function(X,FUN,...,job.num=mpi.comm.size(comm)-1,apply.seq=NULL,comm=1,sleep=0.01){ - if (job.num < 2) - stop("job.num is at least 2.") - splitRows <- function(X, ncl) - lapply(.splitIndices(nrow(X), ncl), function(i) X[i,, drop=FALSE]) - .docall(c, mpi.iapplyLB(splitRows(X,job.num), apply, 1, FUN, ..., - apply.seq=apply.seq, comm=comm,sleep=sleep)) -} - -mpi.parCapply <- function(X,FUN,...,job.num=mpi.comm.size(comm)-1,apply.seq=NULL,comm=1){ - if (job.num < 2) - stop("job.num is at least 2.") - splitCols <- function(X, ncl) - lapply(.splitIndices(ncol(X), ncl), function(i) X[,i, drop=FALSE]) - .docall(c, mpi.applyLB(splitCols(X,job.num), apply, 2, FUN, ..., - apply.seq=apply.seq, comm=comm)) -} - -mpi.iparCapply <- function(X,FUN,...,job.num=mpi.comm.size(comm)-1,apply.seq=NULL,comm=1,sleep=0.01){ - if (job.num < 2) - stop("job.num is at least 2.") - splitCols <- function(X, ncl) - lapply(.splitIndices(ncol(X), ncl), function(i) X[,i, drop=FALSE]) - .docall(c, mpi.iapplyLB(splitCols(X,job.num), apply, 2, FUN, ..., - apply.seq=apply.seq, comm=comm,sleep=sleep)) -} - -mpi.parApply <- function(X, MARGIN, FUN, ..., job.num = mpi.comm.size(comm)-1, - apply.seq=NULL, comm=1) -{ - FUN <- match.fun(FUN) - d <- dim(X) - dl <- length(d) - if(dl == 0) - stop("dim(X) must have a positive length") - ds <- 1:dl - - if(length(oldClass(X)) > 0) - X <- if(dl == 2) as.matrix(X) else as.array(X) - dn <- dimnames(X) - - s.call <- ds[-MARGIN] - s.ans <- ds[MARGIN] - d.call <- d[-MARGIN] - d.ans <- d[MARGIN] - dn.call<- dn[-MARGIN] - dn.ans <- dn[MARGIN] - - d2 <- prod(d.ans) - if(d2 == 0) { - newX <- array(vector(typeof(X), 1), dim = c(prod(d.call), 1)) - ans <- FUN(if(length(d.call) < 2) newX[,1] else - array(newX[,1], d.call, dn.call), ...) - return(if(is.null(ans)) ans else if(length(d.call) < 2) ans[1][-1] - else array(ans, d.ans, dn.ans)) - } - newX <- aperm(X, c(s.call, s.ans)) - dim(newX) <- c(prod(d.call), d2) - if(length(d.call) < 2) { - if (length(dn.call)) dimnames(newX) <- c(dn.call, list(NULL)) - ans <- mpi.parLapply(1:d2, function(i, ...) FUN(newX[,i], ...), - ..., job.num = job.num, apply.seq=apply.seq, comm=comm ) - } - else - ans <- mpi.parLapply(1:d2, - function(i, ...) FUN(array(newX[,i], d.call, dn.call), ...), - ..., job.num = job.num, apply.seq=apply.seq, comm=comm) - - ans.list <- is.recursive(ans[[1]]) - l.ans <- length(ans[[1]]) - - ans.names <- names(ans[[1]]) - if(!ans.list) - ans.list <- any(unlist(lapply(ans, length)) != l.ans) - if(!ans.list && length(ans.names)) { - all.same <- sapply(ans, function(X) identical(names(X), ans.names)) - if (!all(all.same)) ans.names <- NULL - } - len.a <- if(ans.list) d2 else length(ans <- unlist(ans, recursive = FALSE)) - if(length(MARGIN) == 1 && len.a == d2) { - names(ans) <- if(length(dn.ans[[1]])) dn.ans[[1]] - return(ans) - } - if(len.a == d2) - return(array(ans, d.ans, dn.ans)) - if(len.a > 0 && len.a %% d2 == 0) - return(array(ans, c(len.a %/% d2, d.ans), - if(is.null(dn.ans)) { - if(!is.null(ans.names)) list(ans.names,NULL) - } else c(list(ans.names), dn.ans))) - return(ans) -} - -mpi.iparApply <- function(X, MARGIN, FUN, ..., job.num = mpi.comm.size(comm)-1, - apply.seq=NULL, comm=1,sleep=0.01) -{ - FUN <- match.fun(FUN) - d <- dim(X) - dl <- length(d) - if(dl == 0) - stop("dim(X) must have a positive length") - ds <- 1:dl - - if(length(oldClass(X)) > 0) - X <- if(dl == 2) as.matrix(X) else as.array(X) - dn <- dimnames(X) - - s.call <- ds[-MARGIN] - s.ans <- ds[MARGIN] - d.call <- d[-MARGIN] - d.ans <- d[MARGIN] - dn.call<- dn[-MARGIN] - dn.ans <- dn[MARGIN] - - d2 <- prod(d.ans) - if(d2 == 0) { - newX <- array(vector(typeof(X), 1), dim = c(prod(d.call), 1)) - ans <- FUN(if(length(d.call) < 2) newX[,1] else - array(newX[,1], d.call, dn.call), ...) - return(if(is.null(ans)) ans else if(length(d.call) < 2) ans[1][-1] - else array(ans, d.ans, dn.ans)) - } - newX <- aperm(X, c(s.call, s.ans)) - dim(newX) <- c(prod(d.call), d2) - if(length(d.call) < 2) { - if (length(dn.call)) dimnames(newX) <- c(dn.call, list(NULL)) - ans <- mpi.iparLapply(1:d2, function(i, ...) FUN(newX[,i], ...), - ..., job.num = job.num, apply.seq=apply.seq, comm=comm, sleep=sleep ) - } - else - ans <- mpi.iparLapply(1:d2, - function(i, ...) FUN(array(newX[,i], d.call, dn.call), ...), - ..., job.num = job.num, apply.seq=apply.seq, comm=comm, sleep=sleep) - - ans.list <- is.recursive(ans[[1]]) - l.ans <- length(ans[[1]]) - - ans.names <- names(ans[[1]]) - if(!ans.list) - ans.list <- any(unlist(lapply(ans, length)) != l.ans) - if(!ans.list && length(ans.names)) { - all.same <- sapply(ans, function(X) identical(names(X), ans.names)) - if (!all(all.same)) ans.names <- NULL - } - len.a <- if(ans.list) d2 else length(ans <- unlist(ans, recursive = FALSE)) - if(length(MARGIN) == 1 && len.a == d2) { - names(ans) <- if(length(dn.ans[[1]])) dn.ans[[1]] - return(ans) - } - if(len.a == d2) - return(array(ans, d.ans, dn.ans)) - if(len.a > 0 && len.a %% d2 == 0) - return(array(ans, c(len.a %/% d2, d.ans), - if(is.null(dn.ans)) { - if(!is.null(ans.names)) list(ans.names,NULL) - } else c(list(ans.names), dn.ans))) - return(ans) -} - -#mpi.parallel.sim <- mpi.parSim +### Copyright (C) 2002 Hao Yu + +mpi.hostinfo <- function(comm=1){ + if (mpi.comm.size(comm)==0){ + err <-paste("It seems no members running on comm", comm) + stop(err) + } + hostname <- mpi.get.processor.name() + rk <- mpi.comm.rank(comm=comm) + size <- mpi.comm.size(comm=comm) + cat("\tHost:",hostname,"\tRank(ID):",rk, "\tof Size:", size, + "on comm", comm, "\n") +} + +slave.hostinfo <- function(comm=1, short=TRUE){ + #if (!mpi.is.master()) + if (mpi.comm.rank(comm)!=0) + stop("cannot run slavehostinfo on slaves") + size <- mpi.comm.size(comm) + if (size==0){ + err <-paste("It seems no slaves running on comm", comm) + stop(err) + } + if (size == 1) + mpi.hostinfo(comm) + else { + master <-mpi.get.processor.name() + slavehost <- unlist(mpi.remote.exec(mpi.get.processor.name(),comm=comm)) + slavecomm <- 1 #as.integer(mpi.remote.exec(.comm,comm=comm)) + ranks <- 1:(size-1) + commm <- paste(comm, ")",sep="") + if (size > 10){ + rank0 <- paste("master (rank 0 , comm", commm) + ranks <- c(paste(ranks[1:9]," ",sep=""), ranks[10:(size-1)]) + } + else + rank0 <- paste("master (rank 0, comm", commm) + cat(rank0, "of size", size, "is running on:",master, "\n") + slavename <- paste("slave", ranks,sep="") + ranks <- paste("(rank ",ranks, ", comm ",slavecomm,")", sep="") + if (short && size > 8){ + for (i in 1:3) { + cat(slavename[i], ranks[i], "of size",size, + "is running on:",slavehost[i], "\n") + } + cat("... ... ...\n") + for (i in (size-2):(size-1)){ + cat(slavename[i], ranks[i], "of size",size, + "is running on:",slavehost[i], "\n") + } + } + else { + for (i in 1:(size-1)){ + cat(slavename[i], ranks[i], "of size",size, + "is running on:",slavehost[i], "\n") + } + } + } +} + +lamhosts <- function(){ + hosts <- system("lamnodes C -c -n", TRUE) + base <-character(0) + for (host in hosts) + base <- c(base, unlist(strsplit(host, "\\."))[1]) + nn <- 0:(length(hosts)-1) + names(nn) <- base + nn +} + +mpi.spawn.Rslaves <- + function(Rscript=system.file("slavedaemon.R", package="Rmpi"), + nslaves=mpi.universe.size(), + root=0, + intercomm=2, + comm=1, + hosts=NULL, + needlog=TRUE, + mapdrive=TRUE, + quiet=FALSE, + nonblock=TRUE, + sleep=0.1) { + if (!is.loaded("mpi_comm_spawn")) + stop("You cannot use MPI_Comm_spawn API") + if (mpi.comm.size(comm) > 0){ + err <-paste("It seems there are some slaves running on comm ", comm) + stop(err) + } + if (.Platform$OS=="windows"){ + #stop("Spawning is not implemented. Please use mpiexec with Rprofile.") + workdrive <- unlist(strsplit(getwd(),":"))[1] + workdir <- unlist(strsplit(getwd(),"/")) + if (length(workdir) > 1) + workdir <-paste(workdir, collapse="\\") + else + workdir <- paste(workdir,"\\") + localhost <- Sys.getenv("COMPUTERNAME") + networkdrive <-NULL #.Call("RegQuery", as.integer(2),paste("NETWORK\\",workdrive,sep=""), + #PACKAGE="Rmpi") + remotepath <-networkdrive[which(networkdrive=="RemotePath")+1] + mapdrive <- as.logical(mapdrive && !is.null(remotepath)) + arg <- c(Rscript, R.home(), workdrive, workdir, localhost, mapdrive, remotepath) + if (.Platform$r_arch == "i386") + realns <- mpi.comm.spawn(slave = system.file("Rslaves32.cmd", + package = "Rmpi"), slavearg = arg, nslaves = nslaves, + info = 0, root = root, intercomm = intercomm, quiet = quiet) + else + realns <- mpi.comm.spawn(slave = system.file("Rslaves64.cmd", + package = "Rmpi"), slavearg = arg, nslaves = nslaves, + info = 0, root = root, intercomm = intercomm, quiet = quiet) + } + else{ + tmp <- paste(Sys.getpid(), "+", comm, sep="") + if (needlog) + arg <- c(Rscript, tmp, "needlog", R.home()) + else + arg <- c(Rscript, tmp , "nolog", R.home()) + if (!is.null(hosts)){ + hosts <- as.integer(hosts) + if (any(is.na(hosts))) + stop("hosts argument contains non-integer object(s).") + if (max(hosts) > mpi.universe.size() -1 ||min(hosts) < 0){ + tmp1 <- paste("hosts number should be within 0 to", + mpi.universe.size()-1) + stop(tmp1) + } + nslaves <- length(hosts) + tmpfile <-paste(tmp, "appschema", sep="") + fileobj <- file(tmpfile,"w") + cat("c", paste(hosts, collapse=","), sep="", file=fileobj) + cat(" ", system.file("Rslaves.sh", package="Rmpi"), file=fileobj) + cat(" ", paste(arg, collapse=" "), file=fileobj) + close(fileobj) + mpi.info.create(0) + mpi.info.set(0,"file",tmpfile) + } + if (length(unlist(strsplit(.Platform$pkgType,"mac"))) ==2 && .Platform$r_arch =="x86_64") + realns<-mpi.comm.spawn(slave=system.file("MacR64slaves.sh", package="Rmpi"), + slavearg=arg, nslaves=nslaves, info=0, root=root, intercomm=intercomm, quiet = quiet) + else + realns<-mpi.comm.spawn(slave=system.file("Rslaves.sh", package="Rmpi"), + slavearg=arg, nslaves=nslaves, info=0, root=root, intercomm=intercomm, quiet = quiet) + } + if (!is.null(hosts)){ + unlink(tmpfile) + mpi.info.free(0) + } + if (realns==0) + stop("It seems no single slave spawned.") + if (mpi.intercomm.merge(intercomm,0,comm)) { + mpi.comm.set.errhandler(comm) + mpi.comm.disconnect(intercomm) + mpi.bcast(nonblock,type=1, rank=0, comm=comm) + mpi.bcast(sleep,type=2, rank=0, comm=comm) + if (!quiet) slave.hostinfo(comm) + } + else + stop("Fail to merge the comm for master and slaves.") +} + +mpi.remote.exec <- function(cmd, ..., simplify=TRUE, comm=1, ret=TRUE){ + if (mpi.comm.size(comm) < 2) + stop("It seems no slaves running.") + tag <- floor(runif(1,20000,30000)) + scmd <- substitute(cmd) + arg <-list(...) + #if (length(arg) > 0) + # deparse(arg) + #tag.ret <- c(tag, ret, simplify) + mpi.bcast.cmd(.mpi.worker.exec, tag=tag, ret=ret, simplify=simplify, comm = comm) + #mpi.bcast(as.integer(tag.ret), type=1, comm=comm) + mpi.bcast.Robj(list(scmd=scmd, arg=arg), comm=comm) + + if (ret){ + size <- mpi.comm.size(comm) + allcode <- mpi.allgather(integer(2), 1, integer(2*size), comm) + type <- allcode[seq(3,2*size,2)] + len <- allcode[seq(4,2*size,2)] + eqlen <- all(len==len[1]) + if (all(type==1)){ + if (eqlen && simplify){ + out <- mpi.gather(integer(len[1]),1,integer(size*len[1]),0,comm) + out <- out[(len[1]+1):(size*len[1])] + dim(out) <- c(len[1], size-1) + out <- data.frame(out) + } + else { + out1<-mpi.gatherv(integer(1),1,integer(1+sum(len)),c(1,len),0,comm) + uplen <- cumsum(len)+1 + lowlen <-c(2, uplen[-(size-1)]+1) + out <- as.list(integer(size-1)) + names(out) <- paste("slave",1:(size-1), sep="") + for (i in 1:(size-1)) + out[[i]]<- out1[lowlen[i]:uplen[i]] + } + } + else if (all(type==2)){ + if (eqlen && simplify){ + out <- mpi.gather(double(len[1]),2,double(size*len[1]),0,comm) + out <- out[(len[1]+1):(size*len[1])] + dim(out) <- c(len[1], size-1) + out <- data.frame(out) + } + else { + out1<-mpi.gatherv(double(1),2,double(1+sum(len)),c(1,len),0,comm) + uplen <- cumsum(len)+1 + lowlen <-c(2, uplen[-(size-1)]+1) + out <- as.list(integer(size-1)) + names(out) <- paste("slave",1:(size-1), sep="") + for (i in 1:(size-1)) + out[[i]]<- out1[lowlen[i]:uplen[i]] + } + } + else if (all(type==4)){ + if (eqlen && simplify){ + out <- mpi.gather(raw(len[1]),4,raw(size*len[1]),0,comm) + out <- out[(len[1]+1):(size*len[1])] + dim(out) <- c(len[1], size-1) + out <- data.frame(out) + } + else { + out1<-mpi.gatherv(raw(1),4,raw(1+sum(len)),c(1,len),0,comm) + uplen <- cumsum(len)+1 + lowlen <-c(2, uplen[-(size-1)]+1) + out <- as.list(integer(size-1)) + names(out) <- paste("slave",1:(size-1), sep="") + for (i in 1:(size-1)) + out[[i]]<- out1[lowlen[i]:uplen[i]] + } + } + + else { + out <- as.list(integer(size-1)) + names(out) <- paste("slave",1:(size-1), sep="") + for (i in 1:(size-1)){ + tmp<- mpi.recv.Robj(mpi.any.source(),tag,comm) + src <- mpi.get.sourcetag()[1] + out[[src]]<- tmp + } + } + out + } +} + +.typeindex <- function (x) { + if(is.integer(x)) + as.integer(c(1,length(x))) + else if (is.numeric(x)) + as.integer(c(2,length(x))) + else if (is.raw(x)) + as.integer(c(4,length(x))) + + else + as.integer(-1) +} + +.mpi.worker.exec <- function(tag, ret, simplify){ + #assign(".mpi.err", FALSE, envir = .GlobalEnv) + assign(".mpi.err", FALSE) + .comm <- 1 + #tag.ret <- mpi.bcast(integer(3), type=1, comm=.comm) + #tag <- tag.ret[1] + #ret <- as.logical(tag.ret[2]) + #simplify <- as.logical(tag.ret[3]) + scmd.arg <- mpi.bcast.Robj(comm=.comm) + + if (ret){ + size <- mpi.comm.size(.comm) + myerrcode <- as.integer(0) + if (length(scmd.arg$arg)>0) + out <- try(do.call(as.character(scmd.arg$scmd), scmd.arg$arg, envir=.GlobalEnv),TRUE) + else + out <- try(eval(scmd.arg$scmd, envir=sys.parent()), TRUE) + + if (get(".mpi.err")){ + print(geterrmessage()) + type <- integer(2) + } + else { + type <- .typeindex(out) + if (is.na(type[2])) + type[2] <- as.integer(0) + } + allcode <- mpi.allgather(type, 1, integer(2*size), .comm) + type <- allcode[seq(3,2*size,2)] + len <- allcode[seq(4,2*size,2)] + eqlen <- all(len==len[1]) + if (all(type==1)) { + if (eqlen && simplify) + mpi.gather(out, 1, integer(1), 0, .comm) + else + mpi.gatherv(out, 1, integer(1), integer(1), 0 ,.comm) + } + else if (all(type==2)) { + if (eqlen && simplify) + mpi.gather(out, 2, double(1), 0, .comm) + else + mpi.gatherv(out, 2, double(1), integer(1), 0, .comm) + } + else if (all(type==4)) { + if (eqlen && simplify) + mpi.gather(out, 4, raw(1), 0, .comm) + else + mpi.gatherv(out, 4, raw(1), integer(1), 0, .comm) + } + + else { + mpi.send.Robj(out,0,tag,.comm) + } + } + else { + if (length(scmd.arg$arg)>0) + out <- try(do.call(as.character(scmd.arg$scmd), scmd.arg$arg)) + else + out <- try(eval(scmd.arg$scmd)) + } +} + +mpi.close.Rslaves <- function(dellog=TRUE, comm=1){ + if (mpi.comm.size(comm) < 2){ + err <-paste("It seems no slaves running on comm", comm) + stop(err) + } + #mpi.break=delay(do.call("break", list(), envir=.GlobalEnv)) + mpi.bcast.cmd(cmd="kaerb", rank=0, comm=comm) + if (.Platform$OS!="windows"){ + if (dellog && mpi.comm.size(0) < mpi.comm.size(comm)){ + tmp <- paste(Sys.getpid(),"+",comm,sep="") + logfile <- paste("*.",tmp,".*.log", sep="") + if (length(system(paste("ls", logfile),TRUE,ignore.stderr=TRUE) )>=1) + system(paste("rm", logfile)) + } + } +# mpi.barrier(comm) + if (comm >0){ + #if (is.loaded("mpi_comm_disconnect")) + #mpi.comm.disconnect(comm) + #else + mpi.comm.free(comm) + } +# mpi.comm.set.errhandler(0) +} + +tailslave.log <- function(nlines=3,comm=1){ + if (mpi.comm.size(comm)==0) + stop ("It seems no slaves running") + tmp <- paste(Sys.getpid(),"+",comm,sep="") + logfile <- paste("*.",tmp,".*.log", sep="") + if (length(system(paste("ls", logfile),TRUE,ignore.stderr=TRUE))==0) + stop("It seems no slave log files.") + system(paste("tail -",nlines," ", logfile,sep="")) +} + +mpi.apply <- function(X, FUN, ..., comm=1){ + n <- length(X) + nslaves <- mpi.comm.size(comm)-1 + if (nslaves < n) + stop("data length must be at most total slave size") + if (!is.function(FUN)) + stop("FUN is not a function") + length(list(...)) #test for any non existing R objects + tag <- floor(runif(1,1,1000)) + mpi.bcast.cmd(.mpi.worker.apply, n=n, tag=tag, comm=comm) + #mpi.bcast(as.integer(c(tag,n)),type=1,comm=comm) + mpi.bcast.Robj(list(FUN=FUN,dot.arg=list(...)),rank=0,comm=comm) + if (n < nslaves) + X=c(X,as.list(integer( nslaves-n))) + mpi.scatter.Robj(c(list("master"),as.list(X)),root=0,comm=comm) + + out <- as.list(integer(n)) + for (i in 1:n){ + tmp<- mpi.recv.Robj(mpi.any.source(),tag,comm) + src <- mpi.get.sourcetag()[1] + out[[src]]<- tmp + } + out +} + +.mpi.worker.apply <- function(n, tag){ + #assign(".mpi.err", FALSE, envir = .GlobalEnv) + .comm <- 1 + #tag.n <- mpi.bcast(integer(2), type=1, comm=.comm) + #tag <- tag.n[1] + #n <- tag.n[2] + tmpfunarg <- mpi.bcast.Robj(rank=0, comm=.comm) + .tmpfun <- tmpfunarg$FUN + dotarg <- tmpfunarg$dot.arg + tmpdata.arg <- list(mpi.scatter.Robj(root=0,comm=.comm)) + if (mpi.comm.rank(.comm) <= n){ + out <- try(do.call(".tmpfun", c(tmpdata.arg, dotarg)),TRUE) + mpi.send.Robj(out,0,tag,.comm) + } +} + +mpi.iapply <- function(X, FUN, ..., comm=1, sleep=0.01){ + n <- length(X) + nslaves <- mpi.comm.size(comm)-1 + if (nslaves < n) + stop("data length must be at most total slave size") + if (!is.function(FUN)) + stop("FUN is not a function") + length(list(...)) #test for any non existing R objects + tag <- floor(runif(1,1,1000)) + mpi.bcast.cmd(.mpi.worker.apply, n=n, tag=tag,comm=comm) + #mpi.bcast(as.integer(c(tag,n)),type=1,comm=comm) + mpi.bcast.Robj(list(FUN=FUN,dot.arg=list(...)),rank=0,comm=comm) + if (n < nslaves) + X=c(X,as.list(integer( nslaves-n))) + mpi.scatter.Robj(c(list("master"),as.list(X)),root=0,comm=comm) + + out <- as.list(integer(n)) + done=0 + anysource=mpi.any.source() + repeat { + if (mpi.iprobe(anysource,tag,comm)){ + srctag <- mpi.get.sourcetag() + charlen <- mpi.get.count(type=4) + tmp <- unserialize(mpi.recv(x = raw(charlen), type = 4, srctag[1], + srctag[2], comm)) + out[[srctag[1]]]<- tmp + done=done+1 + } + if (done < n) + Sys.sleep(sleep) + else break + } + gc() + out +} + +mpi.parSim <- function(n=100,rand.gen=rnorm, rand.arg=NULL, + statistic, nsim=100, run=1, slaveinfo=FALSE, sim.seq=NULL, + simplify=TRUE, comm=1, ...){ + sim.seq=NULL + if (mpi.comm.size(comm) < 2) + stop("It seems no slaves running.") + if (!is.function(rand.gen)) + stop("rand.gen is not a function") + if (!is.function(statistic)) + stop("statistic is not a function") + if (!is.null(rand.arg)) + if (!is.list(rand.arg)) + stop("rand.arg is not a list") + if (length(list(...))>0) + deparse(list(...)) + + slave.num <- mpi.comm.size(comm)-1 + if (!is.null(sim.seq)) + if (!is.integer(sim.seq)) + stop("sim.seq is not an integer vector") + else if (min(sim.seq)<1 && max(sim.seq)>slave.num && + length(sim.seq)!=slave.num*run) + stop("sim.seq is not in right order") + + mpi.bcast.cmd(.mpi.worker.sim, n=n, nsim=nsim, run=run, comm=comm) + mpi.bcast.Robj(list(rand.gen=rand.gen, rand.arg=rand.arg, + stat=statistic, stat.arg=list(...)), comm=comm) + + #nnr <- c(n,nsim,run) + #mpi.bcast(as.integer(nnr),type=1, comm=comm) + result <- as.list(integer(slave.num*run)) + + if (!is.null(sim.seq)){ + for ( i in 1:(slave.num*run)){ + result[[i]] <- mpi.recv.Robj(source=sim.seq[i], tag=8, comm=comm) + mpi.send(as.integer(i), type=1, dest=sim.seq[i], tag=88, comm=comm) + } + return(.simplify(slave.num*run, result, simplify, nsim)) + } + + i <- 0 + anysrc <- mpi.any.source() + anytag <- mpi.any.tag() + mpi.parSim.tmp <- integer(slave.num*run) + while (i < slave.num*run){ + i <- i+1 + result[[i]] <- mpi.recv.Robj(source=anysrc, tag=8, comm=comm) + src <- mpi.get.sourcetag()[1] + mpi.send(as.integer(i), type=1, dest=src, tag=88, comm=comm) + mpi.parSim.tmp[i] <- src + } + if (slaveinfo){ + slavename <- paste("slave",1:slave.num, sep="") + cat("Finished slave jobs summary:\n") + for (i in 1:slave.num){ + if (i < 10) + cat(slavename[i], " finished",sum(mpi.parSim==i), "job(s)\n") + else + cat(slavename[i], "finished",sum(mpi.parSim==i), "job(s)\n") + } + } + #assign(".mpi.parSim", mpi.parSim.tmp, envir = .GlobalEnv) + .simplify(slave.num*run, result, simplify, nsim) +} + +.mpi.worker.sim <- function(n, nsim, run){ + .comm <- 1 + tmpdata <- mpi.bcast.Robj(comm=.comm) + rand.arg <- tmpdata$rand.arg + stat.arg <- tmpdata$stat.arg + + .tmp.rand.gen <- tmpdata$rand.gen + .tmp.statistic <- tmpdata$stat + + #nnr <- mpi.bcast(integer(3), type=1, comm=.comm) + #n <- nnr[1]; nsim <- nnr[2]; run <- nnr[3] + + i <- 0 + slave.num <- mpi.comm.size(.comm)-1 + + while( i < slave.num*(run-1)+1){ + out <- replicate(nsim, do.call(".tmp.statistic", c(list(do.call(".tmp.rand.gen", + c(list(n),rand.arg))), stat.arg))) + + mpi.send.Robj(obj=out, dest=0, tag=8, comm=.comm) + i <- mpi.recv(integer(1), type=1, source=0, tag=88, comm=.comm) + } +} + +#from snow +.docall <- function(fun, args) { + if ((is.character(fun) && length(fun) == 1) || is.name(fun)) + fun <- get(as.character(fun), envir = .GlobalEnv, mode = "function") + enquote <- function(x) as.call(list(as.name("quote"), x)) + do.call("fun", lapply(args, enquote)) +} + +.splitIndices <- function(nx, ncl) { + #i <- 1:nx; + #structure(split(i, cut(i, ncl)), names=NULL) + x <- 1:nx + r <- nx/ncl + ii <- 0:(ncl - 1) * r + if (nx < ncl) + intv <- 0:ncl + else + intv <- c(x[round(1 + ii)]-1,nx) + structure(split(x, cut(x, intv)), names = NULL) +} + +mpi.parMM <- function(A, B, job.num=mpi.comm.size(comm)-1, comm=1){ + splitRows <- function(x, ncl) + lapply(.splitIndices(nrow(x), ncl), function(i) x[i,, drop=FALSE]) + .docall(rbind, mpi.applyLB(splitRows(A, job.num), + get("%*%"), B, comm=comm)) +} + +mpi.iparMM <- function(A, B, comm=1, sleep=0.01){ + splitRows <- function(x, ncl) + lapply(.splitIndices(nrow(x), ncl), function(i) x[i,, drop=FALSE]) + .docall(rbind, mpi.iapply(splitRows(A, mpi.comm.size(comm)-1), + get("%*%"), B, comm=comm, sleep=sleep)) +} + +mpi.applyLB <- function(X, FUN, ..., apply.seq=NULL, comm=1){ + apply.seq=NULL + n <- length(X) + slave.num <- mpi.comm.size(comm)-1 + if (slave.num < 1) + stop("There are no slaves running") + if (n <= slave.num) { + if (exists(".mpi.applyLB")) + rm(".mpi.applyLB", envir=.GlobalEnv) + return (mpi.apply(X,FUN,...,comm=comm)) + } + if (!is.function(FUN)) + stop("FUN is not a function") + length(list(...)) + if (!is.null(apply.seq)) + if (!is.integer(apply.seq)) + stop("apply.seq is not an integer vector") + else if (min(apply.seq)<1 && max(apply.seq)>slave.num && + length(apply.seq)!=n) + stop("apply.seq is not in right order") + + mpi.bcast.cmd(.mpi.worker.applyLB, n=n, comm=comm) + #mpi.bcast(as.integer(n),type=1,comm=comm) + mpi.bcast.Robj(list(FUN=FUN,dot.arg=list(...)),rank=0,comm=comm) + out <- as.list(integer(n)) + mpi.anysource <- mpi.any.source() + mpi.anytag <- mpi.any.tag() + for (i in 1:slave.num) + mpi.send.Robj(list(data.arg=list(X[[i]])), dest=i,tag=i, comm=comm) + + if (!is.null(apply.seq)){ + for ( i in 1:n){ + tmp <- mpi.recv.Robj(source=apply.seq[i], tag=mpi.anytag, comm=comm) + tag <- mpi.get.sourcetag()[2] + out[[tag]]<- tmp + j <- i+slave.num + if (j <= n) + mpi.send.Robj(list(data.arg=list(X[[j]])), dest=apply.seq[i],tag=j, comm=comm) + else + mpi.send.Robj(list(data.arg=list(n)),dest=apply.seq[i],tag=j,comm=comm) + } + return(out) + } + #.mpi.applyLB <<- integer(n) + mpi.seq.tmp <- integer(n) + for (i in 1:n){ + tmp<- mpi.recv.Robj(mpi.anysource,mpi.anytag,comm) + srctag <- mpi.get.sourcetag() + out[[srctag[2]]]<- tmp + mpi.seq.tmp[i] <- srctag[1] + j <- i+slave.num + if (j <= n) + mpi.send.Robj(list(data.arg=list(X[[j]])), dest=srctag[1],tag=j, comm=comm) + else + mpi.send.Robj(list(data.arg=list(n)),dest=srctag[1],tag=j,comm=comm) + } + #assign(".mpi.applyLB",mpi.seq.tmp, envir = .GlobalEnv) + out +} + +.mpi.worker.applyLB <- function(n){ + #assign(".mpi.err", FALSE, envir = .GlobalEnv) + .comm <- 1 + #n <- mpi.bcast(integer(1), type=1, comm=.comm) + tmpfunarg <- mpi.bcast.Robj(rank=0, comm=.comm) + .tmpfun <- tmpfunarg$FUN + dotarg <- tmpfunarg$dot.arg + mpi.anytag <- mpi.any.tag() + repeat { + tmpdata.arg <- mpi.recv.Robj(source=0,tag=mpi.anytag, comm=.comm)$data.arg + tag <- mpi.get.sourcetag()[2] + if (tag > n) + break + out <- try(do.call(".tmpfun", c(tmpdata.arg, dotarg)),TRUE) + #if (.mpi.err) + # print(geterrmessage()) + mpi.send.Robj(out,0,tag,.comm) + } +} + +mpi.iapplyLB <- function(X, FUN, ..., apply.seq=NULL, comm=1, sleep=0.01){ + apply.seq=NULL + n <- length(X) + slave.num <- mpi.comm.size(comm)-1 + if (slave.num < 1) + stop("There are no slaves running") + if (n <= slave.num) { + if (exists(".mpi.applyLB")) + rm(".mpi.applyLB", envir =.GlobalEnv) + return (mpi.iapply(X,FUN,...,comm=comm,sleep=sleep)) + } + if (!is.function(FUN)) + stop("FUN is not a function") + if (slave.num > 2000) + stop("Total slaves are more than nonblock send/receive can handle") + length(list(...)) + if (!is.null(apply.seq)) + if (!is.integer(apply.seq)) + stop("apply.seq is not an integer vector") + else if (min(apply.seq)<1 && max(apply.seq)>slave.num && + length(apply.seq)!=n) + stop("apply.seq is not in right order") + + mpi.bcast.cmd(.mpi.worker.applyLB, n=n, comm=comm) + #mpi.bcast(as.integer(n),type=1,comm=comm) + mpi.bcast.Robj(list(FUN=FUN,dot.arg=list(...)),rank=0,comm=comm) + out <- as.list(integer(n)) + mpi.anysource <- mpi.any.source() + mpi.anytag <- mpi.any.tag() + for (i in 1:slave.num) + mpi.send.Robj(list(data.arg=list(X[[i]])), dest=i,tag=i,comm=comm) + #for (i in 1:slave.num) + # mpi.waitany(slave.num) + + if (!is.null(apply.seq)){ + i=0 + repeat { + if (mpi.iprobe(apply.seq[i+1],mpi.anytag,comm)){ + i=i+1 + j <- i+slave.num + if ( j <= n) + mpi.send.Robj(list(data.arg=list(X[[j]])), dest=apply.seq[i],tag=j, comm=comm) + else + mpi.send.Robj(as.integer(0),dest=apply.seq[i],tag=j,comm=comm) + charlen <- mpi.get.count(type=4) + tag <- mpi.get.sourcetag()[2] + tmp <- unserialize(mpi.recv(x = raw(charlen), type = 4, apply.seq[i], tag, comm)) + out[[tag]]<- tmp + #mpi.wait(0) + } + if (i < n) + Sys.sleep(sleep) + else break + } + return(out) + } + mpi.seq.tmp <- integer(n) + i=0 + repeat { + if (mpi.iprobe(mpi.anysource,mpi.anytag,comm)){ + i=i+1 + srctag <- mpi.get.sourcetag() + src <- srctag[1] + tag <- srctag[2] + j <- i+slave.num + if ( j <= n) + mpi.send.Robj(list(data.arg=list(X[[j]])), dest=src,tag=j, comm=comm) + else + mpi.send.Robj(as.integer(0),dest=src,tag=j,comm=comm) + charlen <- mpi.get.count(type=4) + tmp <- unserialize(mpi.recv(x = raw(charlen), type = 4, src, tag, comm)) + out[[tag]]<- tmp + mpi.seq.tmp[i] <- src + #mpi.wait(src-1) + } + if (i < n) + Sys.sleep(sleep) + else + break + } + #assign(".mpi.applyLB",mpi.seq.tmp, envir = .GlobalEnv) + gc() + out +} + +#.mpi.worker.iapplyLB <- function(){ +# assign(".mpi.err", FALSE, envir = .GlobalEnv) +# n <- mpi.bcast(integer(1), type=1, comm=.comm) +# tmpfunarg <- mpi.bcast.Robj(rank=0, comm=.comm) +# .tmpfun <- tmpfunarg$fun +# dotarg <- tmpfunarg$dot.arg +# mpi.anytag <- mpi.any.tag() +# repeat { +# tmpdata.arg <- mpi.recv.Robj(source=0,tag=mpi.anytag, comm=.comm)$data.arg +# tag <- mpi.get.sourcetag()[2] +# if (tag > n) +# break +# out <- try(do.call(".tmpfun", c(tmpdata.arg, dotarg)),TRUE) +# #if (.mpi.err) +# # print(geterrmessage()) +# mpi.wait(0) +# mpi.isend.Robj(out,0,tag,.comm) +# } +# mpi.wait(0) +#} + +.simplify <- function(n, answer, simplify, len=1, recursive=FALSE){ + if (simplify && length(answer)&&length(common.len <- unique(unlist(lapply(answer, + length)))) == 1 ) { + if (common.len == len) + unlist(answer, recursive = recursive) + else if (common.len > len) + array(unlist(answer, recursive = recursive), + dim = c(common.len/len, n*len), + dimnames = list(names(answer[[1]]), names(answer))) + else answer + } + else answer +} + +mpi.parLapply <- function(X, FUN, ..., job.num=mpi.comm.size(comm)-1, apply.seq=NULL, comm=1){ + if (job.num < 2) + stop("job.num is at least 2.") + splitList <- function(x, ncl) + lapply(.splitIndices(length(X), ncl), function(i) X[i]) + .docall(c, mpi.applyLB(splitList(X, job.num), + lapply, FUN, ..., apply.seq=apply.seq, comm=comm)) +} + +mpi.iparLapply <- function(X, FUN, ..., job.num=mpi.comm.size(comm)-1, apply.seq=NULL, comm=1, sleep=0.01){ + if (job.num < 2) + stop("job.num is at least 2.") + splitList <- function(X, ncl) + lapply(.splitIndices(length(X), ncl), function(i) X[i]) + .docall(c, mpi.iapplyLB(splitList(X, job.num), + lapply, FUN, ..., apply.seq=apply.seq, comm=comm, sleep=sleep)) +} + +mpi.parSapply <- function (X, FUN, ..., job.num=mpi.comm.size(comm)-1, apply.seq=NULL, + simplify = TRUE, USE.NAMES = TRUE, comm=1) +{ + FUN <- match.fun(FUN) + answer <- mpi.parLapply(as.list(X),FUN,...,job.num=job.num,apply.seq=apply.seq,comm=comm) + if (USE.NAMES && is.character(X) && is.null(names(answer))) + names(answer) <- X + .simplify(length(X),answer, simplify) +} + +mpi.iparSapply <- function (X, FUN, ..., job.num=mpi.comm.size(comm)-1, apply.seq=NULL, + simplify = TRUE, USE.NAMES = TRUE, comm=1,sleep=0.01) +{ + FUN <- match.fun(FUN) + answer <- mpi.iparLapply(as.list(X),FUN,...,job.num=job.num,apply.seq=apply.seq,comm=comm,sleep=sleep) + if (USE.NAMES && is.character(X) && is.null(names(answer))) + names(answer) <- X + .simplify(length(X),answer, simplify) +} + +mpi.parReplicate <- function(n, expr, job.num=mpi.comm.size(comm)-1, apply.seq=NULL, + simplify = TRUE, comm=1){ + mpi.parSapply(integer(n), eval.parent(substitute(function(...) expr)), + job.num=job.num, apply.seq=apply.seq, simplify = simplify, comm=comm) +} + +mpi.iparReplicate <- function(n, expr, job.num=mpi.comm.size(comm)-1, apply.seq=NULL, + simplify = TRUE, comm=1,sleep=0.01){ + mpi.iparSapply(integer(n), eval.parent(substitute(function(...) expr)), + job.num=job.num, apply.seq=apply.seq, simplify = simplify, comm=comm,sleep=sleep) +} + +mpi.parRapply <- function(X,FUN,...,job.num=mpi.comm.size(comm)-1,apply.seq=NULL,comm=1){ + if (job.num < 2) + stop("job.num is at least 2.") + splitRows <- function(X, ncl) + lapply(.splitIndices(nrow(X), ncl), function(i) X[i,, drop=FALSE]) + .docall(c, mpi.applyLB(splitRows(X,job.num), apply, 1, FUN, ..., + apply.seq=apply.seq, comm=comm)) +} + +mpi.iparRapply <- function(X,FUN,...,job.num=mpi.comm.size(comm)-1,apply.seq=NULL,comm=1,sleep=0.01){ + if (job.num < 2) + stop("job.num is at least 2.") + splitRows <- function(X, ncl) + lapply(.splitIndices(nrow(X), ncl), function(i) X[i,, drop=FALSE]) + .docall(c, mpi.iapplyLB(splitRows(X,job.num), apply, 1, FUN, ..., + apply.seq=apply.seq, comm=comm,sleep=sleep)) +} + +mpi.parCapply <- function(X,FUN,...,job.num=mpi.comm.size(comm)-1,apply.seq=NULL,comm=1){ + if (job.num < 2) + stop("job.num is at least 2.") + splitCols <- function(X, ncl) + lapply(.splitIndices(ncol(X), ncl), function(i) X[,i, drop=FALSE]) + .docall(c, mpi.applyLB(splitCols(X,job.num), apply, 2, FUN, ..., + apply.seq=apply.seq, comm=comm)) +} + +mpi.iparCapply <- function(X,FUN,...,job.num=mpi.comm.size(comm)-1,apply.seq=NULL,comm=1,sleep=0.01){ + if (job.num < 2) + stop("job.num is at least 2.") + splitCols <- function(X, ncl) + lapply(.splitIndices(ncol(X), ncl), function(i) X[,i, drop=FALSE]) + .docall(c, mpi.iapplyLB(splitCols(X,job.num), apply, 2, FUN, ..., + apply.seq=apply.seq, comm=comm,sleep=sleep)) +} + +mpi.parApply <- function(X, MARGIN, FUN, ..., job.num = mpi.comm.size(comm)-1, + apply.seq=NULL, comm=1) +{ + FUN <- match.fun(FUN) + d <- dim(X) + dl <- length(d) + if(dl == 0) + stop("dim(X) must have a positive length") + ds <- 1:dl + + if(length(oldClass(X)) > 0) + X <- if(dl == 2) as.matrix(X) else as.array(X) + dn <- dimnames(X) + + s.call <- ds[-MARGIN] + s.ans <- ds[MARGIN] + d.call <- d[-MARGIN] + d.ans <- d[MARGIN] + dn.call<- dn[-MARGIN] + dn.ans <- dn[MARGIN] + + d2 <- prod(d.ans) + if(d2 == 0) { + newX <- array(vector(typeof(X), 1), dim = c(prod(d.call), 1)) + ans <- FUN(if(length(d.call) < 2) newX[,1] else + array(newX[,1], d.call, dn.call), ...) + return(if(is.null(ans)) ans else if(length(d.call) < 2) ans[1][-1] + else array(ans, d.ans, dn.ans)) + } + newX <- aperm(X, c(s.call, s.ans)) + dim(newX) <- c(prod(d.call), d2) + if(length(d.call) < 2) { + if (length(dn.call)) dimnames(newX) <- c(dn.call, list(NULL)) + ans <- mpi.parLapply(1:d2, function(i, ...) FUN(newX[,i], ...), + ..., job.num = job.num, apply.seq=apply.seq, comm=comm ) + } + else + ans <- mpi.parLapply(1:d2, + function(i, ...) FUN(array(newX[,i], d.call, dn.call), ...), + ..., job.num = job.num, apply.seq=apply.seq, comm=comm) + + ans.list <- is.recursive(ans[[1]]) + l.ans <- length(ans[[1]]) + + ans.names <- names(ans[[1]]) + if(!ans.list) + ans.list <- any(unlist(lapply(ans, length)) != l.ans) + if(!ans.list && length(ans.names)) { + all.same <- sapply(ans, function(X) identical(names(X), ans.names)) + if (!all(all.same)) ans.names <- NULL + } + len.a <- if(ans.list) d2 else length(ans <- unlist(ans, recursive = FALSE)) + if(length(MARGIN) == 1 && len.a == d2) { + names(ans) <- if(length(dn.ans[[1]])) dn.ans[[1]] + return(ans) + } + if(len.a == d2) + return(array(ans, d.ans, dn.ans)) + if(len.a > 0 && len.a %% d2 == 0) + return(array(ans, c(len.a %/% d2, d.ans), + if(is.null(dn.ans)) { + if(!is.null(ans.names)) list(ans.names,NULL) + } else c(list(ans.names), dn.ans))) + return(ans) +} + +mpi.iparApply <- function(X, MARGIN, FUN, ..., job.num = mpi.comm.size(comm)-1, + apply.seq=NULL, comm=1,sleep=0.01) +{ + FUN <- match.fun(FUN) + d <- dim(X) + dl <- length(d) + if(dl == 0) + stop("dim(X) must have a positive length") + ds <- 1:dl + + if(length(oldClass(X)) > 0) + X <- if(dl == 2) as.matrix(X) else as.array(X) + dn <- dimnames(X) + + s.call <- ds[-MARGIN] + s.ans <- ds[MARGIN] + d.call <- d[-MARGIN] + d.ans <- d[MARGIN] + dn.call<- dn[-MARGIN] + dn.ans <- dn[MARGIN] + + d2 <- prod(d.ans) + if(d2 == 0) { + newX <- array(vector(typeof(X), 1), dim = c(prod(d.call), 1)) + ans <- FUN(if(length(d.call) < 2) newX[,1] else + array(newX[,1], d.call, dn.call), ...) + return(if(is.null(ans)) ans else if(length(d.call) < 2) ans[1][-1] + else array(ans, d.ans, dn.ans)) + } + newX <- aperm(X, c(s.call, s.ans)) + dim(newX) <- c(prod(d.call), d2) + if(length(d.call) < 2) { + if (length(dn.call)) dimnames(newX) <- c(dn.call, list(NULL)) + ans <- mpi.iparLapply(1:d2, function(i, ...) FUN(newX[,i], ...), + ..., job.num = job.num, apply.seq=apply.seq, comm=comm, sleep=sleep ) + } + else + ans <- mpi.iparLapply(1:d2, + function(i, ...) FUN(array(newX[,i], d.call, dn.call), ...), + ..., job.num = job.num, apply.seq=apply.seq, comm=comm, sleep=sleep) + + ans.list <- is.recursive(ans[[1]]) + l.ans <- length(ans[[1]]) + + ans.names <- names(ans[[1]]) + if(!ans.list) + ans.list <- any(unlist(lapply(ans, length)) != l.ans) + if(!ans.list && length(ans.names)) { + all.same <- sapply(ans, function(X) identical(names(X), ans.names)) + if (!all(all.same)) ans.names <- NULL + } + len.a <- if(ans.list) d2 else length(ans <- unlist(ans, recursive = FALSE)) + if(length(MARGIN) == 1 && len.a == d2) { + names(ans) <- if(length(dn.ans[[1]])) dn.ans[[1]] + return(ans) + } + if(len.a == d2) + return(array(ans, d.ans, dn.ans)) + if(len.a > 0 && len.a %% d2 == 0) + return(array(ans, c(len.a %/% d2, d.ans), + if(is.null(dn.ans)) { + if(!is.null(ans.names)) list(ans.names,NULL) + } else c(list(ans.names), dn.ans))) + return(ans) +} + +#mpi.parallel.sim <- mpi.parSim diff -Nru rmpi-0.6-9.2/src/conversion.c rmpi-0.7-1/src/conversion.c --- rmpi-0.6-9.2/src/conversion.c 2018-11-12 18:51:40.000000000 +0000 +++ rmpi-0.7-1/src/conversion.c 2023-03-17 13:55:57.000000000 +0000 @@ -28,7 +28,7 @@ return sexp_x; } -SEXP pid(){ +SEXP pid(void){ return AsInt(getpid()); } diff -Nru rmpi-0.6-9.2/src/Rmpi.c rmpi-0.7-1/src/Rmpi.c --- rmpi-0.6-9.2/src/Rmpi.c 2018-11-12 18:51:40.000000000 +0000 +++ rmpi-0.7-1/src/Rmpi.c 2023-01-20 19:42:59.000000000 +0000 @@ -35,7 +35,7 @@ #define XLENGTH LENGTH #endif -SEXP mpidist(){ +SEXP mpidist(void){ int i=0; #ifdef OPENMPI @@ -57,7 +57,7 @@ return AsInt(i); } -SEXP mpi_initialize(){ +SEXP mpi_initialize(void){ int i,flag; MPI_Initialized(&flag); @@ -107,7 +107,7 @@ } } -SEXP mpi_finalize(){ +SEXP mpi_finalize(void){ MPI_Finalize(); Free(comm); Free(status); @@ -118,7 +118,7 @@ return AsInt(1); } -SEXP mpi_get_processor_name (){ +SEXP mpi_get_processor_name (void){ int resultlen; char *name; SEXP sexp_name; @@ -139,7 +139,7 @@ */ #ifdef MPI2 -SEXP mpi_universe_size(){ +SEXP mpi_universe_size(void){ int *MPI_Universe_Size; int univ_flag; MPI_Comm_get_attr(comm[0], MPI_UNIVERSE_SIZE, &MPI_Universe_Size, &univ_flag); @@ -150,19 +150,19 @@ } #endif -SEXP mpi_any_source(){ +SEXP mpi_any_source(void){ return AsInt(MPI_ANY_SOURCE); } -SEXP mpi_any_tag(){ +SEXP mpi_any_tag(void){ return AsInt(MPI_ANY_TAG); } -SEXP mpi_undefined(){ +SEXP mpi_undefined(void){ return AsInt(MPI_UNDEFINED); } -SEXP mpi_proc_null(){ +SEXP mpi_proc_null(void){ return AsInt(MPI_PROC_NULL); } @@ -205,7 +205,7 @@ return AsInt(1); } -SEXP mpi_comm_maxsize(){ +SEXP mpi_comm_maxsize(void){ return AsInt(COMM_MAXSIZE); } @@ -218,7 +218,7 @@ return AsInt(1); } -SEXP mpi_status_maxsize(){ +SEXP mpi_status_maxsize(void){ return AsInt(STATUS_MAXSIZE); } @@ -232,7 +232,7 @@ return AsInt(1); } -SEXP mpi_request_maxsize(){ +SEXP mpi_request_maxsize(void){ return AsInt(REQUEST_MAXSIZE); } @@ -1065,7 +1065,7 @@ return AsInt(erreturn(mpi_errhandler(MPI_Comm_get_parent(&comm[INTEGER(sexp_comm)[0]])))); } -SEXP mpi_is_master(){ +SEXP mpi_is_master(void){ int check; MPI_Comm master; MPI_Comm_get_parent(&master); diff -Nru rmpi-0.6-9.2/src/Rmpi.h rmpi-0.7-1/src/Rmpi.h --- rmpi-0.6-9.2/src/Rmpi.h 2018-11-12 18:51:40.000000000 +0000 +++ rmpi-0.7-1/src/Rmpi.h 2023-01-20 19:39:21.000000000 +0000 @@ -31,24 +31,24 @@ // extern void *R_chk_calloc2(size_t, size_t); /* from Rmpi.c */ -SEXP mpi_initialize(); -SEXP mpi_finalize(); -SEXP mpi_get_processor_name(); -SEXP mpi_universe_size(); -SEXP mpi_any_source(); -SEXP mpi_any_tag(); -SEXP mpi_undefined(); -SEXP mpi_proc_null(); +SEXP mpi_initialize(void); +SEXP mpi_finalize(void); +SEXP mpi_get_processor_name(void); +SEXP mpi_universe_size(void); +SEXP mpi_any_source(void); +SEXP mpi_any_tag(void); +SEXP mpi_undefined(void); +SEXP mpi_proc_null(void); SEXP mpi_info_create(SEXP sexp_info); SEXP mpi_info_set(SEXP sexp_info, SEXP sexp_key, SEXP sexp_value); SEXP mpi_info_get(SEXP sexp_info, SEXP sexp_key, SEXP sexp_valuelen); SEXP mpi_info_free(SEXP sexp_info); SEXP mpi_realloc_comm(SEXP sexp_newncomm); -SEXP mpi_comm_maxsize(); +SEXP mpi_comm_maxsize(void); SEXP mpi_realloc_status(SEXP sexp_newnstatus); -SEXP mpi_status_maxsize(); +SEXP mpi_status_maxsize(void); SEXP mpi_realloc_request(SEXP sexp_newnrequest); -SEXP mpi_request_maxsize(); +SEXP mpi_request_maxsize(void); SEXP mpi_realloc_datatype(SEXP sexp_newndatatype); SEXP mpi_gather(SEXP sexp_sdata, SEXP sexp_type, SEXP sexp_rdata, SEXP sexp_root, SEXP sexp_comm); @@ -86,7 +86,7 @@ SEXP mpi_comm_spawn (SEXP sexp_slave, SEXP sexp_argv, SEXP sexp_nslave, SEXP sexp_info, SEXP sexp_root, SEXP sexp_intercomm, SEXP sexp_quiet); SEXP mpi_comm_get_parent(SEXP sexp_comm); -SEXP mpi_is_master(); +SEXP mpi_is_master(void); SEXP mpi_comm_disconnect(SEXP sexp_comm); SEXP mpi_intercomm_merge(SEXP sexp_intercomm, SEXP sexp_high, SEXP sexp_comm); SEXP mpi_comm_remote_size(SEXP sexp_comm);