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
|
#' Replace a function with a stub.
#'
#' The result of calling \code{stub} is that, when \code{where}
#' is invoked and when it internally makes a call to \code{what},
#' \code{how} is going to be called instead.
#'
#' This is much more limited in scope in comparison to
#' \code{\link[testthat]{with_mock}} which effectively replaces
#' \code{what} everywhere. In other words, when using \code{with_mock}
#' and regardless of the number of intermediate calls, \code{how} is
#' always called instead of \code{what}. However, using this API,
#' the replacement takes place only for a single function \code{where}
#' and only for calls originating in that function.
#'
#'
#' @name stub
#' @rdname stub
NULL
# \code{remote_stub} reverses the effect of \code{stub}.
#' @param where Function to be called that will in turn call
#' \code{what}.
#' @param what Name of the function you want to stub out (a
#' \code{character} string).
#' @param how Replacement function (also a \code{\link{mock}} function)
#' or a return value for which a function will be created
#' automatically.
#' @param depth Specifies the depth to which the function should be stubbed
#'
#' @export
#' @rdname stub
#'
#' @examples
#' f <- function() TRUE
#' g <- function() f()
#' stub(g, 'f', FALSE)
#'
#' # now g() returns FALSE because f() has been stubbed out
#' g()
#'
`stub` <- function (where, what, how, depth=1)
{
# `where` needs to be a function
where_name <- deparse(substitute(where))
# `what` needs to be a character value
stopifnot(is.character(what), length(what) == 1)
test_env <- parent.frame()
tree <- build_function_tree(test_env, where, where_name, depth)
mock_through_tree(tree, what, how)
}
mock_through_tree <- function(tree, what, how) {
for (d in tree) {
for (parent in d) {
parent_env = parent[['parent_env']]
func_dict = parent[['funcs']]
for (func_name in ls(func_dict, all.names=TRUE)) {
func = func_dict[[func_name]]
func_env = new.env(parent = environment(func))
what <- override_seperators(what, func_env)
where_name <- override_seperators(func_name, parent_env)
if (!is.function(how)) {
assign(what, function(...) how, func_env)
} else {
assign(what, how, func_env)
}
environment(func) <- func_env
assign(where_name, func, parent_env)
}
}
}
}
override_seperators = function(name, env) {
for (sep in c('::', "$")) {
if (grepl(sep, name, fixed = TRUE)) {
elements <- strsplit(name, sep, fixed = TRUE)
mangled_name <- paste(elements[[1L]][1L], elements[[1L]][2L], sep='XXX')
stub_list <- c(mangled_name)
if ("stub_list" %in% names(attributes(get(sep, env)))) {
stub_list <- c(stub_list, attributes(get(sep, env))[['stub_list']])
}
create_new_name <- create_create_new_name_function(stub_list, env, sep)
assign(sep, create_new_name, env)
}
}
return(if (exists('mangled_name')) mangled_name else name)
}
backtick <- function(x) {
encodeString(x, quote = "`", na.encode = FALSE)
}
create_create_new_name_function <- function(stub_list, env, sep)
{
force(stub_list)
force(env)
force(sep)
create_new_name <- function(pkg, func)
{
pkg_name <- deparse(substitute(pkg))
func_name <- deparse(substitute(func))
for(stub in stub_list) {
if (paste(pkg_name, func_name, sep='XXX') == stub) {
return(eval(parse(text = backtick(stub)), env))
}
}
# used to avoid recursively calling the replacement function
eval_env = new.env(parent=parent.frame())
assign(sep, eval(parse(text=paste0('`', sep, '`'))), eval_env)
code = paste(pkg_name, backtick(func_name), sep=sep)
return(eval(parse(text=code), eval_env))
}
attributes(create_new_name) <- list(stub_list=stub_list)
return(create_new_name)
}
build_function_tree <- function(test_env, where, where_name, depth)
{
func_dict = new.env()
func_dict[[where_name]] = where
tree = list(
# one depth
list(
# one parent
list(parent_env=test_env, funcs=func_dict)
)
)
if (depth > 1) {
for (d in 2:depth) {
num_parents = 0
new_depth = list()
for (funcs in tree[[d - 1]]) {
parent_dict = funcs[['funcs']]
for (parent_name in ls(parent_dict, all.names=TRUE)) {
func_dict = new.env()
parent_env = environment(get(parent_name, parent_dict))
for (func_name in ls(parent_env, all.names=TRUE)) {
func = get(func_name, parent_env)
if (is.function(func)) {
func_dict[[func_name]] = func
}
}
new_parent = list(parent_env=parent_env, funcs=func_dict)
num_parents = num_parents + 1
new_depth[[num_parents]] = new_parent
}
}
tree[[d]] = new_depth
}
}
return(tree)
}
|
