rngtools/0000755000176200001440000000000013612425042012120 5ustar liggesusersrngtools/NAMESPACE0000644000176200001440000000101413612077333013341 0ustar liggesusers# Generated by roxygen2: do not edit by hand 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) importFrom(parallel,nextRNGStream) importFrom(stats,runif) importFrom(stats,setNames) importFrom(utils,head) importFrom(utils,tail) rngtools/README.md0000644000176200001440000000124213556344245013412 0ustar liggesusers[![Build Status](https://travis-ci.org/renozao/rngtools.png?branch=master)](https://travis-ci.org/renozao/rngtools) [![codecov](https://codecov.io/gh/renozao/rngtools/branch/master/graph/badge.svg)](https://codecov.io/gh/renozao/rngtools) 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. rngtools/man/0000755000176200001440000000000013612076530012677 5ustar liggesusersrngtools/man/rngtools.Rd0000644000176200001440000000216613612076530015042 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/rngtools-package.r \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() } rngtools/man/getRNG1.Rd0000644000176200001440000000255713612076530014406 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RNG.R \docType{methods} \name{getRNG1} \alias{getRNG1} \alias{getRNG1,ANY-method} \title{Extracting RNG Settings from Computation Result Objects} \usage{ getRNG1(object, ...) \S4method{getRNG1}{ANY}(object, ...) } \arguments{ \item{object}{an R object.} \item{...}{extra arguments to allow extension.} } \description{ \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 fits, it would return the RNG settings used to compute the \emph{first} fit. } \details{ \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 maximizes 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 (by class)}{ \itemize{ \item \code{ANY}: Default method that is identical to \code{getRNG(object, ...)}. }} rngtools/man/dot-getRNG.Rd0000644000176200001440000000342713612076530015106 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RNG.R \docType{methods} \name{.getRNG} \alias{.getRNG} \alias{.getRNG,ANY-method} \alias{.getRNG,missing-method} \alias{.getRNG,list-method} \alias{.getRNG,numeric-method} \title{Getting RNG Seeds} \usage{ .getRNG(object, ...) \S4method{.getRNG}{ANY}(object, ...) \S4method{.getRNG}{missing}(object) \S4method{.getRNG}{list}(object) \S4method{.getRNG}{numeric}(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}.} } \description{ \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}. } \section{Methods (by class)}{ "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. "missing": Returns the current RNG settings. "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'}. "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}}. } rngtools/man/RNGstr.Rd0000644000176200001440000000675413612076530014361 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/format.R, R/RNG.R \name{RNGstr} \alias{RNGstr} \alias{RNGtype} \alias{showRNG} \alias{RNGinfo} \alias{RNGdigest} \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{...}{extra arguments passed to \code{RNGtype}.} \item{provider}{logical that indicates if the library that provides the RNG should also be returned as an extra element.} \item{indent}{character string to use as indentation prefix in the output from \code{showRNG}.} } \value{ a single character string \code{RNGtype} returns a named character vector containing the types of the random number generator, which correspond to the arguments accepted by \link[base:RNGkind]{base::RNGkind}. Note that starting with R 3.6, the vector has length 3, while in previous R versions it has length 2 (no sample.kind element). } \description{ These functions retrieve/prints formated information about RNGs. } \details{ All functions 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}}. } \section{Functions}{ \itemize{ \item \code{RNGstr}: returns a description of an RNG seed as a single character string. It 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. \item \code{RNGtype}: extract the kinds of RNG and Normal RNG. It 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()}. \item \code{showRNG}: displays human readable information about RNG settings. If \code{object} is missing it displays information about the current RNG. \item \code{RNGinfo}: is equivalent to \code{RNGtype} but returns a named list instead of an unnamed character vector. }} \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) } rngtools/man/RNGseed.Rd0000644000176200001440000000267313612076530014465 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RNG.R \name{RNGseed} \alias{RNGseed} \alias{RNGrecovery} \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{ These functions provide a direct access to the RNG seed object \code{.Random.seed}. } \section{Functions}{ \itemize{ \item \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. \item \code{RNGrecovery}: recovers from a broken state of \code{.Random.seed}, and reset the RNG settings to defaults. }} \examples{ #--- RNGseed --- # 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)) } } rngtools/man/rngcmp.Rd0000644000176200001440000000127013556344245014464 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RNG.R \name{rng.equal} \alias{rng.equal} \alias{rng1.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. } \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}. } rngtools/man/dot-setRNG.Rd0000644000176200001440000000300713612076530015114 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RNG.R \docType{methods} \name{.setRNG} \alias{.setRNG} \alias{.setRNG,character-method} \alias{.setRNG,numeric-method} \title{Setting RNG Seeds} \usage{ .setRNG(object, ...) \S4method{.setRNG}{character}(object, ...) \S4method{.setRNG}{numeric}(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}.} } \description{ \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}. } \section{Methods (by class)}{ "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}}. "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{ # 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) } rngtools/man/uchecks.Rd0000644000176200001440000000121113612076530014606 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/format.R \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[RUnit]{checkTrue}}.} } \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{ #--- checkRNG --- # check for differences in RNG set.seed(123) checkRNG(123) try( checkRNG(123, 123) ) try( checkRNG(123, 1:3) ) } rngtools/man/rng.Rd0000644000176200001440000000723013612076530013756 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RNG.R \name{getRNG} \alias{getRNG} \alias{hasRNG} \alias{nextRNG} \alias{setRNG} \title{Getting/Setting RNGs} \usage{ getRNG(object, ..., num.ok = FALSE, extract = TRUE, recursive = TRUE) hasRNG(object) nextRNG(object, ..., ndraw = 0L) setRNG(object, ..., verbose = FALSE, check = TRUE) } \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{verbose}{a logical that indicates if the new RNG settings should be displayed.} \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.} } \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. } \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). } } } \examples{ #--- getRNG --- # 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) #--- hasRNG --- # 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)) ) #--- nextRNG --- head(nextRNG()) head(nextRNG(1234)) head(nextRNG(1234, ndraw=10)) #--- setRNG --- obj <- list(x=1000, rng=123) setRNG(obj) rng <- getRNG() runif(10) set.seed(123) rng.equal(rng) } \seealso{ \code{\link{.Random.seed}}, \code{\link{showRNG}} } rngtools/man/RNGseq.Rd0000644000176200001440000000565713612076530014342 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/RNGseq.R \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, sample.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{...}{extra arguments passed to \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{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.} \item{normal.kind}{Type of Normal random generator passed to \link[base:RNGkind]{base::RNGkind}. See \code{\link{RNG}}.} \item{sample.kind}{Type of Discrete Uniform random generator passed to \link[base:RNGkind]{base::RNGkind}. See \code{\link{RNG}}. Note that this argument is valid for R >= 3.6.0, and an error will be thrown if one tries to use it in previous versions of R.} \item{verbose}{logical to toggle verbose messages} } \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{ These functions are used to generate independent streams of random numbers. } \section{Functions}{ \itemize{ \item \code{RNGseq}: Creates 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. \item \code{RNGseq_seed}: generates the -- next -- random seed used as the first seed in the sequence generated by \code{\link{RNGseq}}. }} \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}} } rngtools/DESCRIPTION0000644000176200001440000000206413612425042013630 0ustar liggesusersPackage: rngtools Authors@R: c(person("Renaud", "Gaujoux", email = "renozao@protonmail.com", role = c("aut", "cre")), person("Max", "Kuhn", role = "ctb")) Version: 1.5 License: GPL-3 Title: Utility Functions for Working with Random Number Generators Description: Provides a set of functions for working with Random Number Generators (RNGs). In particular, a generic S4 framework is defined 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 Encoding: UTF-8 Depends: R (>= 3.2.0), methods Imports: digest, utils, stats, parallel Suggests: covr, RUnit, testthat RoxygenNote: 7.0.2 NeedsCompilation: no Packaged: 2020-01-22 17:43:08 UTC; renaud Author: Renaud Gaujoux [aut, cre], Max Kuhn [ctb] Maintainer: Renaud Gaujoux Repository: CRAN Date/Publication: 2020-01-23 23:20:02 UTC rngtools/tests/0000755000176200001440000000000013556344245013276 5ustar liggesusersrngtools/tests/testthat/0000755000176200001440000000000013612425042015122 5ustar liggesusersrngtools/tests/testthat/test-RNGseq.r0000644000176200001440000001437013612100435017422 0ustar liggesusers# Unit tets for RNGseq # # Author: Renaud Gaujoux ############################################################################### context("RNGseq: RNG streams") test_that('RNGseq_seed', { # actual testing function .test_loc <- function(.msg, ..., .change=FALSE){ msg <- function(...) paste(.msg, ':', ...) os <- RNGseed() on.exit(RNGseed(os)) s <- RNGseq_seed(...) expect_true(length(s) == 7L && s[1] %% 100 == 7L, msg("RNGseq_seed returns a value of .Random.seed for L'Ecuyer-CMRG")) expect_identical(RNGseed()[1], os[1], msg("RNGseq_seed does not change the type of RNG")) if( !.change ) expect_identical(RNGseed(), os, msg("RNGseq_seed does not change the value of .Random.seed")) else expect_true( !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() # 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) expect_identical(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) expect_identical(s1[[1]], s3[[1]], "v1.4 - set.seed(1) + seed=missing and seed=1 return identical results when current RNG is NOT CMRG") expect_identical(s1[[2]], s3[[2]], "v1.4 - set.seed(1) + seed=missing and seed=1 return identical results when current RNG is CMRG") expect_true( !identical(s1[[1]], s1[[2]]), "v1.4 - set.seed(1) + seed=missing return NON identical results in different RNG settings") expect_true( !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) expect_identical(s1[[1]], s3[[1]], "v1.3 - set.seed(1) + seed=missing and seed=1 return identical results when current RNG is NOT CMRG") expect_true( !identical(s1[[2]], s3[[2]]), "v1.3 - set.seed(1) + seed=missing and seed=1 return NON identical results when current RNG is CMRG") expect_true( !identical(s1[[1]], s1[[2]]), "v1.3 - set.seed(1) + seed=missing return NON identical results in different RNG settings") expect_true( !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 expect_identical(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) expect_identical(RNGseq_seed(s), s, "RNGseq_seed(7-length) returns complete seed with the given value") # errors os <- RNGseed() expect_error(RNGseq_seed(NA), info = "seed=NA throws an exception") expect_identical(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) expect_identical(s, r, "Current is CMRG: seed=NULL return current stream") runif(10) expect_identical(s, RNGseq_seed(456), "Current is CMRG: seed=numeric return stream seeded with value") }) test_that('RNGseq', { 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 ) expect_identical(RNGseed(), os, msg("the value of .Random.seed is not changed")) else expect_true( !identical(RNGseed(), os), msg("the value of .Random.seed does change")) if( .list ) expect_true(is.list(s), msg("result is a list")) else{ expect_true(is.integer(s), msg("result is an integer vector")) s <- list(s) } expect_true(length(s) == n, msg("result has correct length")) expect_true(all(sapply(s, length) == 7L), msg("each element has length 7")) expect_true(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) #expect_identical(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) expect_identical(RNGseq(length(s), s), s, "If passing a complete list: returns the list itself") s3 <- RNGseq(5) s <- structure(s, rng=s3) expect_identical(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) expect_identical(rs, ref, "Current RNG is CMRG: RNGseq(n, num) returns RNG streams that start with stream as set.seed") expect_identical(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) expect_identical(rs2, ref, "Current RNG is CMRG: RNGseq(n) returns RNG streams that start with current stream") expect_identical(.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") }) rngtools/tests/testthat/test-format.R0000644000176200001440000000621013612100436017506 0ustar liggesusers# Unit test # # Author: Renaud Gaujoux (edited by Max Kuhn) # Created: 01 May 2018 # Copyright: Cytoreason (2017) ############################################################################### context("Formatting functions") library(utils) # RUnit-testthat bridge checkIdentical <- function(x, y, msg){ expect_identical(x, y, info = msg) } checkTrue <- function(x, y, msg){ expect_true(x, info = msg) } ## 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, '[', ..., ']') expect_identical(oldRNG, newRNG, info = msg("does not change RNG", ...)) # expect_true( isString(d), info = msg("result is a character string", ...)) expect_identical(d, fn(obj), info = msg("digest is from the RNG setting", ...)) } } test_that('RNGdigest and RNGstr', { RNGkind_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 }) # Note: in R 3.6, RNGkind returns a vector of length 3 (vs 2 in previous versions) # Here we set the expected default length according to the runtime version checkRNGtype <- function(x, ..., expL = .RNGkind_length()){ fn <- RNGtype oldRNG <- getRNG() if( !missing(x) ){ d <- fn(x) obj <- getRNG(x) cl <- paste0(class(x), '(', length(x), ')') }else{ d <- fn() obj <- getRNG() cl <- 'MISSING' } newRNG <- getRNG() msg <- function(x, ...) paste(cl, ':', x, '[', ..., ']') expect_identical(oldRNG, newRNG, info = msg("does not change RNG", ...)) # expect_true( is.character(d), msg("result is a character vector", ...) ) expect_identical( length(d), expL, info = msg("result has correct length (", expL, ")", ...) ) } test_that('RNGtype', { 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') expect_true( !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() expect_error(RNGtype(2:3), info = "Error with invalid length seed") expect_identical(oldRNG, getRNG(), info = "RNG still valid after error") # oldRNG <- getRNG() expect_error(RNGtype(123L), info = "Error with invalid RNG kind") expect_identical(oldRNG, getRNG(), info = "RNG still valid after error") expect_error(RNGtype(1234L), info = "Error with invalid RNG integer") expect_identical(oldRNG, getRNG(), info = "RNG still valid after error") }) rngtools/tests/testthat/test-RNG.r0000644000176200001440000001142113612100437016705 0ustar liggesusers# Unit test for getRNG # # Author: Renaud Gaujoux ############################################################################### context("Get/Set RNG") test_that('getRNG', { RNGkind_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 <- paste0(class(x), '(', length(x), ')') }else{ d <- fn() cl <- 'MISSING' } newRNG <- RNGseed() .msg <- function(x) paste(cl, ':', x, '[', msg, ']') expect_identical(oldRNG, newRNG, .msg("does not change RNG")) expect_identical(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_that('setRNG', { RNGkind_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, ':', ...) expect_true(!identical(oldRNG, newRNG), msg("changes RNG")) expect_identical(getRNG(), y, msg("RNG is correctly set") ) expect_identical(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 expect_error( setRNG(2:3), info = "numeric vector: throws an error if invalid value for .Random.seed") expect_identical( .Random.seed, refseed, ".Random.seed is not changed in case of an error in setRNG") oldRNG <- getRNG() expect_error(setRNG(1234L), info = "Error with invalid integer seed") expect_identical(oldRNG, getRNG(), "RNG still valid after error") expect_error(setRNG(123L), info = "Error with invalid RNG kind") expect_identical(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() expect_warning(setRNG(1234L, check = FALSE), "\\.Random\\.seed.* is not .* valid" , info = "Invalid integer kind: Warning only if check = FALSE") expect_identical(1234L, getRNG(), "RNG has new invalid integer value") setRNG(oldRNG) expect_warning(setRNG(123L, check = FALSE), "\\.Random\\.seed.* is not .* valid" , info = "Invalid kind: Warning only if check = FALSE") expect_identical(123L, getRNG(), "RNG has new invalid RNG kind") } }) rngtools/tests/testthat.R0000755000176200001440000000045113556344245015264 0ustar liggesuserslibrary(testthat) library(rngtools) test_check("rngtools") # test that everything works fine when the RNG version is set on backward-compatibility mode if( utils::compareVersion(paste0(R.version$major, ".", R.version$minor), "3.6.0") >= 0 ){ RNGversion("3.5.0") test_check("rngtools") } rngtools/R/0000755000176200001440000000000013612074611012323 5ustar liggesusersrngtools/R/RNGseq.R0000644000176200001440000002033313556344245013620 0ustar liggesusers# 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 #' #' These functions are used to generate independent streams of random numbers. #' @name RNGseq NULL #' @describeIn RNGseq Creates 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}). #' #' @importFrom parallel nextRNGStream #' @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){ # 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 } # internal wrapper to handle the changes introduced in R 3.6 RNGkind <- function(kind = NULL, normal.kind = NULL, sample.kind = NULL, ..., strict = TRUE){ if( !nargs() ) base::RNGkind() else if( testRversion("<3.6.0") ){ if( !is.null(sample.kind) && strict ) stop(sprintf("Invalid RNGkind call: argument sample.kind is only supported in R >= 3.6.0 [current version: %s]", Rversion())) base::RNGkind(kind = kind, normal.kind = normal.kind, ...) }else base::RNGkind(kind = kind, normal.kind = normal.kind, sample.kind = sample.kind, ...) } RNGkind_default <- function(){ RNGkind(kind = "default", normal.kind = "default", sample.kind = "default", strict = FALSE) } #' @describeIn RNGseq 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 passed to [base::RNGkind]. See \code{\link{RNG}}. #' @param sample.kind Type of Discrete Uniform random generator passed to [base::RNGkind]. See \code{\link{RNG}}. #' Note that this argument is valid for R >= 3.6.0, and an error will be thrown if one tries to use it in previous #' versions of R. #' @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}} #' #' @importFrom stats runif #' @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, sample.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, sample.kind = sample.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, sample.kind = sample.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, sample.kind = sample.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) || !is.null(sample.kind) ) RNGkind(normal.kind=normal.kind, sample.kind = sample.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 } rngtools/R/utils.R0000644000176200001440000000602413612103514013603 0ustar liggesusers # from pkgmaker 0.30 isNumber <- function(x){ is.numeric(x) && length(x) == 1 } # from pkgmaker 0.30 isReal <- function(x){ isNumber(x) && !is.integer(x) } # from pkgmaker 0.30 isInteger <- function(x){ is.integer(x) && length(x) == 1 } # adapted from pkgmaker 0.30 testRversion <- function(x, test=1L){ # emulate stringr functions str_trim <- function(x) sub("^ *(.*[^ ]) *$", "\\1", x) str_match <- function(x, pattern, n){ r <- regexpr(pattern, x, perl = TRUE) start <- attr(r, "capture.start") len <- attr(r, "capture.length") res <- sapply(seq(nrow(start)), FUN = function(i){ s <- start[i, ] if( s[1L] < 0 ) return(rep(NA_character_, length(s) + 1L)) hit <- sapply(seq_along(s), function(j){ s <- s[j] substr(x[i], s, s + len[i, j] - 1L) }) c(x[i], hit) }) t(res) } ## rv <- Rversion() op <- '==' if( grepl("^[=<>]", str_trim(x)) ){ m <- str_match(x, "^([<>=]=?)(.*)") if( is.na(m[, 1]) ) stop('Invalid version specification: ', x) op <- m[, 2] if( op == '=' ) op <- '==' x <- str_trim(m[, 3L]) if( !missing(test) ) warning("Ignoring argument `test`: comparison operator was passed in argument `x`") test <- 0L } do.call(op, list(utils::compareVersion(rv, x), test)) } # from pkgmaker 0.30 is_NA <- function(x){ is.atomic(x) && length(x) == 1L && is.na(x) # x <- unname(x) # identical(x, NA) || identical(x, as.character(NA)) || identical(x, as.numeric(NA)) || identical(x, as.integer(NA)) } # from pkgmaker 0.30 Rversion <- function(){ paste(R.version$major, R.version$minor, sep='.') } # from pkgmaker 0.30 str_out <- function(x, max=3L, quote=is.character(x), use.names=FALSE, sep=", ", total = FALSE){ if( is_NA(max) ) max <- Inf suffix <- NULL nTotal <- length(x) if( max > 2 && length(x) > max ){ suffix <- "..." x <- c(head(x, max-1), tail(x, 1)) } x <- head(x, max) # add quotes if necessary quote <- if( isTRUE(quote) ) "'" else if( is.character(quote) ) quote if( !is.null(quote) ) x <- unlist(lapply(x, function(v) paste(quote,v,quote, sep=''))) else if( all(sapply(x, isInteger)) ) x <- unlist(lapply(x, function(v) paste0(v,'L'))) # add names if necessary if( use.names && !is.null(names(x)) ){ nm <- paste0(names(x),'=') x <- paste(ifelse(nm=='=','',nm), x, sep='') } # insert suffix if( !is.null(suffix) ){ x <- c(head(x, length(x)-1L), suffix, tail(x, 1L)) } s <- paste(paste(x, collapse=sep), sep='') if( total ) s <- paste0(s, ' (', format(nTotal, big.mark=",", scientific=F), ' total)') # return formatted string s } # from pkgmaker 0.30 isString <- function (x, y, ignore.case = FALSE) { if (res <- is.character(x) && length(x) == 1L) { if (!missing(y)) { if (!isString(y)) stop("Invalid argument 'y': must be a string itself.") if (ignore.case) { x <- toupper(x) y <- toupper(y) } res <- x == y } } res } rngtools/R/rngtools-package.r0000644000176200001440000000221313612100432015733 0ustar liggesusers#' 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 digest #' @import methods #' #' @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 rngtools/R/RNG.R0000644000176200001440000004721513556344245013117 0ustar liggesusers# 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 ############################################################################### ###% 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. ###% #' @importFrom utils tail 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 #' #' These functions provide a direct access to the RNG seed object `.Random.seed`. #' #' @name RNGseed NULL #' @describeIn 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) } #' @describeIn RNGseed recovers from a broken state of \code{.Random.seed}, #' and reset the RNG settings to defaults. #' #' @export RNGrecovery <- function(){ s <- as.integer(c(401,0,0)) assign(".Random.seed", s, envir=.GlobalEnv) do.call(RNGkind, as.list(rep("default", .RNGkind_length()))) } .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)) } #' Getting RNG Seeds #' #' \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}. #' #' @inheritParams getRNG #' @export setGeneric('.getRNG', function(object, ...) standardGeneric('.getRNG') ) #' @describeIn .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) } ) #' @describeIn .getRNG 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) ) } ) #' @describeIn .getRNG 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 # } #) #' @describeIn .getRNG 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) } ) #' Extracting RNG Settings from Computation Result Objects #' #' \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 fits, 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 maximizes 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. #' #' @param object an R object. #' @param ... extra arguments to allow extension. #' #' @export setGeneric('getRNG1', function(object, ...) standardGeneric('getRNG1') ) #' @describeIn 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 } #' @importFrom utils head .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 verbose a logical that indicates if the new RNG settings should #' be displayed. #' #' @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) } #' Setting RNG Seeds #' #' \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}. #' #' @inheritParams setRNG #' @export setGeneric('.setRNG', function(object, ...) standardGeneric('.setRNG') ) #' @describeIn .setRNG Sets the RNG to the kind(s) specified in \code{object}. #' If object is a single string that is a valid RNG kind, then this method is equivalent to \code{RNGkind(object, ...}. #' Otherwise, each element is assumed to be a valid argument for [RNGkind]. #' Note that this latter case the names of `object`, if any, are used as argument names in the call to [RNGkind]. #' #' @examples #' # set RNG kind #' old <- setRNG('Marsaglia') #' # restore #' setRNG(old) setMethod('.setRNG', 'character', function(object, ...){ if( length(object) == 1L ) RNGkind(kind=object, ...) else{ n0 <- .RNGkind_length() if( length(object) > n0 ){ warning("RNG character specification is too long: discarding elements ", paste0(tail(object, -n0), collapse = ", ")) } do.call(RNGkind, as.list(head(object, n0))) } } ) #' @describeIn .setRNG 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)) } rngtools/R/format.R0000644000176200001440000001411613612100344013732 0ustar liggesusers# RNG formatting functions # # Author: Renaud Gaujouc ############################################################################### #' Formatting RNG Information #' #' These functions retrieve/prints formated information about RNGs. #' #' All functions 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}}. #' #' @name RNGstr NULL #' @describeIn RNGstr returns a description of an RNG seed as a single character string. #' #' It 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), paste0('[', digest(seed), ']')) }else{ str_out(seed, Inf) } } else paste(class(seed), ' [', digest(seed), ']', sep='') } #' @describeIn RNGstr extract the kinds of RNG and Normal RNG. #' #' It 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 an extra element. #' #' @return \code{RNGtype} returns a named character vector containing the types of the random number generator, which correspond #' to the arguments accepted by [base::RNGkind]. #' Note that starting with R 3.6, the vector has length 3, while in previous R versions it has length 2 (no sample.kind element). #' #' @export #' @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() } # set RNGkind parameter names each element names(res) <- c("kind", "normal.kind", "sample.kind")[1:length(res)] # determine provider if requested if( provider ){ prov <- RNGprovider(res) res <- c(res, provider = prov) } # return result res } # Returns the length of RNGkind output # This is used in a few places to dynamically adapt to the changes in RNGkind output that were introduced in R 3.6 .RNGkind_length <- function(){ length(RNGkind()) } #' @describeIn RNGstr 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 #' @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 n0 <- .RNGkind_length() cat(indent, "RNG kind: ", paste(info[1:n0], collapse=" / ") , if( length(info) > n0 ) paste('[', paste0(tail(info, -n0), collapse = ", "), ']', sep='') , "\n") cat(indent, "RNG state:", RNGstr(object), "\n") } #' @describeIn RNGstr is equivalent to \code{RNGtype} but returns a named #' list instead of an unnamed character vector. #' #' @param ... extra arguments passed to \code{RNGtype}. #' #' @importFrom stats setNames #' @export #' @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, ...) as.list(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[RUnit]{checkTrue}}. #' #' @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(), ...){ if( !requireNamespace('RUnit') ){ stop("Missing Suggests dependency: package 'RUnit' is required to check RNG in unit tests.") } RUnit::checkTrue(rng.equal(x, y), ...) } rngtools/MD50000644000176200001440000000210413612425042012425 0ustar liggesusersca6fc4b011cbb5126ff281b089ab0c95 *DESCRIPTION 9fcd1a7ad06dc43b072a98d47665e0d7 *NAMESPACE a8e94277bf108d4ea71ec413cbe91aa4 *R/RNG.R 6f389acf73a6a632b7e2a0918004febd *R/RNGseq.R 2e45d90d8242367b5aa8747af104e927 *R/format.R 14798518784acfe5cc5a9b2eb16065df *R/rngtools-package.r 83ed54171c5855ad4da6308841111cc9 *R/utils.R ebd079934624c564e23420f2a6826fce *README.md 47188140a636c927cebdfabc08a3e051 *man/RNGseed.Rd ef1e7580ac857085d6ae212e630f7bd5 *man/RNGseq.Rd ec5bd23fe2b51bcbe830937772bdb642 *man/RNGstr.Rd f492f22f4fa8c89a638e0c2aaa7dd6c7 *man/dot-getRNG.Rd ef56c220057eb4f908272cd01099de2b *man/dot-setRNG.Rd e9d2f123dc2a0dfc756c470223999e0f *man/getRNG1.Rd 55b42f21e7d122ea22666b2983db06d6 *man/rng.Rd 1209f318e2b7c6dba158b402b4f5a4e0 *man/rngcmp.Rd ecfe5bc1a7593c9c504e613d0b4eaf67 *man/rngtools.Rd e0c5291d3c54be17c5f35cf094d64629 *man/uchecks.Rd 497184d2d2283f9fe133b686aaa9211f *tests/testthat.R 421efb947dab4efd26e6938d73328a0f *tests/testthat/test-RNG.r 48b2f7a75b1d164229cc43c0072347d1 *tests/testthat/test-RNGseq.r 1597eb803714bf6bd42346aa7ee07ebe *tests/testthat/test-format.R