1# File src/library/base/R/RNG.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2019 The R Core Team 5# 6# This program is free software; you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# A copy of the GNU General Public License is available at 17# https://www.R-project.org/Licenses/ 18 19## Random Number Generator 20 21## The available kinds are in 22## ../../../include/Random.h and ../../../main/RNG.c [RNG_Table] 23## 24RNGkind <- function(kind = NULL, normal.kind = NULL, sample.kind = NULL) 25{ 26 kinds <- c("Wichmann-Hill", "Marsaglia-Multicarry", "Super-Duper", 27 "Mersenne-Twister", "Knuth-TAOCP", "user-supplied", 28 "Knuth-TAOCP-2002", "L'Ecuyer-CMRG", "default") 29 n.kinds <- c("Buggy Kinderman-Ramage", "Ahrens-Dieter", "Box-Muller", 30 "user-supplied", "Inversion", "Kinderman-Ramage", 31 "default") 32 s.kinds <- c("Rounding", "Rejection", "default") 33 do.set <- length(kind) > 0L 34 if(do.set) { 35 if(!is.character(kind) || length(kind) > 1L) 36 stop("'kind' must be a character string of length 1 (RNG to be used).") 37 if(is.na(i.knd <- pmatch(kind, kinds) - 1L)) 38 stop(gettextf("'%s' is not a valid abbreviation of an RNG", kind), 39 domain = NA) 40 if(i.knd == length(kinds) - 1L) i.knd <- -1L 41 } else i.knd <- NULL 42 43 if(!is.null(normal.kind)) { 44 if(!is.character(normal.kind) || length(normal.kind) != 1L) 45 stop("'normal.kind' must be a character string of length 1") 46 normal.kind <- pmatch(normal.kind, n.kinds) - 1L 47 if(is.na(normal.kind)) 48 stop(gettextf("'%s' is not a valid choice", normal.kind), 49 domain = NA) 50 if (normal.kind == 0L) 51 warning("buggy version of Kinderman-Ramage generator used", 52 domain = NA) 53 if(normal.kind == length(n.kinds) - 1L) normal.kind <- -1L 54 } 55 56 if(!is.null(sample.kind)) { 57 if(!is.character(sample.kind) || length(sample.kind) != 1L) 58 stop("'sample.kind' must be a character string of length 1") 59 sample.kind <- pmatch(sample.kind, s.kinds) - 1L 60 if(is.na(sample.kind)) 61 stop(gettextf("'%s' is not a valid choice", sample.kind), 62 domain = NA) 63 if (sample.kind == 0L) 64 warning("non-uniform 'Rounding' sampler used", 65 domain = NA) 66 if(sample.kind == length(s.kinds) - 1L) sample.kind <- -1L 67 } 68 r <- 1L + .Internal(RNGkind(i.knd, normal.kind, sample.kind)) 69 r <- c(kinds[r[1L]], n.kinds[r[2L]], s.kinds[r[3L]]) 70 if(do.set || !is.null(normal.kind) || !is.null(sample.kind)) 71 invisible(r) else r 72} 73 74set.seed <- function(seed, kind = NULL, normal.kind = NULL, sample.kind = NULL) 75{ 76 kinds <- c("Wichmann-Hill", "Marsaglia-Multicarry", "Super-Duper", 77 "Mersenne-Twister", "Knuth-TAOCP", "user-supplied", 78 "Knuth-TAOCP-2002", "L'Ecuyer-CMRG", "default") 79 n.kinds <- c("Buggy Kinderman-Ramage", "Ahrens-Dieter", "Box-Muller", 80 "user-supplied", "Inversion", "Kinderman-Ramage", 81 "default") 82 s.kinds <- c("Rounding", "Rejection", "default") 83 if(length(kind) ) { 84 if(!is.character(kind) || length(kind) > 1L) 85 stop("'kind' must be a character string of length 1 (RNG to be used).") 86 if(is.na(i.knd <- pmatch(kind, kinds) - 1L)) 87 stop(gettextf("'%s' is not a valid abbreviation of an RNG", kind), 88 domain = NA) 89 if(i.knd == length(kinds) - 1L) i.knd <- -1L 90 } else i.knd <- NULL 91 92 if(!is.null(normal.kind)) { 93 if(!is.character(normal.kind) || length(normal.kind) != 1L) 94 stop("'normal.kind' must be a character string of length 1") 95 normal.kind <- pmatch(normal.kind, n.kinds) - 1L 96 if(is.na(normal.kind)) 97 stop(gettextf("'%s' is not a valid choice", normal.kind), 98 domain = NA) 99 if (normal.kind == 0L) 100 stop("buggy version of Kinderman-Ramage generator is not allowed", 101 domain = NA) 102 if(normal.kind == length(n.kinds) - 1L) normal.kind <- -1L 103 } 104 if(!is.null(sample.kind)) { 105 if(!is.character(sample.kind) || length(sample.kind) != 1L) 106 stop("'sample.kind' must be a character string of length 1") 107 sample.kind <- pmatch(sample.kind, s.kinds) - 1L 108 if(is.na(sample.kind)) 109 stop(gettextf("'%s' is not a valid choice", sample.kind), 110 domain = NA) 111 if (sample.kind == 0L) 112 warning("non-uniform 'Rounding' sampler used", 113 domain = NA) 114 if(sample.kind == length(s.kinds) - 1L) sample.kind <- -1L 115 } 116 .Internal(set.seed(seed, i.knd, normal.kind, sample.kind)) 117} 118 119# Compatibility function to set RNGkind as in a given R version 120 121RNGversion <- function(vstr) 122{ 123 vnum <- as.numeric(strsplit(as.character(vstr), ".", fixed=TRUE)[[1L]]) 124 if (length(vnum) < 2L) 125 stop("malformed version string") 126 if (vnum[1L] == 0 && vnum[2L] < 99) 127 RNGkind("Wichmann-Hill", "Buggy Kinderman-Ramage", "Rounding") 128 else if (vnum[1L] == 0 || vnum[1L] == 1 && vnum[2L] <= 6) 129 RNGkind("Marsaglia-Multicarry", "Buggy Kinderman-Ramage", "Rounding") 130 else if (vnum[1L] <= 2 || vnum[1L] == 3 && vnum[2L] <= 5) 131 RNGkind("Mersenne-Twister", "Inversion", "Rounding") 132 else 133 RNGkind("Mersenne-Twister", "Inversion", "Rejection") 134} 135