SCM

SCM Repository

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

Diff of /pkg/randtoolbox/R/runifInterface.R

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 6135, Thu Nov 29 11:07:56 2018 UTC revision 6136, Tue Apr 30 12:56:05 2019 UTC
# Line 2  Line 2 
2  # @file  runifInterface.R  # @file  runifInterface.R
3  # @brief R file for runif interface  # @brief R file for runif interface
4  #  #
5  # @author Petr Savicky  # @author Petr Savicky, Christophe Dutang
6  #  #
7  #  #
8  # Copyright (C) 2009, Petr Savicky, Academy of Sciences of the Czech Republic.  # Copyright (C) 2019, Christophe Dutang,
9    # Petr Savicky, Academy of Sciences of the Czech Republic.
10    # Christophe Dutang, see http://dutangc.free.fr
11  # All rights reserved.  # All rights reserved.
12  #  #
13  # The new BSD License is applied to this software.  # The new BSD License is applied to this software.
14  # Copyright (c) 2009 Petr Savicky.  # Copyright (c) 2019 Christophe Dutang, Petr Savicky.
15  # All rights reserved.  # All rights reserved.
16  #  #
17  #      Redistribution and use in source and binary forms, with or without  #      Redistribution and use in source and binary forms, with or without
# Line 47  Line 49 
49  ###  ###
50    
51    
52  set.generator <- function(name=c("congruRand", "WELL", "MersenneTwister", "default"), parameters=NULL, seed=NULL, ...,  set.generator <- function(name=c("WELL", "MersenneTwister", "default"), parameters=NULL, seed=NULL, ...,
53          only.dsc=FALSE)          only.dsc=FALSE)
54  {  {
55          name <- match.arg(name)          name <- match.arg(name)
56          dots <- list(...)          dots <- list(...)
57          if (name == "congruRand")          if (name == "congruRand")
58          {            stop("the use of linear congruential generator is temporarily disabled, use congruRand() instead.")
59                  if (is.null(parameters))          # if (name == "congruRand")
60                          parameters <- c(mod=dots$mod, mult=dots$mult, incr=dots$incr)          # {
61                  if (length(parameters) == 0)          #       if (is.null(parameters))
62                          parameters <- c(mod="2147483647", mult="16807", incr="0")          #               parameters <- c(mod=dots$mod, mult=dots$mult, incr=dots$incr)
63                  if (!identical(names(parameters), c("mod", "mult", "incr")))          #       if (length(parameters) == 0)
64                  {          #               parameters <- c(mod="2147483647", mult="16807", incr="0")
65                          param.names <- paste(names(parameters),collapse=" ")          #       if (!identical(names(parameters), c("mod", "mult", "incr")))
66                          stop("parameter list \"", param.names, "\" is not correct for congruRand")          #       {
67                  }          #               param.names <- paste(names(parameters),collapse=" ")
68                  if (is.null(seed))          #               stop("parameter list \"", param.names, "\" is not correct for congruRand")
69                          seed <- floor(as.double(parameters["mod"]) * runif(1))          #       }
70                  if (is.numeric(parameters))          #       if (is.null(seed))
71                          parameters <- formatC(parameters, format="f", digits=0)          #               seed <- floor(as.double(parameters["mod"]) * runif(1))
72                  if (is.numeric(seed))          #       if (is.numeric(parameters))
73                          seed <- formatC(seed, format="f", digits=0)          #               parameters <- formatC(parameters, format="f", digits=0)
74                  state <- c(seed=seed)          #       if (is.numeric(seed))
75                  description <- list(name=name, parameters=parameters, state=state)          #               seed <- formatC(seed, format="f", digits=0)
76          } else if (name == "WELL")          #       state <- c(seed=seed)
77            #       description <- list(name=name, parameters=parameters, state=state)
78            # } else
79              if (name == "WELL")
80          {          {
81                  if (is.null(parameters))                  if (is.null(parameters))
82                  {                  {
# Line 141  Line 146 
146                  stop("unsupported generator: ", name)                  stop("unsupported generator: ", name)
147          if (only.dsc)          if (only.dsc)
148                  return(description)                  return(description)
         cat("to be removed\n")  
         print(description)  
149          put.description(description)          put.description(description)
150          invisible(NULL)          invisible(NULL)
151  }  }
# Line 152  Line 155 
155          name <- description$name          name <- description$name
156          parameters <- description$parameters          parameters <- description$parameters
157          state <- description$state          state <- description$state
158          if (name == "congruRand")          # if (name == "congruRand")
159          {          # {
160            #implemented in src/congruRand.c          #   #implemented in src/congruRand.c
161                  aux <- .C(CF_put_state_congru,          #       aux <- .C(CF_put_state_congru,
162                          parameters,          #               parameters,
163                          state,          #               state,
164                          err = integer(1),          #               err = integer(1),
165                          PACKAGE="randtoolbox")          #               PACKAGE="randtoolbox")
166                  if (aux$err != 0)          #       if (aux$err != 0)
167                          stop("check congruRand error: ", aux$err)          #               stop("check congruRand error: ", aux$err)
168                  if (RNGkind()[1] != "user-supplied")          #       if (RNGkind()[1] != "user-supplied")
169                  {          #       {
170                    #implemented in src/runifInterface.c          #         #implemented in src/runifInterface.c
171                          .C(CF_set_noop, PACKAGE="randtoolbox")          #               .C(CF_set_noop, PACKAGE="randtoolbox")
172                          RNGkind("user-supplied")          #               RNGkind("user-supplied")
173                          #implemented in src/congruRand.c          #               #implemented in src/congruRand.c
174                          aux <- .C(CF_put_state_congru,          #               aux <- .C(CF_put_state_congru,
175                                  parameters,          #                       parameters,
176                                  state,          #                       state,
177                                  err = integer(1),          #                       err = integer(1),
178                                  PACKAGE="randtoolbox")          #                       PACKAGE="randtoolbox")
179                          if (aux$err != 0)          #               if (aux$err != 0)
180                                  stop("check congruRand error: ", aux$err)          #                       stop("check congruRand error: ", aux$err)
181                  }          #       }
182          } else if (name == "WELL")          # } else
183              if (name == "WELL")
184          {          {
185            #implemented in src/runifInterface.c            #implemented in src/runifInterface.c
186                  .C(CF_set_noop, PACKAGE="randtoolbox")                  .C(CF_set_noop, PACKAGE="randtoolbox")
# Line 214  Line 218 
218          generator <- .C(CF_current_generator,          generator <- .C(CF_current_generator,
219                  integer(1),                  integer(1),
220                  PACKAGE="randtoolbox")[[1]]                  PACKAGE="randtoolbox")[[1]]
221          if (generator == 1)          cat("generator", generator, "\n")
222          {          # if (generator == 1)
223                  name <- "congruRand"          # {
224                  outspace <- "18446744073709551616" # 2^64          #       name <- "congruRand"
225                  #implemented in src/congruRand.c          #       outspace <- "18446744073709551616" # 2^64
226                  aux <- .C(CF_get_state_congru,          #       #implemented in src/congruRand.c
227                          parameters=rep(outspace, times=3),          #       aux <- .C(CF_get_state_congru,
228                          seed=outspace,          #               parameters=rep(outspace, times=3),
229                          PACKAGE="randtoolbox")          #               seed=outspace,
230                  parameters <- aux$parameters          #               PACKAGE="randtoolbox")
231                  names(parameters) <- c("mod", "mult", "incr")          #       parameters <- aux$parameters
232                  seed <- aux$seed          #       names(parameters) <- c("mod", "mult", "incr")
233                  state <- c(seed=aux$seed)          #       seed <- aux$seed
234                  if(parameters[1] == "4294967296" && parameters[2] == "1664525" && parameters[3] == "1013904223")          #       state <- c(seed=aux$seed)
235                          literature <- "Knuth - Lewis"          #       if(parameters[1] == "4294967296" && parameters[2] == "1664525" && parameters[3] == "1013904223")
236                  else if(parameters[1] == "281474976710656" && parameters[2] == "31167285" && parameters[3] == "1")          #               literature <- "Knuth - Lewis"
237                          literature <- "Lavaux - Jenssens"          #       else if(parameters[1] == "281474976710656" && parameters[2] == "31167285" && parameters[3] == "1")
238                  else if(parameters[1] == "18446744073709551616" && parameters[2] == "636412233846793005" && parameters[3] == "1")          #               literature <- "Lavaux - Jenssens"
239                          literature <- "Haynes"          #       else if(parameters[1] == "18446744073709551616" && parameters[2] == "636412233846793005" && parameters[3] == "1")
240                  else if(parameters[1] == "4294967296" && parameters[2] == "69069" && parameters[3] == "0")          #               literature <- "Haynes"
241                          literature <- "Marsaglia"          #       else if(parameters[1] == "4294967296" && parameters[2] == "69069" && parameters[3] == "0")
242                  else if(parameters[1] == "4294967295" && parameters[2] == "16807" && parameters[3] == "0")          #               literature <- "Marsaglia"
243                          literature <- "Park - Miller"          #       else if(parameters[1] == "4294967295" && parameters[2] == "16807" && parameters[3] == "0")
244                  else          #               literature <- "Park - Miller"
245                          literature <- "Unknown"          #       else
246          } else if (generator == 2)          #               literature <- "Unknown"
247            # } else
248              if (generator == 2)
249          {          {
250                  name <- "WELL"                  name <- "WELL"
251                  #implemented in rngWELL package, see NAMESPACE                  #implemented in rngWELL package, see NAMESPACE
# Line 250  Line 256 
256  #                       state = integer(2000),  #                       state = integer(2000),
257  #                       PACKAGE="rngWELL")  #                       PACKAGE="rngWELL")
258                  order <- as.character(tmp$order)                  order <- as.character(tmp$order)
                 print(tmp)  
259                  version <- letters[tmp$version]                  version <- letters[tmp$version]
260                  parameters <- c(order=order, version=version)                  parameters <- c(order=order, version=version)
261                  size <- ceiling(tmp$order/32)                  size <- ceiling(tmp$order/32)

Legend:
Removed from v.6135  
changed lines
  Added in v.6136

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