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 4392 - (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 3973 set.generator <- function(name=c("congruRand", "default"), parameters=NULL, seed=NULL, ...,
51 :     only.description=FALSE)
52 : savicky 3954 {
53 : savicky 3966 name <- match.arg(name)
54 :     dots <- list(...)
55 :     if (name == "congruRand") {
56 :     if (is.null(parameters)) {
57 :     parameters <- c(mod=dots$mod, mult=dots$mult, incr=dots$incr)
58 : savicky 3954 }
59 : savicky 3966 if (length(parameters) == 0) {
60 : savicky 4370 parameters <- c(mod="2147483647", mult="16807", incr="0")
61 : savicky 3966 }
62 :     if (!identical(names(parameters), c("mod", "mult", "incr"))) {
63 :     param.names <- paste(names(parameters),collapse=" ")
64 : savicky 3973 stop("parameter list \"", param.names, "\" is not correct for congruRand")
65 : savicky 3966 }
66 : savicky 3954 if (is.null(seed)) {
67 : savicky 3973 seed <- floor(as.double(parameters["mod"]) * runif(1))
68 : savicky 3954 }
69 : savicky 4370 if (is.numeric(parameters)) {
70 :     parameters <- formatC(parameters, format="f", digits=0)
71 :     }
72 :     if (is.numeric(seed)) {
73 :     seed <- formatC(seed, format="f", digits=0)
74 :     }
75 : savicky 3966 state <- c(seed=seed)
76 :     description <- list(name=name, parameters=parameters, state=state)
77 : savicky 3973 if (only.description) {
78 :     return(description)
79 :     } else {
80 : savicky 4373 put.description(description)
81 : savicky 3973 }
82 : savicky 3966 } else if (name == "default") {
83 : savicky 3954 RNGkind("default")
84 :     if (!is.null(seed)) {
85 :     set.seed(seed)
86 :     }
87 :     } else {
88 : savicky 3966 stop("unsupported generator: ", name)
89 : savicky 3954 }
90 :     invisible(NULL)
91 :     }
92 :    
93 : savicky 4373 put.description <- function(description)
94 : savicky 3954 {
95 : savicky 3966 name <- description$name
96 :     parameters <- description$parameters
97 :     state <- description$state
98 :     if (name == "congruRand") {
99 : savicky 4375 aux <- .C("put_state_congru",
100 : savicky 4370 parameters,
101 :     state,
102 : savicky 3973 err = integer(1),
103 :     PACKAGE="randtoolbox")
104 : savicky 4375 if (aux$err != 0)
105 : savicky 3973 stop("check congruRand error: ", aux$err)
106 : savicky 4375 if (RNGkind()[1] != "user-supplied") {
107 : savicky 4392 .C("set_noop", PACKAGE="randtoolbox")
108 : savicky 4375 RNGkind("user-supplied")
109 :     aux <- .C("put_state_congru",
110 :     parameters,
111 :     state,
112 :     err = integer(1),
113 :     PACKAGE="randtoolbox")
114 :     if (aux$err != 0)
115 :     stop("check congruRand error: ", aux$err)
116 :     }
117 : savicky 3954 } else {
118 : savicky 3966 stop("unsupported generator: ", name)
119 : savicky 3954 }
120 :     invisible(NULL)
121 :     }
122 :    
123 : savicky 4373 get.description <- function()
124 : savicky 3954 {
125 :     if (RNGkind(NULL)[1] != "user-supplied") {
126 : savicky 3958 stop("For R base generators, use .Random.seed, not get.state()")
127 : savicky 3954 }
128 :     generator <- .C("current_generator",
129 :     integer(1),
130 :     PACKAGE="randtoolbox")[[1]]
131 :     if (generator == 1) {
132 : savicky 3966 name <- "congruRand"
133 : savicky 4370 outspace <- "18446744073709551616" # 2^64
134 : savicky 3954 aux <- .C("get_state_congru",
135 : savicky 4370 parameters=rep(outspace, times=3),
136 :     seed=outspace,
137 : savicky 3954 PACKAGE="randtoolbox")
138 : savicky 4370 parameters <- aux$parameters
139 :     seed <- aux$seed
140 : savicky 3966 state <- c(seed=aux$seed)
141 : savicky 4370 if(parameters[1] == "4294967296" && parameters[2] == "1664525" && parameters[3] == "1013904223")
142 :     literature <- "Knuth - Lewis"
143 :     else if(parameters[1] == "281474976710656" && parameters[2] == "31167285" && parameters[3] == "1")
144 :     literature <- "Lavaux - Jenssens"
145 :     else if(parameters[1] == "18446744073709551616" && parameters[2] == "636412233846793005" && parameters[3] == "1")
146 :     literature <- "Haynes"
147 :     else if(parameters[1] == "4294967296" && parameters[2] == "69069" && parameters[3] == "0")
148 :     literature <- "Marsaglia"
149 :     else if(parameters[1] == "4294967295" && parameters[2] == "16807" && parameters[3] == "0")
150 :     literature <- "Park - Miller"
151 :     else
152 :     literature <- "Unknown"
153 : savicky 3954 } else {
154 :     stop("internal error of randtoolbox")
155 :     }
156 : dutangc 3975 list(name=name, authors=literature, parameters=parameters, state=state)
157 : savicky 3954 }
158 :    

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