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
|
# Find first knitr frame on the stack
knitr_exit_frame <- function(envir) {
frames <- as.list(sys.frames())
frame_loc <- frame_loc(envir, frames)
if (!frame_loc) {
return(envir)
}
knitr_ns <- asNamespace("knitr")
# This doesn't handle correctly the recursive case (knitr called
# within a chunk). Handling this would be a little fiddly for an
# uncommon edge case.
for (i in seq(1, frame_loc)) {
if (identical(topenv(frames[[i]]), knitr_ns)) {
return(frames[[i]])
}
}
NULL
}
source_exit_frame <- function(envir) {
source_exit_frame_option(envir) %||% envir
}
# Returns an environment if expression is called directly from `source()`.
# Otherwise returns `NULL`.
source_exit_frame_option <- function(envir, frames = as.list(sys.frames())) {
calls <- as.list(sys.calls())
i <- frame_loc(envir, frames)
if (!i) {
return(NULL)
}
if (i < 4) {
return(NULL)
}
is_call <- function(x, fn) {
is.call(x) && identical(x[[1]], fn)
}
calls <- as.list(calls)
if (!is_call(calls[[i - 3]], quote(source))) {
return(NULL)
}
if (!is_call(calls[[i - 2]], quote(withVisible))) {
return(NULL)
}
if (!is_call(calls[[i - 1]], quote(eval))) {
return(NULL)
}
if (!is_call(calls[[i - 0]], quote(eval))) {
return(NULL)
}
frames[[i - 3]]
}
frame_loc <- function(envir, frames) {
n <- length(frames)
if (!n) {
return(0)
}
for (i in seq_along(frames)) {
if (identical(frames[[n - i + 1]], envir)) {
return(n - i + 1)
}
}
0
}
in_knitr <- function(envir) {
knitr_in_progress() && identical(knitr::knit_global(), envir)
}
knitr_in_progress <- function() {
isTRUE(getOption("knitr.in.progress"))
}
|
