This is an automated email from the git hooks/post-receive script. albac-guest pushed a commit to branch master in repository r-cran-rngtools.
commit 25cb50251f7a26f8f29d0e1e26730df01f96523b Author: Alba Crespi <[email protected]> Date: Sun Jul 3 23:02:11 2016 +0200 Imported Upstream version 1.2.4 --- DESCRIPTION | 24 ++ MD5 | 23 ++ NAMESPACE | 23 ++ R/RNG.R | 639 +++++++++++++++++++++++++++++++++++++++ R/RNGseq.R | 206 +++++++++++++ R/format.R | 208 +++++++++++++ R/rngtools-package.r | 56 ++++ README.md | 12 + build/vignette.rds | Bin 0 -> 209 bytes inst/doc/rngtools-unitTests.R | 9 + inst/doc/rngtools-unitTests.Rnw | 80 +++++ inst/doc/rngtools-unitTests.pdf | Bin 0 -> 99069 bytes inst/tests/runit.RNG.r | 133 ++++++++ inst/tests/runit.RNGseq.r | 162 ++++++++++ inst/tests/runit.format.r | 103 +++++++ man/RNGseed.Rd | 60 ++++ man/RNGseq.Rd | 95 ++++++ man/RNGstr.Rd | 121 ++++++++ man/rng.Rd | 238 +++++++++++++++ man/rngcmp.Rd | 31 ++ man/rngtools.Rd | 53 ++++ man/uchecks.Rd | 26 ++ tests/doRUnit.R | 6 + vignettes/rngtools-unitTests.Rnw | 80 +++++ 24 files changed, 2388 insertions(+) diff --git a/DESCRIPTION b/DESCRIPTION new file mode 100644 index 0000000..bb75d7c --- /dev/null +++ b/DESCRIPTION @@ -0,0 +1,24 @@ +Package: rngtools +Maintainer: Renaud Gaujoux <[email protected]> +Author: Renaud Gaujoux +Version: 1.2.4 +License: GPL-3 +Title: Utility functions for working with Random Number Generators +Description: This package contains a set of functions for working with + Random Number Generators (RNGs). In particular, it defines a generic + S4 framework for getting/setting the current RNG, or RNG data + that are embedded into objects for reproducibility. + Notably, convenient default methods greatly facilitate the way current + RNG settings can be changed. +URL: https://renozao.github.io/rngtools +BugReports: http://github.com/renozao/rngtools/issues +SCM: github:renozao, r-forge +Depends: R (>= 3.0.0), methods, pkgmaker (>= 0.20) +Imports: stringr, digest +Suggests: parallel, RUnit, knitr +Collate: 'rngtools-package.r' 'format.R' 'RNG.R' 'RNGseq.R' +VignetteBuilder: knitr +Packaged: 2014-03-06 13:11:11 UTC; renaud +NeedsCompilation: no +Repository: CRAN +Date/Publication: 2014-03-06 22:18:10 diff --git a/MD5 b/MD5 new file mode 100644 index 0000000..8edc212 --- /dev/null +++ b/MD5 @@ -0,0 +1,23 @@ +2f38fe52d9b165b47c771ac2b0da0fbd *DESCRIPTION +b9a32980e99ce9c025b0597ae8b58717 *NAMESPACE +5adf706c7f033e4df1be28d4fd68d680 *R/RNG.R +ecbc598f29702d10d8efb3fb0495fe28 *R/RNGseq.R +fec46586c69d62db5fb1e13bb125cd50 *R/format.R +e2029dcfc0a3f91647cdd34d4ced1929 *R/rngtools-package.r +3820488e613033e8bb5b526227147be1 *README.md +219cf9f7d2b662dfa2a9308817d7e83f *build/vignette.rds +6118ae7b86de4110717f8213518e5a88 *inst/doc/rngtools-unitTests.R +640605f55fb05c3bc722bfc2dff10326 *inst/doc/rngtools-unitTests.Rnw +9b0719669b75e46cedb037f2b3849193 *inst/doc/rngtools-unitTests.pdf +2fe79852860623ebee42ac6f3d09d8f4 *inst/tests/runit.RNG.r +43a4b97ff6a6ab8eb0bc055a1296a297 *inst/tests/runit.RNGseq.r +454f088e424ec986386a05df67547d74 *inst/tests/runit.format.r +58c623d5812709cb7a229db09e28a33b *man/RNGseed.Rd +da7c8a7b2d6775dd9ae91c984e074b74 *man/RNGseq.Rd +c3b8aac92c0b78e95d09a7f182c9d131 *man/RNGstr.Rd +f3ed281a3d6a2486f077e3ae82d7d053 *man/rng.Rd +29055b8d1c2295715232370351928602 *man/rngcmp.Rd +5309ae8b9c73e02166f9800e41165144 *man/rngtools.Rd +6e57687d6148e44975f7e448a8635dd1 *man/uchecks.Rd +1b0d4ec95a873e5554708f9c20ca1e70 *tests/doRUnit.R +640605f55fb05c3bc722bfc2dff10326 *vignettes/rngtools-unitTests.Rnw diff --git a/NAMESPACE b/NAMESPACE new file mode 100644 index 0000000..0dc79ce --- /dev/null +++ b/NAMESPACE @@ -0,0 +1,23 @@ +export(.getRNG) +export(.setRNG) +export(RNGdigest) +export(RNGinfo) +export(RNGrecovery) +export(RNGseed) +export(RNGseq) +export(RNGseq_seed) +export(RNGstr) +export(RNGtype) +export(checkRNG) +export(getRNG) +export(getRNG1) +export(hasRNG) +export(nextRNG) +export(rng.equal) +export(rng1.equal) +export(setRNG) +export(showRNG) +import(digest) +import(methods) +import(pkgmaker) +import(stringr) diff --git a/R/RNG.R b/R/RNG.R new file mode 100644 index 0000000..0c04900 --- /dev/null +++ b/R/RNG.R @@ -0,0 +1,639 @@ +# Copyright (C) 2009-2012 Renaud Gaujoux +# +# This file is part of the rngtools package for R. +# This program is free software; you can redistribute it and/or +# modify it under the terms of the GNU General Public License +# as published by the Free Software Foundation; either version 2 +# of the License, or (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +# +# Creation: 08 Nov 2011 +############################################################################### + +library(pkgmaker) + +###% Returns all the libraries that provides a user-supplied RNG +###% +###% The library that provides the wrapper hooks for the management multiple +###% user-supplied RNG is removed from the output list. +###% +RNGlibs <- function(n=0, full=FALSE, hook="user_unif_rand", unlist=TRUE){ + dlls <- getLoadedDLLs() + res <- lapply(dlls, function(d){ + dname <- d[['name']] + if( dname=='' ) + return(NA) + + symb.unif_rand <- RNGlib(PACKAGE=dname, hook=hook) + if( is.null(symb.unif_rand) ) + NA + else + symb.unif_rand + }) + + res <- res[!is.na(res)] + if( !full ) + res <- names(res) + + # limit the results if requested + if( n>0 ) + res <- tail(res, n) + + # return result + if( unlist && length(res) == 1 ) + res[[1]] + else + res +} + +###% Returns the library that provides the current user-supplied RNG hooks. +###% +###% This is the library that is first called by runif when using setting RNG +###% kind to "user-supplied". +###% In general this will be rstream, except if a package providing the RNG hook +###% 'user_unif_rand' is loaded after rstream, and no call to RNGkind or getRNG +###% were done thereafter. +###% +###% @return an object of class NativeSymbolInfo or NULL if no hook were found +###% +RNGlib <- function(PACKAGE='', full=FALSE, hook="user_unif_rand", ...){ + + if( !missing(PACKAGE) ) + full = TRUE + if( !missing(hook) ) + hook <- match.arg(hook, c('user_unif_rand', 'user_unif_init', 'user_unif_nseed', 'user_unif_seedloc')) + + # lookup for the hook "user_unif_rand" in all the loaded libraries + symb.unif_rand <- try( getNativeSymbolInfo(hook, PACKAGE=PACKAGE, ...), silent=TRUE) + if( is(symb.unif_rand, 'try-error') ){ + + if( !full ) '' else NULL + + }else if( PACKAGE=='' && is.null(symb.unif_rand$package) ){ + #special case for MS Windows when PACKAGE is not specified: if two + # RNGlibs are loaded, the first one is seen, not the last one as on Unix + libs <- RNGlibs(full=TRUE, unlist=FALSE, hook=hook) + w <- which(sapply(libs, function(l) identical(l$address, symb.unif_rand$address))) + + # returns full info or just the name + if( full ) libs[[w]] + else names(libs)[w] + + }else if( full ) symb.unif_rand + else symb.unif_rand$package[['name']] +} + +###% Returns the package that provides the current RNG managed by rstream +###% +###% It returns the name of the package to which are currently passed the RNG +###% calls (runif, set.seed). +###% This is either 'base' if core RNG is in use (e.g. Mersenne-Twister, Marsaglia-Multicarry, etc...) +###% or the package that provides the actual RNG hooks called by the rstream +###% wrapper hooks. This one was set either explicitly via RNGkind or implicitly +###% when rstream was first loaded. In this latter case, the provider was identified +###% at loading time as 'base' if core RNGs were in use or as the package that was +###% providing the RNG hook 'user_unif_rand' if the RNG in used was "user-supplied". +###% +RNGprovider <- function(kind=RNGkind(), user.supplied=FALSE){ + + if( kind[1L] == 'user-supplied' || user.supplied ) RNGlib() + else 'base' +} + +#' Directly Getting or Setting the RNG Seed +#' +#' \code{RNGseed} directly gets/sets the current RNG seed \code{.Random.seed}. +#' It can typically be used to backup and restore the RNG state on exit of +#' functions, enabling local RNG changes. +#' +#' @param seed an RNG seed, i.e. an integer vector. +#' No validity check is performed, so it \strong{must} be a +#' valid seed. +#' +#' @return invisibly the current RNG seed when called with no arguments, +#' or the -- old -- value of the seed before changing it to +#' \code{seed}. +#' +#' @export +#' @examples +#' +#' # get current seed +#' RNGseed() +#' # directly set seed +#' old <- RNGseed(c(401L, 1L, 1L)) +#' # show old/new seed description +#' showRNG(old) +#' showRNG() +#' +#' # set bad seed +#' RNGseed(2:3) +#' try( showRNG() ) +#' # recover from bad state +#' RNGrecovery() +#' showRNG() +#' +#' # example of backup/restore of RNG in functions +#' f <- function(){ +#' orng <- RNGseed() +#' on.exit(RNGseed(orng)) +#' RNGkind('Marsaglia') +#' runif(10) +#' } +#' +#' sample(NA) +#' s <- .Random.seed +#' f() +#' identical(s, .Random.seed) +#' \dontshow{ stopifnot(identical(s, .Random.seed)) } +#' +RNGseed <- function(seed){ + + res <- if( missing(seed) ){ + if( exists('.Random.seed', where = .GlobalEnv) ) + get('.Random.seed', envir = .GlobalEnv) + }else if( is.null(seed) ){ + if( exists('.Random.seed', where = .GlobalEnv) ) + rm('.Random.seed', envir = .GlobalEnv) + }else{ + old <- RNGseed() + assign('.Random.seed', seed, envir = .GlobalEnv) + old + } + invisible(res) +} + +#' \code{RNGrecovery} recovers from a broken state of \code{.Random.seed}, +#' and reset the RNG settings to defaults. +#' +#' @export +#' @rdname RNGseed +RNGrecovery <- function(){ + s <- as.integer(c(401,0,0)) + assign(".Random.seed", s, envir=.GlobalEnv) + RNGkind("default", "default") +} + +.getRNGattribute <- function(object){ + if( .hasSlot(object, 'rng') ) slot(object, 'rng') + else if( .hasSlot(object, 'rng.seed') ) slot(object, 'rng.seed') # for back compatibility + else if( !is.null(attr(object, 'rng')) ) attr(object, 'rng') + else if( is.list(object) ){ # compatibility with package setRNG + if( !is.null(object[['rng']]) ) object[['rng']] + else if( is.list(object[['noise']]) && !is.null(object[['noise']][['rng']]) ) + object[['noise']][['rng']] + }else NULL +} + +#' Getting/Setting RNGs +#' +#' \code{getRNG} returns the Random Number Generator (RNG) settings used for +#' computing an object, using a suitable \code{.getRNG} S4 method to extract +#' these settings. +#' For example, in the case of objects that result from multiple model fits, +#' it would return the RNG settings used to compute the best fit. +#' +#' This function handles single number RNG specifications in the following way: +#' \describe{ +#' \item{integers}{Return them unchanged, considering them as encoded RNG kind +#' specification (see \code{\link{RNG}}). No validity check is performed.} +#' \item{real numbers}{If \code{num.ok=TRUE} return them unchanged. +#' Otherwise, consider them as (pre-)seeds and pass them to \code{\link{set.seed}} +#' to get a proper RNG seed. +#' Hence calling \code{getRNG(1234)} is equivalent to \code{set.seed(1234); getRNG()} +#' (See examples). +#' } +#' } +#' +#' @param object an R object from which RNG settings can be extracted, e.g. an +#' integer vector containing a suitable value for \code{.Random.seed} or embedded +#' RNG data, e.g., in S3/S4 slot \code{rng} or \code{rng$noise}. +#' @param ... extra arguments to allow extension and passed to a suitable S4 method +#' \code{.getRNG} or \code{.setRNG}. +#' @param num.ok logical that indicates if single numeric (not integer) RNG data should be +#' considered as a valid RNG seed (\code{TRUE}) or passed to \code{\link{set.seed}} +#' into a proper RNG seed (\code{FALSE}) (See details and examples). +#' @param extract logical that indicates if embedded RNG data should be looked for and +#' extracted (\code{TRUE}) or if the object itself should be considered as an +#' RNG specification. +#' @param recursive logical that indicates if embedded RNG data should be extracted +#' recursively (\code{TRUE}) or only once (\code{FASE}). +#' +#' @return \code{getRNG}, \code{getRNG1}, \code{nextRNG} and \code{setRNG} +#' usually return an integer vector of length > 2L, like \code{\link{.Random.seed}}. +#' +#' \code{getRNG} and \code{getRNG1} return \code{NULL} if no RNG data was found. +#' +#' @rdname rng +#' @seealso \code{\link{.Random.seed}}, \code{\link{showRNG}} +#' @export +#' +#' @examples +#' # get current RNG settings +#' s <- getRNG() +#' head(s) +#' showRNG(s) +#' +#' # get RNG from a given single numeric seed +#' s1234 <- getRNG(1234) +#' head(s1234) +#' showRNG(s1234) +#' # this is identical to the RNG seed as after set.seed() +#' set.seed(1234) +#' identical(s1234, .Random.seed) +#' # but if num.ok=TRUE the object is returned unchanged +#' getRNG(1234, num.ok=TRUE) +#' +#' # single integer RNG data = encoded kind +#' head(getRNG(1L)) +#' +#' # embedded RNG data +#' s <- getRNG(list(1L, rng=1234)) +#' identical(s, s1234) +#' +getRNG <- function(object, ..., num.ok=FALSE, extract=TRUE, recursive=TRUE){ + + if( missing(object) || is.null(object) ) return( .getRNG() ) + + # use RNG data from object if available + if( extract && !is.null(rng <- .getRNGattribute(object)) ){ + if( recursive && hasRNG(rng) ) getRNG(rng, ..., num.ok=num.ok) + else rng + }else if( isNumber(object) ){ + if( num.ok && isReal(object) ) object + else if( isInteger(object) ) object + else nextRNG(object, ...) # return RNG as if after setting seed + }else .getRNG(object, ...) # call S4 method on object + +} + +#' \code{hasRNG} tells if an object has embedded RNG data. +#' @export +#' @rdname rng +#' +#' @examples +#' # test for embedded RNG data +#' hasRNG(1) +#' hasRNG( structure(1, rng=1:3) ) +#' hasRNG( list(1, 2, 3) ) +#' hasRNG( list(1, 2, 3, rng=1:3) ) +#' hasRNG( list(1, 2, 3, noise=list(1:3, rng=1)) ) +#' +hasRNG <- function(object){ + !is.null(.getRNGattribute(object)) +} + +#' \code{.getRNG} is an S4 generic that extract RNG settings from a variety of +#' object types. +#' Its methods define the workhorse functions that are called by \code{getRNG}. +#' +#' @rdname rng +#' @inline +#' @export +setGeneric('.getRNG', function(object, ...) standardGeneric('.getRNG') ) +#' Default method that tries to extract RNG information from \code{object}, by +#' looking sequentially to a slot named \code{'rng'}, a slot named \code{'rng.seed'} +#' or an attribute names \code{'rng'}. +#' +#' It returns \code{NULL} if no RNG data was found. +setMethod('.getRNG', 'ANY', + function(object, ...){ + .getRNGattribute(object) + } +) +#' Returns the current RNG settings. +setMethod('.getRNG', 'missing', + function(object){ + + # return current value of .Random.seed + # ensuring it exists first + if( !exists('.Random.seed', envir = .GlobalEnv) ) + sample(NA) + + return( get('.Random.seed', envir = .GlobalEnv) ) + + } +) + +#' Method for S3 objects, that aims at reproducing the behaviour of the function +#' \code{getRNG} of the package \code{getRNG}. +#' +#' It sequentially looks for RNG data in elements \code{'rng'}, \code{noise$rng} +#' if element \code{'noise'} exists and is a \code{list}, or in attribute \code{'rng'}. +#' +setMethod('.getRNG', 'list', + function(object){ + # lookup for some specific elements + if( !is.null(object$rng) ) object$rng + else if( is.list(object$noise) ) object$noise$rng + else attr(object, 'rng') + } +) +#setMethod('.getRNG', 'rstream', +# function(object){ +# object +# } +#) +#' Method for numeric vectors, which returns the object itself, coerced into an integer +#' vector if necessary, as it is assumed to already represent a value for +#' \code{\link{.Random.seed}}. +#' +setMethod('.getRNG', 'numeric', + function(object, ...){ + as.integer(object) + } +) + +#' \code{getRNG1} is an S4 generic that returns the \strong{initial} RNG settings +#' used for computing an object. +#' For example, in the case of results from multiple model fies, it would +#' return the RNG settings used to compute the \emph{first} fit. +#' +#' \code{getRNG1} is defined to provide separate access to the RNG settings as +#' they were at the very beginning of a whole computation, which might differ +#' from the RNG settings returned by \code{getRNG}, that allows to reproduce the +#' result only. +#' +#' Think of a sequence of separate computations, from which only one result is +#' used for the result (e.g. the one that maximises a likelihood): +#' \code{getRNG1} would return the RNG settings to reproduce the complete sequence +#' of computations, while \code{getRNG} would return the RNG settings necessary to +#' reproduce only the computation whose result has maximum likelihood. +#' +#' @rdname rng +#' @export +#' @inline +#' +setGeneric('getRNG1', function(object, ...) standardGeneric('getRNG1') ) +#' Default method that is identical to \code{getRNG(object, ...)}. +setMethod('getRNG1', 'ANY', + function(object, ...){ + getRNG(object, ...) + } +) + +#' \code{nextRNG} returns the RNG settings as they would be after seeding with +#' \code{object}. +#' +#' @param ndraw number of draws to perform before returning the RNG seed. +#' +#' @rdname rng +#' @export +#' @examples +#' head(nextRNG()) +#' head(nextRNG(1234)) +#' head(nextRNG(1234, ndraw=10)) +#' +nextRNG <- function(object, ..., ndraw=0L){ + + # get/restore .Random.seed on.exit + orseed <- RNGseed() + on.exit(RNGseed(orseed)) + + # return next state of current RNG if object is missing + if( missing(object) ){ + runif(1) + return( getRNG() ) + } + + # extract RNG from object + rng <- .getRNGattribute(object) + if( !is.null(rng) ){ + on.exit() + return( nextRNG(rng, ...) ) + } + + # only work for numeric seeds + if( !is.numeric(object) ) + stop("Invalid seed: expecting a numeric seed.") + + # set RNG + .setRNG(object, ...) + + # perform some draws + if( ndraw > 0 ){ + if( !isNumber(ndraw) ) + stop("Invalid value in argument `ndraw`: single numeric value expected.") + runif(ndraw) + } + # return new RNG settings + res <- RNGseed() + res +} + +.collapse <- function(x, sep=', ', n=7L){ + + res <- paste(head(x, n), collapse=', ') + if( length(x) > n ) + res <- paste(res, '...', sep=', ') + res +} + +#' \code{setRNG} set the current RNG with a seed, +#' using a suitable \code{.setRNG} method to set these settings. +#' +#' @param check logical that indicates if only valid RNG kinds should be +#' accepted, or if invalid values should just throw a warning. +#' Note that this argument is used only on R >= 3.0.2. +#' +#' @return \code{setRNG} invisibly returns the old RNG settings as +#' they were before changing them. +#' +#' @export +#' @rdname rng +#' @examples +#' +#' obj <- list(x=1000, rng=123) +#' setRNG(obj) +#' rng <- getRNG() +#' runif(10) +#' set.seed(123) +#' rng.equal(rng) +#' +setRNG <- function(object, ..., verbose=FALSE, check = TRUE){ + + # do nothing if null + if( is.null(object) ) return() + + # use RNG data from object if available + rng <- getRNG(object, ...) + if( !is.null(rng) && !identical(rng, object) ) return( setRNG(rng, ...) ) + + # get/restore .Random.seed on.exit in case of errors + orseed <- getRNG() + on.exit({ + message("Restoring RNG settings probably due to an error in setRNG") + RNGseed(orseed) + }) + + # call S4 method on object + # check validity of the seed + tryCatch(.setRNG(object, ...) + , warning = function(err){ + if( check && testRversion('> 3.0.1') + && grepl("\\.Random\\.seed.* is not a valid", err$message) ){ + stop("setRNG - Invalid RNG kind [", str_out(object), "]: " + , err$message, '.' + , call.=FALSE) + }else{ + warning(err) + } + } + ) + + # cancel RNG restoration + on.exit() + if( verbose ) showRNG() + + invisible(orseed) +} + +#' \code{.setRNG} is an S4 generic that sets the current RNG settings, from a +#' variety of specifications. +#' Its methods define the workhorse functions that are called by \code{setRNG}. +#' +#' @inline +#' @rdname rng +#' @export +setGeneric('.setRNG', function(object, ...) standardGeneric('.setRNG') ) +#' Sets the RNG to kind \code{object}, assuming is a valid RNG kind: +#' it is equivalent to \code{RNGkind(object, ...}. +#' All arguments in \code{...} are passed to \code{\link{RNGkind}}. +#' +#' @param verbose a logical that indicates if the new RNG settings should +#' be displayed. +#' +#' @examples +#' # set RNG kind +#' old <- setRNG('Marsaglia') +#' # restore +#' setRNG(old) +setMethod('.setRNG', 'character', + function(object, ...){ + if( length(object) == 1L ) + RNGkind(kind=object, ...) + else + RNGkind(kind=object[1L], normal.kind=object[2L]) + } +) + +#' Sets the RNG settings using \code{object} directly the new value for +#' \code{.Random.seed} or to initialise it with \code{\link{set.seed}}. +#' +#' @examples +#' +#' # directly set .Random.seed +#' rng <- getRNG() +#' r <- runif(10) +#' setRNG(rng) +#' rng.equal(rng) +#' +#' # initialise from a single number (<=> set.seed) +#' setRNG(123) +#' rng <- getRNG() +#' runif(10) +#' set.seed(123) +#' rng.equal(rng) +#' +setMethod('.setRNG', 'numeric', + function(object, ...){ + + if( length(object) == 1L ){ + if( is.integer(object) ){ # set kind and draw once to fix seed + RNGseed(object) + # check validity of the seed + tryCatch(runif(1) + , error = function(err){ + stop("setRNG - Invalid RNG kind [", object, "]: " + , err$message, '.' + , call.=FALSE) + } + ) + RNGseed() + }else{ # pass to set.seed + set.seed(object, ...) + } + }else{ + seed <- as.integer(object) + RNGseed(seed) + # check validity of the seed + tryCatch(runif(1) + , error=function(err){ + stop("setRNG - Invalid numeric seed [" + , .collapse(seed, n=5), "]: ", err$message, '.' + , call.=FALSE) + } + ) + RNGseed(seed) + } + } +) + +#' \code{RNGdigest} computes a hash from the RNG settings associated with an +#' object. +#' +#' @import digest +#' @rdname RNGstr +#' @export +#' +#' @examples +#' # compute digest hash from RNG settings +#' RNGdigest() +#' RNGdigest(1234) +#' # no validity check is performed +#' RNGdigest(2:3) +#' +RNGdigest <- function(object=getRNG()){ + + x <- object + object <- getRNG(x) + + # exit if no RNG was extracted + if( is.null(object) ){ + warning("Found no embedded RNG data in object [", class(x),"]: returned NULL digest [", digest(NULL), '].') + return(digest(NULL)) # TODO: return NULL + } + + digest(object) + +} + +#' Comparing RNG Settings +#' +#' \code{rng.equal} compares the RNG settings associated with two objects. +#' +#' These functions return \code{TRUE} if the RNG settings are identical, +#' and \code{FALSE} otherwise. +#' The comparison is made between the hashes returned by \code{RNGdigest}. +#' +#' @param x objects from which RNG settings are extracted +#' @param y object from which RNG settings are extracted +#' +#' @return \code{rng.equal} and \code{rng.equal1} return a \code{TRUE} or +#' \code{FALSE}. +#' +#' @rdname rngcmp +#' @export +rng.equal <- function(x, y){ + if( missing(y) ) + y <- getRNG() + identical(RNGdigest(x), RNGdigest(y)) +} + +#' \code{rng1.equal} tests whether two objects have identical +#' \strong{initial} RNG settings. +#' +#' @rdname rngcmp +#' @export +rng1.equal <- function(x, y){ + if( missing(y) ) + y <- getRNG() + rng.equal(getRNG1(x), getRNG1(y)) +} diff --git a/R/RNGseq.R b/R/RNGseq.R new file mode 100644 index 0000000..78f18d2 --- /dev/null +++ b/R/RNGseq.R @@ -0,0 +1,206 @@ +# Generate a sequence of RNGs suitable for parallel computation +# using L'Ecuyer's RNG +# +# Author: Renaud Gaujoux +############################################################################### + +# or-NULL operator (borrowed from Hadley Wickham) +'%||%' <- function(x, y) if( !is.null(x) ) x else y + +#' Generate Sequence of Random Streams +#' +#' Create a given number of seeds for L'Ecuyer's RNG, that can be used to seed +#' parallel computation, making them fully reproducible. +#' +#' This ensures complete reproducibility of the set of run. +#' The streams are created using L'Ecuyer's RNG, implemented in R core since +#' version 2.14.0 under the name \code{"L'Ecuyer-CMRG"} (see \code{\link{RNG}}). +#' +#' Generating a sequence without specifying a seed uses a single draw of the +#' current RNG. The generation of a sequence using seed (a single or 6-length +#' numeric) a should not affect the current RNG state. +#' +#' @param n Number of streams to be created +#' @param seed seed specification used to initialise the set of streams +#' using \code{\link{RNGseq_seed}}. +#' @param simplify a logical that specifies if sequences of length 1 should be +#' unlisted and returned as a single vector. +#' @param ... extra arguments passed to \code{\link{RNGseq_seed}}. +#' +#' @return a list of integer vectors (or a single integer vector if +#' \code{n=1} and \code{unlist=TRUE}). +#' +#' @export +#' @examples +#' +#' RNGseq(3) +#' RNGseq(3) +#' RNGseq(3, seed=123) +#' # or identically +#' set.seed(123) +#' identical(RNGseq(3), RNGseq(3, seed=123)) +#' \dontshow{ +#' set.seed(123) +#' stopifnot( identical(RNGseq(3), RNGseq(3, seed=123)) ) +#' } +#' +#' RNGseq(3, seed=1:6, verbose=TRUE) +#' # select Normal kind +#' RNGseq(3, seed=123, normal.kind="Ahrens") +#' +RNGseq <- function(n, seed=NULL, ..., simplify=TRUE, version=2){ + + library(parallel) + # check parameters + if( n <= 0 ) + stop("NMF::createStream - invalid value for 'n' [positive value expected]") + + # extract RNG setting from object if possible + if( !is.null(seed) ) seed <- getRNG(seed, num.ok=TRUE) %||% seed + + # convert matrix into a list of seed + if( is.matrix(seed) ) + seed <- lapply(seq(ncol(seed)), function(i) seed[,i]) + + # if already a sequence of seeds: use directly + #print(seed) + if( is.list(seed) ){ + # check length + if( length(seed) > n ){ + warning("Reference seed sequence is longer than the required number of seed: only using the ", n, " first seeds.") + seed <- seed[1:n] + }else if( length(seed) < n ) + stop("Reference seed sequence is shorter [",length(seed),"] than the required number of seed [", n, "].") + + res <- lapply(seed, as.integer) + }else{ # otherwise: get initial seed for the CMRG stream sequence + + orng <- RNGseed() + .s <- RNGseq_seed(seed, ..., version=version) + + res <- lapply(1:n, function(i){ + if( i == 1 ) .s + else .s <<- nextRNGStream(.s) + }) + + # if not seeded and current RNG is L'Ecuyer-CMRG => move to stream after last stream + if( is.null(seed) && RNGkind()[1L] == "L'Ecuyer-CMRG" && version>=2 ){ + # ensure old normal kind is used + RNGseed(c(orng[1L], nextRNGStream(.s)[2:7])) + } + } + + # return list or single RNG + if( n==1 && simplify ) + res[[1]] + else + res + +} + +#' \code{RNGseq_seed} generates the -- next -- random seed used as the first seed in +#' the sequence generated by \code{\link{RNGseq}}. +#' +#' @param normal.kind Type of Normal random generator. See \code{\link{RNG}}. +#' @param verbose logical to toggle verbose messages +#' @param version version of the function to use, to reproduce old behaviours. +#' Version 1 had a bug which made the generated stream sequences share most of their +#' seeds (!), as well as being not equivalent to calling \code{set.seed(seed); RNGseq_seed(NULL)}. +#' Version 2 fixes this bug. +#' +#' @return a 7-length numeric vector. +#' @seealso \code{\link{RNGseq}} +#' +#' @rdname RNGseq +#' @export +#' @examples +#' +#' ## generate a seed for RNGseq +#' # random +#' RNGseq_seed() +#' RNGseq_seed() +#' RNGseq_seed(NULL) +#' # fixed +#' RNGseq_seed(1) +#' RNGseq_seed(1:6) +#' +#' # `RNGseq_seed(1)` is identical to +#' set.seed(1) +#' s <- RNGseq_seed() +#' identical(s, RNGseq_seed(1)) +#' \dontshow{ stopifnot(identical(s, RNGseq_seed(1))) } +#' +RNGseq_seed <- function(seed=NULL, normal.kind=NULL, verbose=FALSE, version=2){ + + # retrieve current seed + orng <- RNGseed() + # setup RNG restoration in case of an error + on.exit({ + RNGseed(orng) + if( verbose ) message("# Restoring RNG: ", paste(RNGkind(), collapse=' - '), ' [', .collapse(orng), ']') + }) + + rkind_not_CMRG <- RNGkind()[1L] != "L'Ecuyer-CMRG" + + if( verbose ) message("# Original RNG: ", paste(RNGkind(), collapse=' - '), ' [', .collapse(orng), ']') + # seed with numeric seed + if( is.numeric(seed) ){ + if( length(seed) == 1L ){ + + if( verbose ) message("# Generate RNGstream random seed from ", seed, " ... ", appendLF=FALSE) + if( version<2 || rkind_not_CMRG ){ # behaviour prior 1.4 + set.seed(seed) + RNGkind(kind="L'Ecuyer-CMRG", normal.kind=normal.kind) + }else{ # fix seed after switching to CMRG: ensure result independence from the current RNG + set.seed(seed, kind="L'Ecuyer-CMRG", normal.kind=normal.kind) + } + if( verbose ) message("OK") + } + else if( length(seed) == 6L ){ + if( verbose ) message("# Directly use 6-long seed: ", paste(seed, collapse=', '), " ... ", appendLF=FALSE) + RNGkind("L'Ecuyer-CMRG", normal.kind=normal.kind) + s <- RNGseed() + s[2:7] <- as.integer(seed) + RNGseed(s) + if( verbose ) message("OK") + }else if ( length(seed) == 7L ){ + if( seed[1] %% 100 != 7L ) + stop("RNGseq_seed - Invalid 7-long numeric seed: RNG code should be '7', i.e. of type \"L'Ecuyer-CMRG\"") + if( verbose ) message("# Directly use CMRG seed: ", paste(seed, collapse=', '), " ... ", appendLF=FALSE) + RNGseed(seed) + if( verbose ) message("OK") + }else + stop("RNGseq_seed - Invalid numeric seed: should be a numeric of length 1, 6 or 7") + }else if( is.null(seed) ){ + if( rkind_not_CMRG ){ # seed with random seed + + # draw once from the current calling RNG to ensure different seeds + # for separate loops, but to ensure identical results as with set.seed + # one must still use the current RNG before changing RNG kind + runif(1) + orng1 <- RNGseed() + RNGseed(orng) + orng <- orng1 + + if( verbose ) message("# Generate random RNGstream seed: ", appendLF=FALSE) + RNGkind(kind="L'Ecuyer", normal.kind=normal.kind) + if( verbose ) message("OK") + }else{ # seed with next RNG stream + if( version < 2 ){ + on.exit() # cancel RNG restoration + s <- nextRNGStream(orng) + if( verbose ) message("# Use next active RNG stream: ", .collapse(s[2:7])) + RNGseed(s) + }else{ + # only change normal kind if necessary and use current stream state + if( !is.null(normal.kind) ) RNGkind(normal.kind=normal.kind) + if( verbose ) message("# Use current active RNG stream: ", .collapse(RNGseed()[2:7])) + } + } + }else + stop("RNGseq_seed - Invalid seed value: should be a numeric or NULL") + + s <- RNGseed() + if( verbose ) message("# Seed RNGkind is: ", paste(RNGkind(), collapse=' - '), ' [', .collapse(s), ']') + s +} diff --git a/R/format.R b/R/format.R new file mode 100644 index 0000000..5b9f620 --- /dev/null +++ b/R/format.R @@ -0,0 +1,208 @@ +# RNG formatting functions +# +# Author: Renaud Gaujouc +############################################################################### + +#' Formatting RNG Information +#' +#' These functions retrieve/prints formated information about RNGs. +#' +#' All functions can retrieve can be called with objects that are -- valid -- +#' RNG seeds or contain embedded RNG data, but none of them change the current +#' RNG setting. +#' To effectively change the current settings on should use \code{\link{setRNG}}. +#' +#' \code{RNGstr} returns a description of an RNG seed as a single character string. +#' +#' \code{RNGstr} formats seeds by collapsing them in a comma separated string. +#' By default, seeds that contain more than 7L integers, have their 3 first values +#' collapsed plus a digest hash of the complete seed. +#' +#' @param object RNG seed (i.e. an integer vector), or an object that contains +#' embedded RNG data. +#' For \code{RNGtype} this must be either a valid RNG seed or a single integer that +#' must be a valid encoded RNG kind (see \code{\link{RNGkind}}). +#' @param n maximum length for a seed to be showed in full. +#' If the seed has length greater than \code{n}, then only the first three elements +#' are shown and a digest hash of the complete seed is appended to the string. +#' +#' @return a single character string +#' +#' @export +#' @examples +#' +#' # default is a 626-long integer +#' RNGstr() +#' # what would be the seed after seeding with set.seed(1234) +#' RNGstr(1234) +#' # another RNG (short seed) +#' RNGstr(c(401L, 1L, 1L)) +#' # no validity check is performed +#' RNGstr(2:3) +#' +RNGstr <- function(object, n=7L, ...){ + + if( missing(object) ){ + rp <- RNGprovider() + rs <- getRNG() + if( rp == 'base' || length(rs) > 1L ) + object <- rs + else + return( "Unknown" ) + } + + # extract seed from object + seed <- getRNG(object, ...) + if( is.null(seed) ) 'NULL' + else if( is.numeric(seed) ){ + if( length(seed) > n ){ + paste(str_out(seed, 3L), str_c('[', digest(seed), ']')) + }else{ + str_out(seed, Inf) + } + } + else + paste(class(seed), ' [', digest(seed), ']', sep='') +} + +#' \code{RNGtype} extract the kinds of RNG and Normal RNG. +#' +#' \code{RNGtype} returns the same type of values as \code{RNGkind()} (character strings), +#' except that it can extract the RNG settings from an object. +#' If \code{object} is missing it returns the kinds of the current RNG settings, +#' i.e. it is identical to \code{RNGkind()}. +#' +#' @param provider logical that indicates if the library that provides the RNG +#' should also be returned as a third element. +#' +#' @return \code{RNGtype} returns a 2 or 3-long character vector. +#' +#' @export +#' @rdname RNGstr +#' +#' @examples +#' +#' # get RNG type +#' RNGtype() +#' RNGtype(provider=TRUE) +#' RNGtype(1:3) +#' +#' # type from encoded RNG kind +#' RNGtype(107L) +#' # this is different from the following which treats 107 as a seed for set.seed +#' RNGtype(107) +#' +RNGtype <- function(object, ..., provider=FALSE){ + + res <- + if( missing(object) ){ + RNGkind() + }else{ + old <- RNGseed() + + # extract RNG data + rng <- getRNG(object, ...) + if( is.null(rng) ){ + warning("Could not find embedded RNG data in ", deparse(substitute(object)), "." + , " Returned current type.") + } + # setup restoration + on.exit( RNGseed(old) ) + setRNG(rng) + RNGkind() + } + + # determine provider if requested + if( provider ){ + prov <- RNGprovider(res) + res <- c(res, prov) + } + # return result + res +} + +#' \code{showRNG} displays human readable information about RNG settings. +#' If \code{object} is missing it displays information about the current RNG. +#' +#' @param indent character string to use as indentation prefix in the output +#' from \code{showRNG}. +#' +#' @export +#' @rdname RNGstr +#' +#' @examples +#' showRNG() +#' # as after set.seed(1234) +#' showRNG(1234) +#' showRNG() +#' set.seed(1234) +#' showRNG() +#' # direct seeding +#' showRNG(1:3) +#' # this does not change the current RNG +#' showRNG() +#' showRNG(provider=TRUE) +#' +showRNG <- function(object=getRNG(), indent='#', ...){ + + # get kind + tryCatch(suppressMessages(info <- RNGtype(object, ...)) + , error = function(e){ + stop("Could not show RNG due to error: ", conditionMessage(e)) + } + ) + # show information + cat(indent, "RNG kind: ", paste(info[1:2], collapse=" / ") + , if( length(info) > 2L ) paste('[', info[3L], ']', sep='') + , "\n") + cat(indent, "RNG state:", RNGstr(object), "\n") +} + +#' \code{RNGinfo} is equivalent to \code{RNGtype} but returns a named +#' list instead of an unnamed character vector. +#' +#' @param ... extra arguments passed to \code{RNGtype}. +#' +#' @export +#' @rdname RNGstr +#' +#' @examples +#' # get info as a list +#' RNGinfo() +#' RNGinfo(provider=TRUE) +#' # from encoded RNG kind +#' RNGinfo(107) +#' +RNGinfo <- function(object=getRNG(), ...){ + + # get type + kind <- RNGtype(object, ...) + n <- c('kind', 'normal', 'provider') + as.list(setNames(kind, n[1:length(kind)])) + +} + + +#' Checking RNG Differences in Unit Tests +#' +#' \code{checkRNG} checks if two objects have the same RNG +#' settings and should be used in unit tests, e.g., with the \pkg{RUnit} +#' package. +#' +#' @param x,y objects from which RNG settings are extracted. +#' @param ... extra arguments passed to \code{\link{rng.equal}}. +#' +#' @export +#' @rdname uchecks +#' @examples +#' +#' # check for differences in RNG +#' set.seed(123) +#' checkRNG(123) +#' try( checkRNG(123, 123) ) +#' try( checkRNG(123, 1:3) ) +#' +checkRNG <- function(x, y=getRNG(), ...){ + requireRUnit() + checkTrue(rng.equal(x, y), ...) +} diff --git a/R/rngtools-package.r b/R/rngtools-package.r new file mode 100644 index 0000000..cc92751 --- /dev/null +++ b/R/rngtools-package.r @@ -0,0 +1,56 @@ +#' Utility functions for working with Random Number Generators +#' +#' This package contains a set of functions for working with +#' Random Number Generators (RNGs). In particular, it defines a generic +#' S4 framework for getting/setting the current RNG, or RNG data +#' that are embedded into objects for reproducibility. +#' +#' Notably, convenient default methods greatly facilitate the way current +#' RNG settings can be changed. +#' +#' @name rngtools +#' @docType package +#' +#' @import stringr +#' @import digest +#' @import methods +#' @import pkgmaker +#' +#' @examples +#' +#' showRNG() +#' s <- getRNG() +#' RNGstr(s) +#' RNGtype(s) +#' +#' # get what would be the RNG seed after set.seed +#' s <- nextRNG(1234) +#' showRNG(s) +#' showRNG( nextRNG(1234, ndraw=10) ) +#' +#' # change of RNG kind +#' showRNG() +#' k <- RNGkind() +#' k[2L] <- 'Ahrens' +#' try( RNGkind(k) ) +#' setRNG(k) +#' showRNG() +#' # set encoded kind +#' setRNG(501L) +#' showRNG() +#' +#' # use as set seed +#' setRNG(1234) +#' showRNG() +#' r <- getRNG() +#' +#' # extract embedded RNG specifications +#' runif(10) +#' setRNG(list(1, rng=1234)) +#' rng.equal(r) +#' +#' # restore default RNG (e.g., after errors) +#' RNGrecovery() +#' showRNG() +#' +NULL diff --git a/README.md b/README.md new file mode 100644 index 0000000..f0f210f --- /dev/null +++ b/README.md @@ -0,0 +1,12 @@ +rngtools +======== + +R package - Utility functions for working with Random Number Generators + +This package contains a set of functions for working with +Random Number Generators (RNGs). In particular, it defines a generic +S4 framework for getting/setting the current RNG, or RNG data +that are embedded into objects for reproducibility. + +Notably, convenient default methods greatly facilitate the way current +RNG settings can be changed. diff --git a/build/vignette.rds b/build/vignette.rds new file mode 100644 index 0000000..dd85a43 Binary files /dev/null and b/build/vignette.rds differ diff --git a/inst/doc/rngtools-unitTests.R b/inst/doc/rngtools-unitTests.R new file mode 100644 index 0000000..e66beab --- /dev/null +++ b/inst/doc/rngtools-unitTests.R @@ -0,0 +1,9 @@ + +## ----setup, include=FALSE------------------------------------------------ +pkg <- 'rngtools' +require( pkg, character.only=TRUE ) +prettyVersion <- packageDescription(pkg)$Version +prettyDate <- format(Sys.Date(), '%B %e, %Y') +authors <- packageDescription(pkg)$Author + + diff --git a/inst/doc/rngtools-unitTests.Rnw b/inst/doc/rngtools-unitTests.Rnw new file mode 100644 index 0000000..ff4e04d --- /dev/null +++ b/inst/doc/rngtools-unitTests.Rnw @@ -0,0 +1,80 @@ + +\documentclass[10pt]{article} +%\VignetteDepends{knitr} +%\VignetteIndexEntry{rngtools-unitTests} +%\VignetteCompiler{knitr} +%\VignetteEngine{knitr::knitr} +\usepackage{vmargin} +\setmargrb{0.75in}{0.75in}{0.75in}{0.75in} + +<<setup, include=FALSE>>= +pkg <- 'rngtools' +require( pkg, character.only=TRUE ) +prettyVersion <- packageDescription(pkg)$Version +prettyDate <- format(Sys.Date(), '%B %e, %Y') +authors <- packageDescription(pkg)$Author +@ + +\usepackage[colorlinks]{hyperref} +\author{\Sexpr{authors}} +\title{\texttt{\Sexpr{pkg}}: Unit testing results\footnote{Vignette computed on Thu Mar 6 11:45:50 2014}} +\date{\texttt{\Sexpr{pkg}} version \Sexpr{prettyVersion} as of \Sexpr{prettyDate}} +\begin{document} +\maketitle + +\section{Details} +\begin{verbatim} + +RUNIT TEST PROTOCOL -- Thu Mar 6 11:45:50 2014 +*********************************************** +Number of test functions: 6 +Number of errors: 0 +Number of failures: 0 + + +1 Test Suite : +package:rngtools - 6 test functions, 0 errors, 0 failures + + + +Details +*************************** +Test Suite: package:rngtools +Test function regexp: ^test. +Test file regexp: ^runit.*.[rR]$ +Involved directory: +/tmp/Rpkglib_51e6234a85cc/rngtools/tests +--------------------------- +Test file: /tmp/Rpkglib_51e6234a85cc/rngtools/tests/runit.format.r +test.RNGdigest: (30 checks) ... OK (0.01 seconds) +test.RNGtype: (22 checks) ... OK (0.01 seconds) +--------------------------- +Test file: /tmp/Rpkglib_51e6234a85cc/rngtools/tests/runit.RNG.r +test.getRNG: (18 checks) ... OK (0 seconds) +test.setRNG: (34 checks) ... OK (0.01 seconds) +--------------------------- +Test file: /tmp/Rpkglib_51e6234a85cc/rngtools/tests/runit.RNGseq.r +test.RNGseq: (51 checks) ... OK (0.01 seconds) +test.RNGseq_seed: (75 checks) ... OK (0 seconds) + +Total execution time +*************************** + user system elapsed + 0.234 0.001 0.234 + +\end{verbatim} + +\section*{Session Information} +\begin{itemize}\raggedright + \item R Under development (unstable) (2014-03-02 r65102), \verb|x86_64-unknown-linux-gnu| + \item Locale: \verb|LC_CTYPE=en_US.UTF-8|, \verb|LC_NUMERIC=C|, \verb|LC_TIME=en_US.UTF-8|, \verb|LC_COLLATE=en_US.UTF-8|, \verb|LC_MONETARY=en_US.UTF-8|, \verb|LC_MESSAGES=en_US.UTF-8|, \verb|LC_PAPER=en_US.UTF-8|, \verb|LC_NAME=C|, \verb|LC_ADDRESS=C|, \verb|LC_TELEPHONE=C|, \verb|LC_MEASUREMENT=en_US.UTF-8|, \verb|LC_IDENTIFICATION=C| + \item Base packages: base, datasets, graphics, grDevices, methods, + parallel, stats, utils + \item Other packages: pkgmaker~0.20, registry~0.2, rngtools~1.2.4, + RUnit~0.4.26, stringr~0.6.2 + \item Loaded via a namespace (and not attached): codetools~0.2-8, + digest~0.6.4, tools~3.1.0, xtable~1.7-1 +\end{itemize} + +\end{document} + diff --git a/inst/doc/rngtools-unitTests.pdf b/inst/doc/rngtools-unitTests.pdf new file mode 100644 index 0000000..15f40de Binary files /dev/null and b/inst/doc/rngtools-unitTests.pdf differ diff --git a/inst/tests/runit.RNG.r b/inst/tests/runit.RNG.r new file mode 100644 index 0000000..fddb18e --- /dev/null +++ b/inst/tests/runit.RNG.r @@ -0,0 +1,133 @@ +# Unit test for getRNG +# +# Author: Renaud Gaujoux +############################################################################### + +library(stringr) + +test.getRNG <- function(){ + + RNGkind('default', 'default') + on.exit( RNGrecovery() ) + + checker <- function(x, y, ..., msg=NULL, drawRNG=TRUE){ + + if( drawRNG ) runif(10) + fn <- getRNG + oldRNG <- RNGseed() + if( !missing(x) ){ + d <- fn(x, ...) + cl <- str_c(class(x), '(', length(x), ')') + }else{ + d <- fn() + cl <- 'MISSING' + } + newRNG <- RNGseed() + .msg <- function(x) paste(cl, ':', x, '[', msg, ']') + checkIdentical(oldRNG, newRNG, .msg("does not change RNG")) + checkIdentical(d, y, .msg("result is correct") ) + } + + set.seed(123456) + seed123456 <- .Random.seed + checker(, seed123456, msg="No arguments: returns .Random.seed", drawRNG=FALSE) + checker(123456, seed123456, msg="Single numeric argument: returns .Random.seed as it would be after setting the seed") + checker(123456, 123456, num.ok=TRUE, msg="Single numeric argument + num.ok: returns argument unchanged") + checker(.Random.seed, .Random.seed, msg="Integer seed argument: returns its argument unchanged") + checker(as.numeric(.Random.seed), .Random.seed, msg="Numeric seed argument: returns its argument as an integer vector") + checker(2:3, 2:3, msg="Integer INVALID seed vector argument: returns its argument unchanged") + checker(c(2,3), c(2L,3L), msg="Numeric INVALID seed vector argument: returns its argument as an integer vector") + checker(1L, 1L, msg="Single integer = Encoded RNG kind: returns it unchanged") + checker(1000L, 1000L, msg="Invalid single integer = Encoded RNG kind: returns it unchanged") + +} + +test.setRNG <- function(){ + + RNGkind('default', 'default') + on.exit( RNGrecovery() ) + + checker <- function(x, y, tset, drawRNG=TRUE){ + + on.exit( RNGrecovery() ) + + if( drawRNG ) runif(10) + oldRNG <- RNGseed() + d <- force(x) + newRNG <- RNGseed() + + msg <- function(x, ...) paste(tset, ':', ...) + checkTrue(!identical(oldRNG, newRNG), msg("changes RNG")) + checkIdentical(getRNG(), y, msg("RNG is correctly set") ) + checkIdentical(d, oldRNG, msg("returns old RNG") ) + } + + set.seed(123456) + refseed <- .Random.seed + checker(setRNG(123456), refseed, "Single numeric: sets current RNG with seed") + + # setting kind with a character string + set.seed(123) + RNGkind('Mar') + refseed <- .Random.seed + RNGrecovery() + set.seed(123) + checker(setRNG('Mar'), refseed, "Single character: change RNG kind", drawRNG=FALSE) + + # setting kind with a character string + set.seed(123) + RNGkind('Mar', 'Ahrens') + refseed <- .Random.seed + RNGrecovery() + set.seed(123) + checker(setRNG('Mar', 'Ahrens'), refseed, "Two character strings: change RNG kind and normal kind", drawRNG=FALSE) + RNGrecovery() + set.seed(123) + checker(setRNG(c('Mar', 'Ahrens')), refseed, "2-long character vector: change RNG kind and normal kind", drawRNG=FALSE) + + # setting kind + set.seed(123456, kind='Mar') + refseed <- .Random.seed + checker(setRNG(123456, kind='Mar'), refseed, "Single numeric + kind: change RNG kind + set seed") + + # setting Nkind + set.seed(123456, normal.kind='Ahrens') + refseed <- .Random.seed + checker(setRNG(123456, normal.kind='Ahrens'), refseed + , "Single numeric + normal.kind: change RNG normal kind + set seed") + + # setting kind and Nkind + set.seed(123456, kind='Mar', normal.kind='Ahrens') + refseed <- .Random.seed + checker(setRNG(123456, kind='Mar', normal.kind='Ahrens'), refseed + , "Single numeric + kind + normal.kind: change RNG all kinds + set seed") + + # with seed length > 1 + refseed <- as.integer(c(201, 0, 0)) + checker(setRNG(refseed), refseed, "numeric vector: directly set seed") + + refseed <- .Random.seed + checkException( setRNG(2:3), "numeric vector: throws an error if invalid value for .Random.seed") + checkIdentical( .Random.seed, refseed, ".Random.seed is not changed in case of an error in setRNG") + + oldRNG <- getRNG() + checkException(setRNG(1234L), "Error with invalid integer seed") + checkIdentical(oldRNG, getRNG(), "RNG still valid after error") + checkException(setRNG(123L), "Error with invalid RNG kind") + checkIdentical(oldRNG, getRNG(), "RNG still valid after error") + + # changes in R >= 3.0.2: invalid seeds only throw warning + if( testRversion('> 3.0.1') ){ + oldRNG <- getRNG() + checkWarning(setRNG(1234L, check = FALSE), "\\.Random\\.seed.* is not .* valid" + , "Invalid integer kind: Warning only if check = FALSE") + checkIdentical(1234L, getRNG(), "RNG has new invalid integer value") + setRNG(oldRNG) + checkWarning(setRNG(123L, check = FALSE), "\\.Random\\.seed.* is not .* valid" + , "Invalid kind: Warning only if check = FALSE") + checkIdentical(123L, getRNG(), "RNG has new invalid RNG kind") + + } + +} + diff --git a/inst/tests/runit.RNGseq.r b/inst/tests/runit.RNGseq.r new file mode 100644 index 0000000..674012e --- /dev/null +++ b/inst/tests/runit.RNGseq.r @@ -0,0 +1,162 @@ +# Unit tets for RNGseq +# +# Author: Renaud Gaujoux +############################################################################### + +library(parallel) + +test.RNGseq_seed <- function(){ + + # actual testing function + .test_loc <- function(.msg, ..., .change=FALSE){ + msg <- function(...) paste(.msg, ':', ...) + os <- RNGseed() + on.exit(RNGseed(os)) + s <- RNGseq_seed(...) + checkTrue(length(s) == 7L && s[1] %% 100 == 7L, msg("RNGseq_seed returns a value of .Random.seed for L'Ecuyer-CMRG")) + checkIdentical(RNGseed()[1], os[1], msg("RNGseq_seed does not change the type of RNG")) + + if( !.change ) checkIdentical(RNGseed(), os, msg("RNGseq_seed does not change the value of .Random.seed")) + else checkTrue( !identical(RNGseed(), os), msg("RNGseq_seed changes the value of .Random.seed")) + s + } + + # test in two RNG settings: default and L'Ecuyer + .test <- function(.msg, ..., ss=NULL, .change=FALSE, Dchange=.change, Lchange=.change){ + os <- RNGseed() + on.exit(RNGseed(os)) + + # default RNG + RNGkind('default') + if( !is.null(ss) ) set.seed(ss) + s1 <- .test_loc(paste(.msg, '- default'), ..., .change=Dchange) + + RNGkind("L'Ecuyer") + if( !is.null(ss) ) set.seed(ss) + s2 <- .test_loc(paste(.msg, "- CMRG"), ..., .change=Lchange) + + list(s1, s2) + } + + os <- RNGseed() + on.exit(RNGseed(os)) + + RNGkind('default', 'default') + + # test different arguments + s1 <- .test("seed=missing", ss=1, Dchange=TRUE, Lchange=FALSE) + runif(10) + s2 <- .test("seed=NULL", NULL, ss=1, Dchange=TRUE, Lchange=FALSE) + checkIdentical(s1, s2, "set.seed(1) + seed=missing and seed=NULL return identical results") + + # doRNG seed with single numeric + runif(10) + s3 <- .test("seed=single numeric", 1) + checkIdentical(s1[[1]], s3[[1]], "v1.4 - set.seed(1) + seed=missing and seed=1 return identical results when current RNG is NOT CMRG") + checkIdentical(s1[[2]], s3[[2]], "v1.4 - set.seed(1) + seed=missing and seed=1 return identical results when current RNG is CMRG") + checkTrue( !identical(s1[[1]], s1[[2]]), "v1.4 - set.seed(1) + seed=missing return NON identical results in different RNG settings") + checkTrue( !identical(s3[[1]], s3[[2]]), "v1.4 - seed=num return NON identical results in different RNG settings") + + # version < 1.4 +# doRNGversion("1.3.9999") + s1 <- .test("v1.3 - seed=missing", ss=1, Dchange=TRUE, Lchange=TRUE, version=1) + s3 <- .test("v1.3 - seed=single numeric", 1, version=1) + checkIdentical(s1[[1]], s3[[1]], "v1.3 - set.seed(1) + seed=missing and seed=1 return identical results when current RNG is NOT CMRG") + checkTrue( !identical(s1[[2]], s3[[2]]), "v1.3 - set.seed(1) + seed=missing and seed=1 return NON identical results when current RNG is CMRG") + checkTrue( !identical(s1[[1]], s1[[2]]), "v1.3 - set.seed(1) + seed=missing return NON identical results in different RNG settings") + checkTrue( !identical(s3[[1]], s3[[2]]), "v1.4 - seed=num return NON identical results in different RNG settings") +# doRNGversion(NULL) + ## + + .test("seed=single integer", 10L) + # directly set doRNG seed with a 6-length + .test("seed=6-length integer", 1:6) + .test("seed=6-length numeric", as.numeric(1:6)) + s <- 1:6 + checkIdentical(RNGseq_seed(s)[2:7], s, "RNGseq_seed(6-length) returns stream to the given value") + # directly set doRNG seed with a full 7-length .Random.seed + .test("seed=7-length integer", c(407L,1:6)) + .test("seed=7-length numeric", as.numeric(c(107L,1:6))) + s <- c(407L,1:6) + checkIdentical(RNGseq_seed(s), s, "RNGseq_seed(7-length) returns complete seed with the given value") + + # errors + os <- RNGseed() + checkException(RNGseq_seed(NA), "seed=NA throws an exception") + checkIdentical(os, RNGseed(), "RNGseq_seed(NA) does not change the value of .Random.seed [error]") + + # Current CMRG is L'Ecuyer + RNGkind("L'Ecuyer") + set.seed(456) + s <- RNGseed() + r <- RNGseq_seed(NULL) + checkIdentical(s, r, "Current is CMRG: seed=NULL return current stream") + runif(10) + checkIdentical(s, RNGseq_seed(456), "Current is CMRG: seed=numeric return stream seeded with value") + +} + +test.RNGseq <- function(){ + + os <- RNGseed() + on.exit(RNGseed(os)) + + # actual testing function + .test_loc <- function(.msg, n, ..., .list=TRUE, .change=FALSE){ + msg <- function(...) paste(.msg, ':', ...) + os <- RNGseed() + on.exit(RNGseed(os)) + + s <- RNGseq(n, ...) + + if( !.change ) checkIdentical(RNGseed(), os, msg("the value of .Random.seed is not changed")) + else checkTrue( !identical(RNGseed(), os), msg("the value of .Random.seed does change")) + + if( .list ) checkTrue(is.list(s), msg("result is a list")) + else{ + checkTrue(is.integer(s), msg("result is an integer vector")) + s <- list(s) + } + + checkTrue(length(s) == n, msg("result has correct length")) + checkTrue(all(sapply(s, length) == 7L), msg("each element has length 7")) + checkTrue(all(sapply(s, function(x) x[1] %% 100) == 7L), msg("each element has correct RNG kind")) + s + } + + .test <- function(msg, n, ...){ + set.seed(1) + s1 <- .test_loc(paste(msg, '- no seed'), n, ..., .change=TRUE) + runif(1) + s2 <- .test_loc(paste(msg, '- seed=1'), n, 1, ..., .change=FALSE) + #checkIdentical(s1, s2, paste(msg, " - set.seed(1) + no seed is identical to seed=1")) + .test_loc(paste(msg, '- seed=1:6'), n, 1:6, ...) + } + .test("n=1", 1, .list=FALSE) + .test("n=2", 2) + .test("n=5", 5) + + # with full list + s <- RNGseq(3) + checkIdentical(RNGseq(length(s), s), s, "If passing a complete list: returns the list itself") + s3 <- RNGseq(5) + s <- structure(s, rng=s3) + checkIdentical(RNGseq(length(s3), s), s3, "If passing a complete list in rng S3 slot: returns the complete slot") + # + + # Current RNG is CMRG + set.seed(456, "L'Ec") + s <- .Random.seed + ref <- list(s, nextRNGStream(s), nextRNGStream(nextRNGStream(s))) + rs <- RNGseq(3, 456) + checkIdentical(rs, ref, "Current RNG is CMRG: RNGseq(n, num) returns RNG streams that start with stream as set.seed") + checkIdentical(s, .Random.seed, "Current RNG is CMRG: RNGseq(n, num) did not change random seed") + + runif(10) + s <- .Random.seed + ref <- list(s, nextRNGStream(s), nextRNGStream(nextRNGStream(s))) + rs2 <- RNGseq(3) + checkIdentical(rs2, ref, "Current RNG is CMRG: RNGseq(n) returns RNG streams that start with current stream") + checkIdentical(.Random.seed, nextRNGStream(tail(rs2,1)[[1]]), "Current RNG is CMRG: RNGseq(n) changes current random seed to next stream of last stream in sequence") + +} diff --git a/inst/tests/runit.format.r b/inst/tests/runit.format.r new file mode 100644 index 0000000..7e94f91 --- /dev/null +++ b/inst/tests/runit.format.r @@ -0,0 +1,103 @@ +# Unit tests for RNG formatting functions +# +# Author: Renaud Gaujoux +############################################################################### + +library(stringr) +library(pkgmaker) + +checkFun <- function(fn, name){ + + function(x, ...){ + + oldRNG <- RNGseed() + if( !missing(x) ){ + d <- fn(x) + obj <- getRNG(x) + cl <- class(x) + }else{ + d <- fn() + obj <- getRNG() + cl <- 'MISSING' + } + newRNG <- RNGseed() + msg <- function(x, ...) paste(name, '-', cl, ':', x, '[', ..., ']') + checkIdentical(oldRNG, newRNG, msg("does not change RNG", ...)) + + # + checkTrue( isString(d), msg("result is a character string", ...)) + checkIdentical(d, fn(obj), msg("digest is from the RNG setting", ...)) + + } +} + +test.RNGdigest <- function(){ + + RNGkind('default', 'default') + on.exit( RNGrecovery() ) + + fn <- c('RNGdigest', 'RNGstr') + sapply(fn, function(f){ + fn <- getFunction(f, where='package:rngtools') + checker <- checkFun(fn, f) + + checker() + checker(1234) + checker(1:3, 'Valid seed') + checker(2:3, 'Invalid seed') + x <- list(10, rng=c(401L, 1L, 1L)) + checker(x, 'list with rng slot') + + }) + TRUE +} + +checkRNGtype <- function(x, ..., expL=2L){ + + fn <- RNGtype + oldRNG <- getRNG() + if( !missing(x) ){ + d <- fn(x) + obj <- getRNG(x) + cl <- str_c(class(x), '(', length(x), ')') + }else{ + d <- fn() + obj <- getRNG() + cl <- 'MISSING' + } + newRNG <- getRNG() + msg <- function(x, ...) paste(cl, ':', x, '[', ..., ']') + checkIdentical(oldRNG, newRNG, msg("does not change RNG", ...)) + + # + checkTrue( is.character(d), msg("result is a character vector", ...) ) + checkIdentical( length(d), expL, msg("result has correct length (", expL, ")", ...) ) + +} + +test.RNGtype <- function(){ + + RNGkind('default', 'default') + on.exit( RNGrecovery() ) + checker <- checkRNGtype + + checker() + checker(1234, 'Valid single numeric seed') + checker(1:3, 'Valid seed') + checker(402L, 'Valid encoded kind') + checkTrue( !identical(RNGtype(402), RNGtype(402L)), "Single integer and real number does not give the same result") + x <- list(10, rng=c(401L, 1L, 1L)) + checker(x, 'list with rng slot') + + # errors + oldRNG <- getRNG() + checkException(RNGtype(2:3), "Error with invalid length seed") + checkIdentical(oldRNG, getRNG(), "RNG still valid after error") + # + + oldRNG <- getRNG() + checkException(RNGtype(123L), "Error with invalid RNG kind") + checkIdentical(oldRNG, getRNG(), "RNG still valid after error") + checkException(RNGtype(1234L), "Error with invalid RNG integer") + checkIdentical(oldRNG, getRNG(), "RNG still valid after error") +} diff --git a/man/RNGseed.Rd b/man/RNGseed.Rd new file mode 100644 index 0000000..cef8b03 --- /dev/null +++ b/man/RNGseed.Rd @@ -0,0 +1,60 @@ +\name{RNGseed} +\alias{RNGrecovery} +\alias{RNGseed} +\title{Directly Getting or Setting the RNG Seed} +\usage{ + RNGseed(seed) + + RNGrecovery() +} +\arguments{ + \item{seed}{an RNG seed, i.e. an integer vector. No + validity check is performed, so it \strong{must} be a + valid seed.} +} +\value{ + invisibly the current RNG seed when called with no + arguments, or the -- old -- value of the seed before + changing it to \code{seed}. +} +\description{ + \code{RNGseed} directly gets/sets the current RNG seed + \code{.Random.seed}. It can typically be used to backup + and restore the RNG state on exit of functions, enabling + local RNG changes. + + \code{RNGrecovery} recovers from a broken state of + \code{.Random.seed}, and reset the RNG settings to + defaults. +} +\examples{ +# get current seed +RNGseed() +# directly set seed +old <- RNGseed(c(401L, 1L, 1L)) +# show old/new seed description +showRNG(old) +showRNG() + +# set bad seed +RNGseed(2:3) +try( showRNG() ) +# recover from bad state +RNGrecovery() +showRNG() + +# example of backup/restore of RNG in functions +f <- function(){ + orng <- RNGseed() + on.exit(RNGseed(orng)) + RNGkind('Marsaglia') + runif(10) +} + +sample(NA) +s <- .Random.seed +f() +identical(s, .Random.seed) +\dontshow{ stopifnot(identical(s, .Random.seed)) } +} + diff --git a/man/RNGseq.Rd b/man/RNGseq.Rd new file mode 100644 index 0000000..c9f6e62 --- /dev/null +++ b/man/RNGseq.Rd @@ -0,0 +1,95 @@ +\name{RNGseq} +\alias{RNGseq} +\alias{RNGseq_seed} +\title{Generate Sequence of Random Streams} +\usage{ + RNGseq(n, seed = NULL, ..., simplify = TRUE, version = 2) + + RNGseq_seed(seed = NULL, normal.kind = NULL, + verbose = FALSE, version = 2) +} +\arguments{ + \item{n}{Number of streams to be created} + + \item{seed}{seed specification used to initialise the set + of streams using \code{\link{RNGseq_seed}}.} + + \item{simplify}{a logical that specifies if sequences of + length 1 should be unlisted and returned as a single + vector.} + + \item{...}{extra arguments passed to + \code{\link{RNGseq_seed}}.} + + \item{normal.kind}{Type of Normal random generator. See + \code{\link{RNG}}.} + + \item{verbose}{logical to toggle verbose messages} + + \item{version}{version of the function to use, to + reproduce old behaviours. Version 1 had a bug which made + the generated stream sequences share most of their seeds + (!), as well as being not equivalent to calling + \code{set.seed(seed); RNGseq_seed(NULL)}. Version 2 fixes + this bug.} +} +\value{ + a list of integer vectors (or a single integer vector if + \code{n=1} and \code{unlist=TRUE}). + + a 7-length numeric vector. +} +\description{ + Create a given number of seeds for L'Ecuyer's RNG, that + can be used to seed parallel computation, making them + fully reproducible. + + \code{RNGseq_seed} generates the -- next -- random seed + used as the first seed in the sequence generated by + \code{\link{RNGseq}}. +} +\details{ + This ensures complete reproducibility of the set of run. + The streams are created using L'Ecuyer's RNG, implemented + in R core since version 2.14.0 under the name + \code{"L'Ecuyer-CMRG"} (see \code{\link{RNG}}). + + Generating a sequence without specifying a seed uses a + single draw of the current RNG. The generation of a + sequence using seed (a single or 6-length numeric) a + should not affect the current RNG state. +} +\examples{ +RNGseq(3) +RNGseq(3) +RNGseq(3, seed=123) +# or identically +set.seed(123) +identical(RNGseq(3), RNGseq(3, seed=123)) +\dontshow{ +set.seed(123) +stopifnot( identical(RNGseq(3), RNGseq(3, seed=123)) ) +} + +RNGseq(3, seed=1:6, verbose=TRUE) +# select Normal kind +RNGseq(3, seed=123, normal.kind="Ahrens") +## generate a seed for RNGseq +# random +RNGseq_seed() +RNGseq_seed() +RNGseq_seed(NULL) +# fixed +RNGseq_seed(1) +RNGseq_seed(1:6) + +# `RNGseq_seed(1)` is identical to +set.seed(1) +s <- RNGseq_seed() +identical(s, RNGseq_seed(1)) +\dontshow{ stopifnot(identical(s, RNGseq_seed(1))) } +} +\seealso{ + \code{\link{RNGseq}} +} + diff --git a/man/RNGstr.Rd b/man/RNGstr.Rd new file mode 100644 index 0000000..cdc975a --- /dev/null +++ b/man/RNGstr.Rd @@ -0,0 +1,121 @@ +\name{RNGstr} +\alias{RNGdigest} +\alias{RNGinfo} +\alias{RNGstr} +\alias{RNGtype} +\alias{showRNG} +\title{Formatting RNG Information} +\usage{ + RNGstr(object, n = 7L, ...) + + RNGtype(object, ..., provider = FALSE) + + showRNG(object = getRNG(), indent = "#", ...) + + RNGinfo(object = getRNG(), ...) + + RNGdigest(object = getRNG()) +} +\arguments{ + \item{object}{RNG seed (i.e. an integer vector), or an + object that contains embedded RNG data. For + \code{RNGtype} this must be either a valid RNG seed or a + single integer that must be a valid encoded RNG kind (see + \code{\link{RNGkind}}).} + + \item{n}{maximum length for a seed to be showed in full. + If the seed has length greater than \code{n}, then only + the first three elements are shown and a digest hash of + the complete seed is appended to the string.} + + \item{provider}{logical that indicates if the library + that provides the RNG should also be returned as a third + element.} + + \item{indent}{character string to use as indentation + prefix in the output from \code{showRNG}.} + + \item{...}{extra arguments passed to \code{RNGtype}.} +} +\value{ + a single character string + + \code{RNGtype} returns a 2 or 3-long character vector. +} +\description{ + These functions retrieve/prints formated information + about RNGs. + + \code{RNGtype} returns the same type of values as + \code{RNGkind()} (character strings), except that it can + extract the RNG settings from an object. If \code{object} + is missing it returns the kinds of the current RNG + settings, i.e. it is identical to \code{RNGkind()}. + + \code{showRNG} displays human readable information about + RNG settings. If \code{object} is missing it displays + information about the current RNG. + + \code{RNGinfo} is equivalent to \code{RNGtype} but + returns a named list instead of an unnamed character + vector. + + \code{RNGdigest} computes a hash from the RNG settings + associated with an object. +} +\details{ + All functions can retrieve can be called with objects + that are -- valid -- RNG seeds or contain embedded RNG + data, but none of them change the current RNG setting. To + effectively change the current settings on should use + \code{\link{setRNG}}. + + \code{RNGstr} returns a description of an RNG seed as a + single character string. + + \code{RNGstr} formats seeds by collapsing them in a comma + separated string. By default, seeds that contain more + than 7L integers, have their 3 first values collapsed + plus a digest hash of the complete seed. +} +\examples{ +# default is a 626-long integer +RNGstr() +# what would be the seed after seeding with set.seed(1234) +RNGstr(1234) +# another RNG (short seed) +RNGstr(c(401L, 1L, 1L)) +# no validity check is performed +RNGstr(2:3) +# get RNG type +RNGtype() +RNGtype(provider=TRUE) +RNGtype(1:3) + +# type from encoded RNG kind +RNGtype(107L) +# this is different from the following which treats 107 as a seed for set.seed +RNGtype(107) +showRNG() +# as after set.seed(1234) +showRNG(1234) +showRNG() +set.seed(1234) +showRNG() +# direct seeding +showRNG(1:3) +# this does not change the current RNG +showRNG() +showRNG(provider=TRUE) +# get info as a list +RNGinfo() +RNGinfo(provider=TRUE) +# from encoded RNG kind +RNGinfo(107) +# compute digest hash from RNG settings +RNGdigest() +RNGdigest(1234) +# no validity check is performed +RNGdigest(2:3) +} + diff --git a/man/rng.Rd b/man/rng.Rd new file mode 100644 index 0000000..4d5d7e6 --- /dev/null +++ b/man/rng.Rd @@ -0,0 +1,238 @@ +\docType{methods} +\name{getRNG} +\alias{getRNG} +\alias{.getRNG} +\alias{getRNG1} +\alias{getRNG1,ANY-method} +\alias{getRNG1-methods} +\alias{.getRNG,ANY-method} +\alias{.getRNG,list-method} +\alias{.getRNG-methods} +\alias{.getRNG,missing-method} +\alias{.getRNG,numeric-method} +\alias{hasRNG} +\alias{nextRNG} +\alias{setRNG} +\alias{.setRNG} +\alias{.setRNG,character-method} +\alias{.setRNG-methods} +\alias{.setRNG,numeric-method} +\title{Getting/Setting RNGs} +\usage{ + getRNG(object, ..., num.ok = FALSE, extract = TRUE, + recursive = TRUE) + + hasRNG(object) + + .getRNG(object, ...) + + getRNG1(object, ...) + + nextRNG(object, ..., ndraw = 0L) + + setRNG(object, ..., verbose = FALSE, check = TRUE) + + .setRNG(object, ...) +} +\arguments{ + \item{object}{an R object from which RNG settings can be + extracted, e.g. an integer vector containing a suitable + value for \code{.Random.seed} or embedded RNG data, e.g., + in S3/S4 slot \code{rng} or \code{rng$noise}.} + + \item{...}{extra arguments to allow extension and passed + to a suitable S4 method \code{.getRNG} or + \code{.setRNG}.} + + \item{num.ok}{logical that indicates if single numeric + (not integer) RNG data should be considered as a valid + RNG seed (\code{TRUE}) or passed to + \code{\link{set.seed}} into a proper RNG seed + (\code{FALSE}) (See details and examples).} + + \item{extract}{logical that indicates if embedded RNG + data should be looked for and extracted (\code{TRUE}) or + if the object itself should be considered as an RNG + specification.} + + \item{recursive}{logical that indicates if embedded RNG + data should be extracted recursively (\code{TRUE}) or + only once (\code{FASE}).} + + \item{ndraw}{number of draws to perform before returning + the RNG seed.} + + \item{check}{logical that indicates if only valid RNG + kinds should be accepted, or if invalid values should + just throw a warning. Note that this argument is used + only on R >= 3.0.2.} + + \item{verbose}{a logical that indicates if the new RNG + settings should be displayed.} +} +\value{ + \code{getRNG}, \code{getRNG1}, \code{nextRNG} and + \code{setRNG} usually return an integer vector of length + > 2L, like \code{\link{.Random.seed}}. + + \code{getRNG} and \code{getRNG1} return \code{NULL} if no + RNG data was found. + + \code{setRNG} invisibly returns the old RNG settings as + they were before changing them. +} +\description{ + \code{getRNG} returns the Random Number Generator (RNG) + settings used for computing an object, using a suitable + \code{.getRNG} S4 method to extract these settings. For + example, in the case of objects that result from multiple + model fits, it would return the RNG settings used to + compute the best fit. + + \code{hasRNG} tells if an object has embedded RNG data. + + \code{.getRNG} is an S4 generic that extract RNG settings + from a variety of object types. Its methods define the + workhorse functions that are called by \code{getRNG}. + + \code{getRNG1} is defined to provide separate access to + the RNG settings as they were at the very beginning of a + whole computation, which might differ from the RNG + settings returned by \code{getRNG}, that allows to + reproduce the result only. + + \code{nextRNG} returns the RNG settings as they would be + after seeding with \code{object}. + + \code{setRNG} set the current RNG with a seed, using a + suitable \code{.setRNG} method to set these settings. + + \code{.setRNG} is an S4 generic that sets the current RNG + settings, from a variety of specifications. Its methods + define the workhorse functions that are called by + \code{setRNG}. +} +\details{ + This function handles single number RNG specifications in + the following way: \describe{ \item{integers}{Return them + unchanged, considering them as encoded RNG kind + specification (see \code{\link{RNG}}). No validity check + is performed.} \item{real numbers}{If \code{num.ok=TRUE} + return them unchanged. Otherwise, consider them as + (pre-)seeds and pass them to \code{\link{set.seed}} to + get a proper RNG seed. Hence calling \code{getRNG(1234)} + is equivalent to \code{set.seed(1234); getRNG()} (See + examples). } } + + Think of a sequence of separate computations, from which + only one result is used for the result (e.g. the one that + maximises a likelihood): \code{getRNG1} would return the + RNG settings to reproduce the complete sequence of + computations, while \code{getRNG} would return the RNG + settings necessary to reproduce only the computation + whose result has maximum likelihood. +} +\section{Methods}{ + \describe{ + + \item{.getRNG}{\code{signature(object = "ANY")}: Default + method that tries to extract RNG information from + \code{object}, by looking sequentially to a slot named + \code{'rng'}, a slot named \code{'rng.seed'} or an + attribute names \code{'rng'}. + + It returns \code{NULL} if no RNG data was found. } + + \item{.getRNG}{\code{signature(object = "missing")}: + Returns the current RNG settings. } + + \item{.getRNG}{\code{signature(object = "list")}: Method + for S3 objects, that aims at reproducing the behaviour of + the function \code{getRNG} of the package \code{getRNG}. + + It sequentially looks for RNG data in elements + \code{'rng'}, \code{noise$rng} if element \code{'noise'} + exists and is a \code{list}, or in attribute + \code{'rng'}. } + + \item{.getRNG}{\code{signature(object = "numeric")}: + Method for numeric vectors, which returns the object + itself, coerced into an integer vector if necessary, as + it is assumed to already represent a value for + \code{\link{.Random.seed}}. } + + \item{getRNG1}{\code{signature(object = "ANY")}: Default + method that is identical to \code{getRNG(object, ...)}. } + + \item{.setRNG}{\code{signature(object = "character")}: + Sets the RNG to kind \code{object}, assuming is a valid + RNG kind: it is equivalent to \code{RNGkind(object, ...}. + All arguments in \code{...} are passed to + \code{\link{RNGkind}}. } + + \item{.setRNG}{\code{signature(object = "numeric")}: Sets + the RNG settings using \code{object} directly the new + value for \code{.Random.seed} or to initialise it with + \code{\link{set.seed}}. } + + } +} +\examples{ +# get current RNG settings +s <- getRNG() +head(s) +showRNG(s) + +# get RNG from a given single numeric seed +s1234 <- getRNG(1234) +head(s1234) +showRNG(s1234) +# this is identical to the RNG seed as after set.seed() +set.seed(1234) +identical(s1234, .Random.seed) +# but if num.ok=TRUE the object is returned unchanged +getRNG(1234, num.ok=TRUE) + +# single integer RNG data = encoded kind +head(getRNG(1L)) + +# embedded RNG data +s <- getRNG(list(1L, rng=1234)) +identical(s, s1234) +# test for embedded RNG data +hasRNG(1) +hasRNG( structure(1, rng=1:3) ) +hasRNG( list(1, 2, 3) ) +hasRNG( list(1, 2, 3, rng=1:3) ) +hasRNG( list(1, 2, 3, noise=list(1:3, rng=1)) ) +head(nextRNG()) +head(nextRNG(1234)) +head(nextRNG(1234, ndraw=10)) +obj <- list(x=1000, rng=123) +setRNG(obj) +rng <- getRNG() +runif(10) +set.seed(123) +rng.equal(rng) +# set RNG kind +old <- setRNG('Marsaglia') +# restore +setRNG(old) +# directly set .Random.seed +rng <- getRNG() +r <- runif(10) +setRNG(rng) +rng.equal(rng) + +# initialise from a single number (<=> set.seed) +setRNG(123) +rng <- getRNG() +runif(10) +set.seed(123) +rng.equal(rng) +} +\seealso{ + \code{\link{.Random.seed}}, \code{\link{showRNG}} +} +\keyword{methods} + diff --git a/man/rngcmp.Rd b/man/rngcmp.Rd new file mode 100644 index 0000000..073c618 --- /dev/null +++ b/man/rngcmp.Rd @@ -0,0 +1,31 @@ +\name{rng.equal} +\alias{rng1.equal} +\alias{rng.equal} +\title{Comparing RNG Settings} +\usage{ + rng.equal(x, y) + + rng1.equal(x, y) +} +\arguments{ + \item{x}{objects from which RNG settings are extracted} + + \item{y}{object from which RNG settings are extracted} +} +\value{ + \code{rng.equal} and \code{rng.equal1} return a + \code{TRUE} or \code{FALSE}. +} +\description{ + \code{rng.equal} compares the RNG settings associated + with two objects. + + \code{rng1.equal} tests whether two objects have + identical \strong{initial} RNG settings. +} +\details{ + These functions return \code{TRUE} if the RNG settings + are identical, and \code{FALSE} otherwise. The comparison + is made between the hashes returned by \code{RNGdigest}. +} + diff --git a/man/rngtools.Rd b/man/rngtools.Rd new file mode 100644 index 0000000..804da22 --- /dev/null +++ b/man/rngtools.Rd @@ -0,0 +1,53 @@ +\docType{package} +\name{rngtools} +\alias{rngtools} +\alias{rngtools-package} +\title{Utility functions for working with Random Number Generators} +\description{ + This package contains a set of functions for working with + Random Number Generators (RNGs). In particular, it + defines a generic S4 framework for getting/setting the + current RNG, or RNG data that are embedded into objects + for reproducibility. +} +\details{ + Notably, convenient default methods greatly facilitate + the way current RNG settings can be changed. +} +\examples{ +showRNG() +s <- getRNG() +RNGstr(s) +RNGtype(s) + +# get what would be the RNG seed after set.seed +s <- nextRNG(1234) +showRNG(s) +showRNG( nextRNG(1234, ndraw=10) ) + +# change of RNG kind +showRNG() +k <- RNGkind() +k[2L] <- 'Ahrens' +try( RNGkind(k) ) +setRNG(k) +showRNG() +# set encoded kind +setRNG(501L) +showRNG() + +# use as set seed +setRNG(1234) +showRNG() +r <- getRNG() + +# extract embedded RNG specifications +runif(10) +setRNG(list(1, rng=1234)) +rng.equal(r) + +# restore default RNG (e.g., after errors) +RNGrecovery() +showRNG() +} + diff --git a/man/uchecks.Rd b/man/uchecks.Rd new file mode 100644 index 0000000..0a9dd81 --- /dev/null +++ b/man/uchecks.Rd @@ -0,0 +1,26 @@ +\name{checkRNG} +\alias{checkRNG} +\title{Checking RNG Differences in Unit Tests} +\usage{ + checkRNG(x, y = getRNG(), ...) +} +\arguments{ + \item{x,y}{objects from which RNG settings are + extracted.} + + \item{...}{extra arguments passed to + \code{\link{rng.equal}}.} +} +\description{ + \code{checkRNG} checks if two objects have the same RNG + settings and should be used in unit tests, e.g., with the + \pkg{RUnit} package. +} +\examples{ +# check for differences in RNG +set.seed(123) +checkRNG(123) +try( checkRNG(123, 123) ) +try( checkRNG(123, 1:3) ) +} + diff --git a/tests/doRUnit.R b/tests/doRUnit.R new file mode 100644 index 0000000..6b7e198 --- /dev/null +++ b/tests/doRUnit.R @@ -0,0 +1,6 @@ +# Run all unit tests in installed directory unitTests +# +# Author: Renaud Gaujoux +############################################################################### + +pkgmaker::utest('package:rngtools', quiet=FALSE) diff --git a/vignettes/rngtools-unitTests.Rnw b/vignettes/rngtools-unitTests.Rnw new file mode 100644 index 0000000..ff4e04d --- /dev/null +++ b/vignettes/rngtools-unitTests.Rnw @@ -0,0 +1,80 @@ + +\documentclass[10pt]{article} +%\VignetteDepends{knitr} +%\VignetteIndexEntry{rngtools-unitTests} +%\VignetteCompiler{knitr} +%\VignetteEngine{knitr::knitr} +\usepackage{vmargin} +\setmargrb{0.75in}{0.75in}{0.75in}{0.75in} + +<<setup, include=FALSE>>= +pkg <- 'rngtools' +require( pkg, character.only=TRUE ) +prettyVersion <- packageDescription(pkg)$Version +prettyDate <- format(Sys.Date(), '%B %e, %Y') +authors <- packageDescription(pkg)$Author +@ + +\usepackage[colorlinks]{hyperref} +\author{\Sexpr{authors}} +\title{\texttt{\Sexpr{pkg}}: Unit testing results\footnote{Vignette computed on Thu Mar 6 11:45:50 2014}} +\date{\texttt{\Sexpr{pkg}} version \Sexpr{prettyVersion} as of \Sexpr{prettyDate}} +\begin{document} +\maketitle + +\section{Details} +\begin{verbatim} + +RUNIT TEST PROTOCOL -- Thu Mar 6 11:45:50 2014 +*********************************************** +Number of test functions: 6 +Number of errors: 0 +Number of failures: 0 + + +1 Test Suite : +package:rngtools - 6 test functions, 0 errors, 0 failures + + + +Details +*************************** +Test Suite: package:rngtools +Test function regexp: ^test. +Test file regexp: ^runit.*.[rR]$ +Involved directory: +/tmp/Rpkglib_51e6234a85cc/rngtools/tests +--------------------------- +Test file: /tmp/Rpkglib_51e6234a85cc/rngtools/tests/runit.format.r +test.RNGdigest: (30 checks) ... OK (0.01 seconds) +test.RNGtype: (22 checks) ... OK (0.01 seconds) +--------------------------- +Test file: /tmp/Rpkglib_51e6234a85cc/rngtools/tests/runit.RNG.r +test.getRNG: (18 checks) ... OK (0 seconds) +test.setRNG: (34 checks) ... OK (0.01 seconds) +--------------------------- +Test file: /tmp/Rpkglib_51e6234a85cc/rngtools/tests/runit.RNGseq.r +test.RNGseq: (51 checks) ... OK (0.01 seconds) +test.RNGseq_seed: (75 checks) ... OK (0 seconds) + +Total execution time +*************************** + user system elapsed + 0.234 0.001 0.234 + +\end{verbatim} + +\section*{Session Information} +\begin{itemize}\raggedright + \item R Under development (unstable) (2014-03-02 r65102), \verb|x86_64-unknown-linux-gnu| + \item Locale: \verb|LC_CTYPE=en_US.UTF-8|, \verb|LC_NUMERIC=C|, \verb|LC_TIME=en_US.UTF-8|, \verb|LC_COLLATE=en_US.UTF-8|, \verb|LC_MONETARY=en_US.UTF-8|, \verb|LC_MESSAGES=en_US.UTF-8|, \verb|LC_PAPER=en_US.UTF-8|, \verb|LC_NAME=C|, \verb|LC_ADDRESS=C|, \verb|LC_TELEPHONE=C|, \verb|LC_MEASUREMENT=en_US.UTF-8|, \verb|LC_IDENTIFICATION=C| + \item Base packages: base, datasets, graphics, grDevices, methods, + parallel, stats, utils + \item Other packages: pkgmaker~0.20, registry~0.2, rngtools~1.2.4, + RUnit~0.4.26, stringr~0.6.2 + \item Loaded via a namespace (and not attached): codetools~0.2-8, + digest~0.6.4, tools~3.1.0, xtable~1.7-1 +\end{itemize} + +\end{document} + -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-cran-rngtools.git _______________________________________________ debian-med-commit mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/debian-med-commit
