1
#' Random seed
2
#'
3
#' `with_seed()` runs code with a specific random seed and resets it afterwards.
4
#'
5
#' @template with
6
#' @param seed `[integer(1)]`\cr The random seed to use to evaluate the code.
7
#' @param .local_envir `[environment]`\cr The environment to use for scoping.
8
#' @examples
9
#' # Same random values:
10
#' with_preserve_seed(runif(5))
11
#' with_preserve_seed(runif(5))
12
#'
13
#' # Use a pseudorandom value as seed to advance the RNG and pick a different
14
#' # value for the next call:
15
#' with_seed(seed <- sample.int(.Machine$integer.max, 1L), runif(5))
16
#' with_seed(seed, runif(5))
17
#' with_seed(seed <- sample.int(.Machine$integer.max, 1L), runif(5))
18
#' @export
19
with_seed <- function(seed, code) {
20 1
  force(seed)
21 1
  with_preserve_seed({
22 1
    set.seed(seed)
23 1
    code
24
  })
25
}
26

27
#' @rdname with_seed
28
#' @export
29
local_seed <- function(seed, .local_envir = parent.frame()) {
30 1
  old_seed <- get_seed()
31 1
  set.seed(seed)
32

33 1
  defer({
34 1
    if (is.null(old_seed)) {
35 0
      on.exit(rm_seed(), add = TRUE)
36
    } else {
37 1
      on.exit(set_seed(old_seed), add = TRUE)
38
    }
39 1
  }, envir = .local_envir)
40

41 1
  invisible(seed)
42
}
43

44
#' @rdname with_seed
45
#' @description
46
#' `with_preserve_seed()` runs code with the current random seed and resets it
47
#'   afterwards.
48
#'
49
#' @export
50
with_preserve_seed <- function(code) {
51 1
  old_seed <- get_seed()
52 1
  if (is.null(old_seed)) {
53 1
    on.exit(rm_seed(), add = TRUE)
54
  } else {
55 1
    on.exit(set_seed(old_seed), add = TRUE)
56
  }
57

58 1
  code
59
}
60

61
#' @rdname with_seed
62
#' @export
63
local_preserve_seed <- function(.local_envir = parent.frame()) {
64 1
  old_seed <- get_seed()
65

66 1
  defer({
67 1
    if (is.null(old_seed)) {
68 1
      on.exit(rm_seed(), add = TRUE)
69
    } else {
70 1
      on.exit(set_seed(old_seed), add = TRUE)
71
    }
72 1
  }, envir = .local_envir)
73

74 1
  invisible(old_seed)
75
}
76

77
has_seed <- function() {
78 1
  exists(".Random.seed", globalenv(), mode = "integer", inherits = FALSE)
79
}
80

81
get_seed <- function() {
82 1
  if (!has_seed()) {
83 1
    return(NULL)
84
  }
85 1
  get(".Random.seed", globalenv(), mode = "integer", inherits = FALSE)
86
}
87

88
set_seed <- function(seed) {
89 1
  assign(".Random.seed", seed, globalenv())
90
}
91

92
rm_seed <- function() {
93 1
  if (!has_seed()) {
94 1
    return(NULL)
95
  }
96 1
  rm(".Random.seed", envir = globalenv())
97
}

Read our documentation on viewing source code .

Loading