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