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 4815 - (view) (download)

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

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