SCM

SCM Repository

[rmetrics] Annotation of /pkg/randtoolbox/R/runifInterface.R
ViewVC logotype

Annotation of /pkg/randtoolbox/R/runifInterface.R

Parent Directory Parent Directory | Revision Log Revision Log


Revision 6136 - (view) (download)

1 : dutangc 4229 ##
2 :     # @file runifInterface.R
3 :     # @brief R file for runif interface
4 :     #
5 : dutangc 6136 # @author Petr Savicky, Christophe Dutang
6 : dutangc 4229 #
7 :     #
8 : dutangc 6136 # Copyright (C) 2019, Christophe Dutang,
9 :     # Petr Savicky, Academy of Sciences of the Czech Republic.
10 :     # Christophe Dutang, see http://dutangc.free.fr
11 : dutangc 4229 # All rights reserved.
12 :     #
13 :     # The new BSD License is applied to this software.
14 : dutangc 6136 # Copyright (c) 2019 Christophe Dutang, Petr Savicky.
15 : dutangc 4229 # All rights reserved.
16 :     #
17 :     # Redistribution and use in source and binary forms, with or without
18 :     # modification, are permitted provided that the following conditions are
19 :     # met:
20 :     #
21 :     # - Redistributions of source code must retain the above copyright
22 :     # notice, this list of conditions and the following disclaimer.
23 :     # - Redistributions in binary form must reproduce the above
24 :     # copyright notice, this list of conditions and the following
25 :     # disclaimer in the documentation and/or other materials provided
26 :     # with the distribution.
27 :     # - Neither the name of the Academy of Sciences of the Czech Republic
28 :     # nor the names of its contributors may be used to endorse or promote
29 :     # products derived from this software without specific prior written
30 :     # permission.
31 :     #
32 :     # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
33 :     # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
34 :     # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
35 :     # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
36 :     # OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
37 :     # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
38 :     # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
39 :     # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
40 :     # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
41 :     # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
42 :     # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
43 :     #
44 :     #
45 :     #############################################################################
46 :     ### runif interface
47 :     ###
48 :     ### R functions
49 :     ###
50 : dutangc 3975
51 : dutangc 4229
52 : dutangc 6136 set.generator <- function(name=c("WELL", "MersenneTwister", "default"), parameters=NULL, seed=NULL, ...,
53 : savicky 4815 only.dsc=FALSE)
54 : savicky 3954 {
55 : savicky 3966 name <- match.arg(name)
56 :     dots <- list(...)
57 : savicky 4534 if (name == "congruRand")
58 : dutangc 6136 stop("the use of linear congruential generator is temporarily disabled, use congruRand() instead.")
59 :     # if (name == "congruRand")
60 :     # {
61 :     # if (is.null(parameters))
62 :     # parameters <- c(mod=dots$mod, mult=dots$mult, incr=dots$incr)
63 :     # if (length(parameters) == 0)
64 :     # parameters <- c(mod="2147483647", mult="16807", incr="0")
65 :     # if (!identical(names(parameters), c("mod", "mult", "incr")))
66 :     # {
67 :     # param.names <- paste(names(parameters),collapse=" ")
68 :     # stop("parameter list \"", param.names, "\" is not correct for congruRand")
69 :     # }
70 :     # if (is.null(seed))
71 :     # seed <- floor(as.double(parameters["mod"]) * runif(1))
72 :     # if (is.numeric(parameters))
73 :     # parameters <- formatC(parameters, format="f", digits=0)
74 :     # if (is.numeric(seed))
75 :     # seed <- formatC(seed, format="f", digits=0)
76 :     # state <- c(seed=seed)
77 :     # description <- list(name=name, parameters=parameters, state=state)
78 :     # } else
79 :     if (name == "WELL")
80 : savicky 4534 {
81 :     if (is.null(parameters))
82 :     {
83 : savicky 5135 if (is.null(dots$order)) dots$order <- ""
84 :     if (is.null(dots$version)) dots$version <- ""
85 :     if (dots$order != "" & nchar(dots$version) != 1) {
86 :     stop("unsupported parameters order=", dots$order, ", version=", dots$version," for WELL")
87 :     }
88 : savicky 5134 version.name <- paste(dots$order, dots$version, sep="")
89 :     order <- substr(version.name, 1, nchar(version.name) - 1)
90 :     version <- substr(version.name, nchar(version.name), nchar(version.name))
91 : savicky 5123 parameters <- c(order=order, version=version)
92 : savicky 4549 }
93 : savicky 5123 if (!identical(names(parameters), c("order", "version")))
94 : savicky 4549 {
95 : savicky 4534 param.names <- paste(names(parameters),collapse=" ")
96 : savicky 5123 cat("parameters required for WELL: order, version\n")
97 : savicky 4549 cat("parameters provided: ", param.names, "\n")
98 :     stop("parameter list is not correct for WELL")
99 : savicky 3973 }
100 : savicky 4549 if (! paste(parameters, collapse="") %in% c("512a", "521a", "521b", "607a", "607b", "800a", "800b", "1024a", "1024b",
101 : savicky 5123 "19937a", "19937b", "19937c", "21701a", "23209a", "23209b", "44497a", "44497b"))
102 : savicky 5134 stop("unsupported parameters order=", parameters["order"], ", version=", parameters["version"]," for WELL")
103 : savicky 4534 if (is.null(seed))
104 :     seed <- floor(2^31 * runif(1))
105 : savicky 4549 size <- ceiling(as.numeric(parameters["order"])/32)
106 : dutangc 6115
107 :     #implemented in rngWELL package, see NAMESPACE
108 : dutangc 5473 state <- doinitMT2002(seed, size, size)[[3]]
109 : dutangc 6115
110 :     #old call was
111 :     # state <- .C("initMT2002", as.integer(seed), as.integer(size), integer(size), PACKAGE="rngWELL")[[3]]
112 :    
113 : savicky 4534 description <- list(name=name, parameters=parameters, state=state)
114 : savicky 4815 } else if (name == "MersenneTwister")
115 :     {
116 :     if (is.null(parameters))
117 :     parameters <- c(initialization=dots$initialization, resolution=dots$resolution)
118 :     if (!identical(names(parameters), c("initialization", "resolution")))
119 :     {
120 :     param.names <- paste(names(parameters),collapse=" ")
121 :     stop("parameter list \"", param.names, "\" is not correct for MersenneTwister")
122 :     }
123 :     type <- match(parameters["initialization"], c("init2002", "array2002"), nomatch=0)
124 :     if (type == 0)
125 :     stop("initialization ", parameters["initialization"], " is not in c(\"init2002\", \"array2002\")")
126 :     if ( ! parameters["resolution"] %in% c("32", "53"))
127 :     stop("resolution \"", parameters["resolution"], "\" is not in c(\"32\", \"53\")")
128 :     if (is.null(seed))
129 :     seed <- floor(2^31 * runif(1))
130 : dutangc 6115
131 :     #implemented in src/mt19937ar.c
132 :     state <- .C(CF_initMersenneTwister,
133 : savicky 4815 as.integer(type),
134 :     length(seed),
135 :     as.integer(seed),
136 :     state=integer(625),
137 :     PACKAGE="randtoolbox")$state
138 :     description <- list(name=name, parameters=parameters, state=state)
139 : savicky 4534 } else if (name == "default")
140 :     {
141 : savicky 3954 RNGkind("default")
142 : savicky 4534 if (!is.null(seed))
143 : savicky 3954 set.seed(seed)
144 : savicky 4534 return(invisible(NULL))
145 :     } else
146 : savicky 3966 stop("unsupported generator: ", name)
147 : savicky 4549 if (only.dsc)
148 : savicky 4534 return(description)
149 :     put.description(description)
150 : savicky 3954 invisible(NULL)
151 :     }
152 :    
153 : savicky 4373 put.description <- function(description)
154 : savicky 3954 {
155 : savicky 3966 name <- description$name
156 :     parameters <- description$parameters
157 :     state <- description$state
158 : dutangc 6136 # if (name == "congruRand")
159 :     # {
160 :     # #implemented in src/congruRand.c
161 :     # aux <- .C(CF_put_state_congru,
162 :     # parameters,
163 :     # state,
164 :     # err = integer(1),
165 :     # PACKAGE="randtoolbox")
166 :     # if (aux$err != 0)
167 :     # stop("check congruRand error: ", aux$err)
168 :     # if (RNGkind()[1] != "user-supplied")
169 :     # {
170 :     # #implemented in src/runifInterface.c
171 :     # .C(CF_set_noop, PACKAGE="randtoolbox")
172 :     # RNGkind("user-supplied")
173 :     # #implemented in src/congruRand.c
174 :     # aux <- .C(CF_put_state_congru,
175 :     # parameters,
176 :     # state,
177 :     # err = integer(1),
178 :     # PACKAGE="randtoolbox")
179 :     # if (aux$err != 0)
180 :     # stop("check congruRand error: ", aux$err)
181 :     # }
182 :     # } else
183 :     if (name == "WELL")
184 : savicky 4534 {
185 : dutangc 6115 #implemented in src/runifInterface.c
186 :     .C(CF_set_noop, PACKAGE="randtoolbox")
187 : savicky 4534 RNGkind("user-supplied")
188 : dutangc 6115 #implemented in rngWELL package, see NAMESPACE
189 : dutangc 5473 doputRngWELL(parameters["order"], parameters["version"], state)
190 :     # .C("putRngWELL",
191 :     # as.integer(parameters["order"]),
192 :     # match(parameters["version"], c("a", "b", "c"), nomatch=0),
193 :     # as.integer(state),
194 :     # PACKAGE="rngWELL")
195 : savicky 4815 } else if (name == "MersenneTwister")
196 :     {
197 : dutangc 6115 #implemented in src/runifInterface.c
198 :     .C(CF_set_noop, PACKAGE="randtoolbox")
199 : savicky 4815 RNGkind("user-supplied")
200 : dutangc 6115 #implemented in src/mt19937ar.c
201 :     .C(CF_putMersenneTwister,
202 : savicky 4815 match(parameters["initialization"], c("init2002", "array2002"), nomatch=0),
203 :     as.integer(parameters["resolution"]),
204 :     as.integer(state),
205 :     NAOK=TRUE,
206 :     PACKAGE="randtoolbox")
207 : savicky 4534 } else
208 : savicky 3966 stop("unsupported generator: ", name)
209 : savicky 3954 invisible(NULL)
210 :     }
211 :    
212 : savicky 4373 get.description <- function()
213 : savicky 3954 {
214 : savicky 4534 if (RNGkind(NULL)[1] != "user-supplied")
215 :     stop("For R base generators, use .Random.seed, not get.description()")
216 : dutangc 6115
217 :     #implemented in src/runifInterface.c
218 :     generator <- .C(CF_current_generator,
219 : savicky 3954 integer(1),
220 :     PACKAGE="randtoolbox")[[1]]
221 : dutangc 6136 cat("generator", generator, "\n")
222 :     # if (generator == 1)
223 :     # {
224 :     # name <- "congruRand"
225 :     # outspace <- "18446744073709551616" # 2^64
226 :     # #implemented in src/congruRand.c
227 :     # aux <- .C(CF_get_state_congru,
228 :     # parameters=rep(outspace, times=3),
229 :     # seed=outspace,
230 :     # PACKAGE="randtoolbox")
231 :     # parameters <- aux$parameters
232 :     # names(parameters) <- c("mod", "mult", "incr")
233 :     # seed <- aux$seed
234 :     # state <- c(seed=aux$seed)
235 :     # if(parameters[1] == "4294967296" && parameters[2] == "1664525" && parameters[3] == "1013904223")
236 :     # literature <- "Knuth - Lewis"
237 :     # else if(parameters[1] == "281474976710656" && parameters[2] == "31167285" && parameters[3] == "1")
238 :     # literature <- "Lavaux - Jenssens"
239 :     # else if(parameters[1] == "18446744073709551616" && parameters[2] == "636412233846793005" && parameters[3] == "1")
240 :     # literature <- "Haynes"
241 :     # else if(parameters[1] == "4294967296" && parameters[2] == "69069" && parameters[3] == "0")
242 :     # literature <- "Marsaglia"
243 :     # else if(parameters[1] == "4294967295" && parameters[2] == "16807" && parameters[3] == "0")
244 :     # literature <- "Park - Miller"
245 :     # else
246 :     # literature <- "Unknown"
247 :     # } else
248 :     if (generator == 2)
249 : savicky 4534 {
250 :     name <- "WELL"
251 : dutangc 6115 #implemented in rngWELL package, see NAMESPACE
252 : dutangc 5473 tmp <- dogetRngWELL(1, 1, 2000)
253 :     # tmp <- .C("getRngWELL",
254 :     # order = integer(1),
255 :     # version = integer(1),
256 :     # state = integer(2000),
257 :     # PACKAGE="rngWELL")
258 : savicky 4549 order <- as.character(tmp$order)
259 :     version <- letters[tmp$version]
260 : savicky 5123 parameters <- c(order=order, version=version)
261 : savicky 4549 size <- ceiling(tmp$order/32)
262 : savicky 4534 state <- tmp$state[1:size]
263 :     literature <- "Panneton - L'Ecuyer - Matsumoto"
264 : savicky 4815 } else if (generator == 3)
265 :     {
266 :     name <- "MersenneTwister"
267 : dutangc 6115 #implemented in src/mt19937.c
268 :     tmp <- .C(CF_getMersenneTwister,
269 : savicky 4815 initialization = integer(1),
270 :     resolution = integer(1),
271 :     state = integer(625),
272 :     PACKAGE="randtoolbox")
273 :     initialization <- c("init2002", "array2002")[tmp$initialization]
274 :     resolution <- as.character(tmp$resolution)
275 :     parameters <- c(initialization=initialization, resolution=resolution)
276 :     state <- tmp$state
277 :     literature <- "M. Matsumoto, T. Nishimura, 1998"
278 : savicky 4534 } else
279 : savicky 3954 stop("internal error of randtoolbox")
280 : savicky 4815 list(name=name, parameters=parameters, state=state, authors=literature)
281 : savicky 3954 }
282 :    

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge