1# Unit test for getRNG
2#
3# Author: Renaud Gaujoux
4###############################################################################
5
6context("Get/Set RNG")
7
8test_that('getRNG', {
9
10	RNGkind_default()
11	on.exit( RNGrecovery() )
12
13	checker <- function(x, y, ..., msg=NULL, drawRNG=TRUE){
14
15		if( drawRNG ) runif(10)
16		fn <- getRNG
17		oldRNG <- RNGseed()
18		if( !missing(x) ){
19			d <- fn(x, ...)
20			cl <- paste0(class(x), '(', length(x), ')')
21		}else{
22			d <- fn()
23			cl <- 'MISSING'
24		}
25		newRNG <- RNGseed()
26		.msg <- function(x) paste(cl, ':', x, '[', msg, ']')
27		expect_identical(oldRNG, newRNG, .msg("does not change RNG"))
28    expect_identical(d, y, .msg("result is correct") )
29	}
30
31	set.seed(123456)
32	seed123456 <- .Random.seed
33	checker(, seed123456, msg="No arguments: returns .Random.seed", drawRNG=FALSE)
34	checker(123456, seed123456, msg="Single numeric argument: returns .Random.seed as it would be after setting the seed")
35	checker(123456, 123456, num.ok=TRUE, msg="Single numeric argument + num.ok: returns argument unchanged")
36	checker(.Random.seed, .Random.seed, msg="Integer seed argument: returns its argument unchanged")
37	checker(as.numeric(.Random.seed), .Random.seed, msg="Numeric seed argument: returns its argument as an integer vector")
38	checker(2:3, 2:3, msg="Integer INVALID seed vector argument: returns its argument unchanged")
39	checker(c(2,3), c(2L,3L), msg="Numeric INVALID seed vector argument: returns its argument as an integer vector")
40	checker(1L, 1L, msg="Single integer = Encoded RNG kind: returns it unchanged")
41	checker(1000L, 1000L, msg="Invalid single integer = Encoded RNG kind: returns it unchanged")
42
43})
44
45test_that('setRNG', {
46
47	RNGkind_default()
48	on.exit( RNGrecovery() )
49
50	checker <- function(x, y, tset, drawRNG=TRUE){
51
52		on.exit( RNGrecovery() )
53
54		if( drawRNG ) runif(10)
55		oldRNG <- RNGseed()
56		d <- force(x)
57		newRNG <- RNGseed()
58
59		msg <- function(x, ...) paste(tset, ':', ...)
60		expect_true(!identical(oldRNG, newRNG), msg("changes RNG"))
61    expect_identical(getRNG(), y, msg("RNG is correctly set") )
62    expect_identical(d, oldRNG, msg("returns old RNG") )
63	}
64
65	set.seed(123456)
66	refseed <- .Random.seed
67	checker(setRNG(123456), refseed, "Single numeric: sets current RNG with seed")
68
69	# setting kind with a character string
70	set.seed(123)
71	RNGkind('Mar')
72	refseed <- .Random.seed
73	RNGrecovery()
74	set.seed(123)
75	checker(setRNG('Mar'), refseed, "Single character: change RNG kind", drawRNG=FALSE)
76
77	# setting kind with a character string
78	set.seed(123)
79	RNGkind('Mar', 'Ahrens')
80	refseed <- .Random.seed
81	RNGrecovery()
82	set.seed(123)
83	checker(setRNG('Mar', 'Ahrens'), refseed, "Two character strings: change RNG kind and normal kind", drawRNG=FALSE)
84	RNGrecovery()
85	set.seed(123)
86	checker(setRNG(c('Mar', 'Ahrens')), refseed, "2-long character vector: change RNG kind and normal kind", drawRNG=FALSE)
87
88	# setting kind
89	set.seed(123456, kind='Mar')
90	refseed <- .Random.seed
91	checker(setRNG(123456, kind='Mar'), refseed, "Single numeric + kind: change RNG kind + set seed")
92
93	# setting Nkind
94	set.seed(123456, normal.kind='Ahrens')
95	refseed <- .Random.seed
96	checker(setRNG(123456, normal.kind='Ahrens'), refseed
97				, "Single numeric + normal.kind: change RNG normal kind + set seed")
98
99	# setting kind and Nkind
100	set.seed(123456, kind='Mar', normal.kind='Ahrens')
101	refseed <- .Random.seed
102	checker(setRNG(123456, kind='Mar', normal.kind='Ahrens'), refseed
103			, "Single numeric + kind + normal.kind: change RNG all kinds + set seed")
104
105	# with seed length > 1
106	refseed <- as.integer(c(201, 0, 0))
107	checker(setRNG(refseed), refseed, "numeric vector: directly set seed")
108
109	refseed <- .Random.seed
110	expect_error( setRNG(2:3), info = "numeric vector: throws an error if invalid value for .Random.seed")
111  expect_identical( .Random.seed, refseed, ".Random.seed is not changed in case of an error in setRNG")
112
113    oldRNG <- getRNG()
114    expect_error(setRNG(1234L), info = "Error with invalid integer seed")
115    expect_identical(oldRNG, getRNG(), "RNG still valid after error")
116    expect_error(setRNG(123L), info = "Error with invalid RNG kind")
117    expect_identical(oldRNG, getRNG(), "RNG still valid after error")
118
119    # changes in R >= 3.0.2: invalid seeds only throw warning
120    if( testRversion('> 3.0.1') ){
121        oldRNG <- getRNG()
122        expect_warning(setRNG(1234L, check = FALSE), "\\.Random\\.seed.* is not .* valid"
123                        , info = "Invalid integer kind: Warning if check = FALSE")
124        expect_identical(oldRNG, getRNG(), "RNG keep old value")
125        RNGrecovery()
126        oldRNG <- getRNG()
127        expect_warning(setRNG(123L, check = FALSE), "\\.Random\\.seed.* is not .* valid"
128                        , info = "Invalid kind: Warning if check = FALSE")
129        expect_identical(oldRNG, getRNG(), "RNG keep old value")
130
131    }
132
133})
134
135