/
on_session_enter.R
207 lines (180 loc) · 6.81 KB
/
on_session_enter.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
#' Register functions to be evaluated at the beginning or end of the R session
#'
#' @param fcn A function or an R expression. The function must accept zero
#' or more arguments (currently not used). If an expression, it will
#' automatically we wrapped up in an anonymous function.
#'
#' @param append If TRUE (default), the function will be evaluated after
#' previously registered ones, otherwise prepended.
#'
#' @param replace if TRUE, the function replaces any previously registered
#' ones, otherwise it will be added (default).
#'
#' @return (invisible) the list of registered functions.
#'
#' @details
#' These functions register one or more functions to be called when the
#' current R session begins or ends. The functions are evaluated in a local
#' environment and without exception handlers, which means that if one
#' produces an error, then none of the succeeding functions will be called.
#'
#' To list currently registered functions, use `fcns <- on_session_enter()`
#' or `fcns <- on_session_exit()`.
#' To remove all registered functions, use `on_session_enter(replace = TRUE)`
#' or `on_session_exit(replace = TRUE)`.
#'
#' The `on_session_enter()` function works by recording all `fcn`:s in an
#' internal list which will be evaluated via a custom
#' \code{\link[base:.First]{.First()}} function created in the global
#' environment. Any other `.First()` function on the search path, including
#' a pre-existing `.First()` function in the global environment, is called
#' at the end after registered functions have been called.
#'
#' The `on_session_exit()` function works by recording all `fcn`:s in an
#' internal list which will be evaluated via a custom function that is called
#' when the global environment is garbage collected, which happens at the very
#' end of the R shutdown process.
#' Contrary to a \code{\link[base:.Last]{.Last()}} function, which is not be
#' called if `quit(runLast = FALSE)` is used, functions registered via
#' `on_session_exit()` are always processed.
#' Registered `on_session_exit()` functions are called _after_ `quit()` saves
#' any workspace image to file (`./.RData`), and _after_ any `.Last()` has
#' been called.
#'
#' @examples
#' \dontrun{
#' ## Summarize interactive session upon termination
#' if (interactive()) {
#' startup::on_session_exit(local({
#' t0 <- Sys.time()
#' function(...) {
#' dt <- difftime(Sys.time(), t0, units = "auto")
#' msg <- c(
#' "Session summary:",
#' sprintf(" * R version: %s", getRversion()),
#' sprintf(" * Process ID: %d", Sys.getpid()),
#' sprintf(" * Wall time: %.2f %s", dt, attr(dt, "units"))
#' )
#' msg <- paste(msg, collapse = "\n")
#' message(msg)
#' }
#' }))
#' }
#' }
#'
#' @export
on_session_enter <- local({
.First <- function() {
"This function was added by startup::on_session_enter()"
"Evaluate registered functions, cf. environment(.First)$fcns"
for (fcn in fcns) {
local(eval(fcn(), envir = parent.frame()))
}
## Call any pre-existing .First() on the search path
"Call any pre-existing .First() on the search path, including"
"any pre-existing .First() function, cf. environment(.First)$first"
## Is there a .First() on the search() path excluding existing one
## in the global environment?
e <- globalenv()
while (!identical(e <- parent.env(e), emptyenv())) {
if (exists(".First", mode = "function", envir = e, inherits = FALSE)) {
first <- get(".First", mode = "function", envir = e, inherits = FALSE)
break
}
}
if (is.function(first)) first()
} ## .First()
function(fcn = NULL, append = TRUE, replace = FALSE) {
stopifnot(is.logical(append), length(append) == 1L, !is.na(append))
stopifnot(is.logical(replace), length(replace) == 1L, !is.na(replace))
if (!is.function(fcn)) {
expr <- fcn
fcn <- function(...) NULL
body(fcn) <- expr
}
env <- environment(.First)
## Set up local .First()? (only once)
if (!isTRUE(env[["on_session_enter"]])) {
env <- new.env(parent = globalenv())
env[["first"]] <- NULL
env[["fcns"]] <- list()
env[["on_session_enter"]] <- TRUE
environment(.First) <<- env
}
## Make sure to record any pre-existing .First() in the global environment
genv <- globalenv()
if (exists(".First", envir = genv, inherits = FALSE)) {
first <- get(".First", envir = genv, inherits = FALSE)
e <- environment(first)
if (!isTRUE(e[["on_session_enter"]])) env[["first"]] <- first
}
fcns <- env[["fcns"]]
if (is.null(fcn)) return(fcns)
## Replace?
if (replace) fcns <- list()
## Append or prepend?
if (!is.null(fcn)) {
fcn <- list(fcn)
fcns <- if (append) c(fcns, fcn) else c(fcn, fcns)
}
assign(".First", .First, envir = genv)
invisible(fcns)
}
})
on_session_enter <- local({
.First <- function() {
"This function was added by startup::on_session_enter()"
"Evaluate registered functions, cf. environment(.First)$fcns"
for (fcn in fcns) {
local(fcn())
}
## Call any pre-existing .First() on the search path
"Call any pre-existing .First() on the search path, including"
"any pre-existing .First() function, cf. environment(.First)$first"
## Is there a .First() on the search() path excluding existing one
## in the global environment?
e <- globalenv()
while (!identical(e <- parent.env(e), emptyenv())) {
if (exists(".First", mode = "function", envir = e, inherits = FALSE)) {
first <- get(".First", mode = "function", envir = e, inherits = FALSE)
break
}
}
if (is.function(first)) first()
} ## .First()
function(fcn = NULL, append = TRUE, replace = FALSE) {
stopifnot(is.logical(append), length(append) == 1L, !is.na(append))
stopifnot(is.logical(replace), length(replace) == 1L, !is.na(replace))
if (!is.function(fcn)) {
expr <- fcn
fcn <- function(...) NULL
body(fcn) <- expr
}
genv <- globalenv()
## Make sure to record any pre-existing .First() in the global environment
first <- NULL
fcns <- list()
if (exists(".First", envir = genv, inherits = FALSE)) {
first <- get(".First", envir = genv, inherits = FALSE)
env <- environment(first)
if (isTRUE(env[["on_session_enter"]])) {
first <- env[["first"]]
fcns <- env[["fcns"]]
}
}
## Replace?
if (replace) fcns <- list()
## Append or prepend?
if (!is.null(fcn)) {
fcn <- list(fcn)
fcns <- if (append) c(fcns, fcn) else c(fcn, fcns)
}
env <- new.env(parent = genv)
env[["first"]] <- first
env[["fcns"]] <- fcns
env[["on_session_enter"]] <- TRUE
environment(.First) <<- env
assign(".First", .First, envir = genv)
invisible(fcns)
}
})