1# RNG formatting functions 2# 3# Author: Renaud Gaujouc 4############################################################################### 5 6#' Formatting RNG Information 7#' 8#' These functions retrieve/prints formated information about RNGs. 9#' 10#' All functions can be called with objects that are -- valid -- 11#' RNG seeds or contain embedded RNG data, but none of them change the current 12#' RNG setting. 13#' To effectively change the current settings on should use \code{\link{setRNG}}. 14#' 15#' @name RNGstr 16NULL 17 18#' @describeIn RNGstr returns a description of an RNG seed as a single character string. 19#' 20#' It formats seeds by collapsing them in a comma separated string. 21#' By default, seeds that contain more than 7L integers, have their 3 first values 22#' collapsed plus a digest hash of the complete seed. 23#' 24#' @param object RNG seed (i.e. an integer vector), or an object that contains 25#' embedded RNG data. 26#' For \code{RNGtype} this must be either a valid RNG seed or a single integer that 27#' must be a valid encoded RNG kind (see \code{\link{RNGkind}}). 28#' @param n maximum length for a seed to be showed in full. 29#' If the seed has length greater than \code{n}, then only the first three elements 30#' are shown and a digest hash of the complete seed is appended to the string. 31#' 32#' @return a single character string 33#' 34#' @export 35#' @examples 36#' 37#' # default is a 626-long integer 38#' RNGstr() 39#' # what would be the seed after seeding with set.seed(1234) 40#' RNGstr(1234) 41#' # another RNG (short seed) 42#' RNGstr(c(401L, 1L, 1L)) 43#' # no validity check is performed 44#' RNGstr(2:3) 45#' 46RNGstr <- function(object, n=7L, ...){ 47 48 if( missing(object) ){ 49 rp <- RNGprovider() 50 rs <- getRNG() 51 if( rp == 'base' || length(rs) > 1L ) 52 object <- rs 53 else 54 return( "Unknown" ) 55 } 56 57 # extract seed from object 58 seed <- getRNG(object, ...) 59 if( is.null(seed) ) 'NULL' 60 else if( is.numeric(seed) ){ 61 if( length(seed) > n ){ 62 paste(str_out(seed, 3L), paste0('[', digest(seed), ']')) 63 }else{ 64 str_out(seed, Inf) 65 } 66 } 67 else 68 paste(class(seed), ' [', digest(seed), ']', sep='') 69} 70 71#' @describeIn RNGstr extract the kinds of RNG and Normal RNG. 72#' 73#' It returns the same type of values as \code{RNGkind()} (character strings), 74#' except that it can extract the RNG settings from an object. 75#' If \code{object} is missing it returns the kinds of the current RNG settings, 76#' i.e. it is identical to \code{RNGkind()}. 77#' 78#' @param provider logical that indicates if the library that provides the RNG 79#' should also be returned as an extra element. 80#' 81#' @return \code{RNGtype} returns a named character vector containing the types of the random number generator, which correspond 82#' to the arguments accepted by [base::RNGkind]. 83#' 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). 84#' 85#' @export 86#' @examples 87#' 88#' # get RNG type 89#' RNGtype() 90#' RNGtype(provider=TRUE) 91#' RNGtype(1:3) 92#' 93#' # type from encoded RNG kind 94#' RNGtype(107L) 95#' # this is different from the following which treats 107 as a seed for set.seed 96#' RNGtype(107) 97#' 98RNGtype <- function(object, ..., provider=FALSE){ 99 100 res <- 101 if( missing(object) ){ 102 RNGkind() 103 }else{ 104 old <- RNGseed() 105 106 # extract RNG data 107 rng <- getRNG(object, ...) 108 if( is.null(rng) ){ 109 warning("Could not find embedded RNG data in ", deparse(substitute(object)), "." 110 , " Returned current type.") 111 } 112 # setup restoration 113 on.exit( RNGseed(old) ) 114 setRNG(rng) 115 RNGkind() 116 } 117 # set RNGkind parameter names each element 118 names(res) <- c("kind", "normal.kind", "sample.kind")[1:length(res)] 119 120 # determine provider if requested 121 if( provider ){ 122 prov <- RNGprovider(res) 123 res <- c(res, provider = prov) 124 } 125 # return result 126 res 127} 128 129 130# Returns the length of RNGkind output 131# This is used in a few places to dynamically adapt to the changes in RNGkind output that were introduced in R 3.6 132.RNGkind_length <- function(){ 133 length(RNGkind()) 134 135} 136 137#' @describeIn RNGstr displays human readable information about RNG settings. 138#' If \code{object} is missing it displays information about the current RNG. 139#' 140#' @param indent character string to use as indentation prefix in the output 141#' from \code{showRNG}. 142#' 143#' @export 144#' @examples 145#' showRNG() 146#' # as after set.seed(1234) 147#' showRNG(1234) 148#' showRNG() 149#' set.seed(1234) 150#' showRNG() 151#' # direct seeding 152#' showRNG(1:3) 153#' # this does not change the current RNG 154#' showRNG() 155#' showRNG(provider=TRUE) 156#' 157showRNG <- function(object=getRNG(), indent='#', ...){ 158 159 # get kind 160 tryCatch(suppressMessages(info <- RNGtype(object, ...)) 161 , error = function(e){ 162 stop("Could not show RNG due to error: ", conditionMessage(e)) 163 } 164 ) 165 # show information 166 n0 <- .RNGkind_length() 167 cat(indent, "RNG kind: ", paste(info[1:n0], collapse=" / ") 168 , if( length(info) > n0 ) paste('[', paste0(tail(info, -n0), collapse = ", "), ']', sep='') 169 , "\n") 170 cat(indent, "RNG state:", RNGstr(object), "\n") 171} 172 173#' @describeIn RNGstr is equivalent to \code{RNGtype} but returns a named 174#' list instead of an unnamed character vector. 175#' 176#' @param ... extra arguments passed to \code{RNGtype}. 177#' 178#' @importFrom stats setNames 179#' @export 180#' @examples 181#' # get info as a list 182#' RNGinfo() 183#' RNGinfo(provider=TRUE) 184#' # from encoded RNG kind 185#' RNGinfo(107) 186#' 187RNGinfo <- function(object=getRNG(), ...){ 188 189 # get type 190 kind <- RNGtype(object, ...) 191 as.list(kind) 192 193} 194 195 196#' Checking RNG Differences in Unit Tests 197#' 198#' \code{checkRNG} checks if two objects have the same RNG 199#' settings and should be used in unit tests, e.g., with the \pkg{RUnit} 200#' package. 201#' 202#' @param x,y objects from which RNG settings are extracted. 203#' @param ... extra arguments passed to \code{\link[RUnit]{checkTrue}}. 204#' 205#' @export 206#' @rdname uchecks 207#' @examples 208#' 209#' # check for differences in RNG 210#' set.seed(123) 211#' checkRNG(123) 212#' try( checkRNG(123, 123) ) 213#' try( checkRNG(123, 1:3) ) 214#' 215checkRNG <- function(x, y=getRNG(), ...){ 216 if( !requireNamespace('RUnit') ){ 217 stop("Missing Suggests dependency: package 'RUnit' is required to check RNG in unit tests.") 218 219 } 220 RUnit::checkTrue(rng.equal(x, y), ...) 221 222} 223