1# Unit test
2#
3# Author: Renaud Gaujoux (edited by Max Kuhn)
4# Created: 01 May 2018
5# Copyright: Cytoreason (2017)
6###############################################################################
7
8context("Formatting functions")
9
10library(utils)
11
12# RUnit-testthat bridge
13checkIdentical <- function(x, y, msg){
14  expect_identical(x, y, info = msg)
15
16}
17checkTrue <- function(x, y, msg){
18  expect_true(x, info = msg)
19
20}
21##
22
23checkFun <- function(fn, name){
24
25  function(x, ...){
26
27    oldRNG <- RNGseed()
28    if( !missing(x) ){
29      d <- fn(x)
30      obj <- getRNG(x)
31      cl <- class(x)
32    }else{
33      d <- fn()
34      obj <- getRNG()
35      cl <- 'MISSING'
36    }
37    newRNG <- RNGseed()
38    msg <- function(x, ...) paste(name, '-', cl, ':', x, '[', ..., ']')
39    expect_identical(oldRNG, newRNG, info = msg("does not change RNG", ...))
40
41    #
42    expect_true( isString(d), info = msg("result is a character string", ...))
43    expect_identical(d, fn(obj), info = msg("digest is from the RNG setting", ...))
44
45  }
46}
47
48test_that('RNGdigest and RNGstr', {
49
50  RNGkind_default()
51  on.exit( RNGrecovery() )
52
53  fn <- c('RNGdigest', 'RNGstr')
54  sapply(fn, function(f){
55        fn <- getFunction(f, where='package:rngtools')
56        checker <- checkFun(fn, f)
57
58        checker()
59        checker(1234)
60        checker(1:3, 'Valid seed')
61        checker(2:3, 'Invalid seed')
62        x <- list(10, rng=c(401L, 1L, 1L))
63        checker(x, 'list with rng slot')
64
65      })
66  TRUE
67
68})
69
70# Note: in R 3.6, RNGkind returns a vector of length 3 (vs 2 in previous versions)
71# Here we set the expected default length according to the runtime version
72checkRNGtype <- function(x, ..., expL = .RNGkind_length()){
73
74  fn <- RNGtype
75  oldRNG <- getRNG()
76  if( !missing(x) ){
77    d <- fn(x)
78    obj <- getRNG(x)
79    cl <- paste0(class(x), '(', length(x), ')')
80  }else{
81    d <- fn()
82    obj <- getRNG()
83    cl <- 'MISSING'
84  }
85  newRNG <- getRNG()
86  msg <- function(x, ...) paste(cl, ':', x, '[', ..., ']')
87  expect_identical(oldRNG, newRNG, info = msg("does not change RNG", ...))
88
89  #
90  expect_true( is.character(d), msg("result is a character vector", ...) )
91  expect_identical( length(d), expL, info = msg("result has correct length (", expL, ")", ...) )
92
93}
94
95test_that('RNGtype', {
96
97  RNGkind('default', 'default')
98  on.exit( RNGrecovery() )
99  checker <- checkRNGtype
100
101  checker()
102  checker(1234, 'Valid single numeric seed')
103  checker(1:3, 'Valid seed')
104  checker(402L, 'Valid encoded kind')
105  expect_true( !identical(RNGtype(402), RNGtype(402L)), "Single integer and real number does not give the same result")
106  x <- list(10, rng=c(401L, 1L, 1L))
107  checker(x, 'list with rng slot')
108
109  # errors
110  oldRNG <- getRNG()
111  expect_error(RNGtype(2:3), info = "Error with invalid length seed")
112  expect_identical(oldRNG, getRNG(), info = "RNG still valid after error")
113  #
114
115  oldRNG <- getRNG()
116  expect_error(RNGtype(123L), info = "Error with invalid RNG kind")
117  expect_identical(oldRNG, getRNG(), info = "RNG still valid after error")
118  expect_error(RNGtype(1234L), info = "Error with invalid RNG integer")
119  expect_identical(oldRNG, getRNG(), info = "RNG still valid after error")
120
121})
122