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