Skip to content

Commit 51e62e2

Browse files
hadleyhadley
authored
More file reorg (#167)
* More output handler to own file * Eliminate unused function * Move specific class checks to `output.R` and use in `output_type()`
1 parent be1f9cf commit 51e62e2

9 files changed

+254
-271
lines changed

‎R/evaluation.R

+27-5
Original file line numberDiff line numberDiff line change
@@ -40,17 +40,39 @@ print.evaluate_evaluation <- function(x, ...) {
4040
output_type <- function(x) {
4141
if (is.character(x)) {
4242
"text"
43-
} else if (inherits(x, "error")) {
43+
} else if (is.error(x)) {
4444
"error"
45-
} else if (inherits(x, "warning")) {
45+
} else if (is.warning(x)) {
4646
"warning"
47-
} else if (inherits(x, "message")) {
47+
} else if (is.message(x)) {
4848
"message"
49-
} else if (inherits(x, "recordedplot")) {
49+
} else if (is.recordedplot(x)) {
5050
"plot"
51-
} else if (inherits(x, "source")) {
51+
} else if (is.source(x)) {
5252
"source"
5353
} else {
5454
class(x)[[1]]
5555
}
5656
}
57+
58+
#' Object class tests
59+
#'
60+
#' @keywords internal
61+
#' @rdname is.message
62+
#' @export
63+
is.message <- function(x) inherits(x, "message")
64+
#' @rdname is.message
65+
#' @export
66+
is.warning <- function(x) inherits(x, "warning")
67+
#' @rdname is.message
68+
#' @export
69+
is.error <- function(x) inherits(x, "error")
70+
#' @rdname is.message
71+
#' @export
72+
is.value <- function(x) inherits(x, "value")
73+
#' @rdname is.message
74+
#' @export
75+
is.source <- function(x) inherits(x, "source")
76+
#' @rdname is.message
77+
#' @export
78+
is.recordedplot <- function(x) inherits(x, "recordedplot")

‎R/output-handler.R

+95
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,95 @@
1+
#' Custom output handlers
2+
#'
3+
#' An `output_handler` handles the results of [evaluate()],
4+
#' including the values, graphics, conditions. Each type of output is handled by
5+
#' a particular function in the handler object.
6+
#'
7+
#' The handler functions should accept an output object as their first argument.
8+
#' The return value of the handlers is ignored, except in the case of the
9+
#' `value` handler, where a visible return value is saved in the output
10+
#' list.
11+
#'
12+
#' Calling the constructor with no arguments results in the default handler,
13+
#' which mimics the behavior of the console by printing visible values.
14+
#'
15+
#' Note that recursion is common: for example, if `value` does any
16+
#' printing, then the `text` or `graphics` handlers may be called.
17+
#'
18+
#' @param source Function to handle the echoed source code under evaluation.
19+
#' This function should take two arguments (`src` and `call`), and return
20+
#' an object that will be inserted into the evaluate outputs. `src` is the
21+
#' unparsed text of the source code, and `call` is the parsed language object
22+
#' If `src` is unparsable, `call` will be `expression()`.
23+
#'
24+
#' Return `src` for the default evaluate behaviour. Return `NULL` to
25+
#' drop the source from the output.
26+
#' @param text Function to handle any textual console output.
27+
#' @param graphics Function to handle graphics, as returned by
28+
#' [recordPlot()].
29+
#' @param message Function to handle [message()] output.
30+
#' @param warning Function to handle [warning()] output.
31+
#' @param error Function to handle [stop()] output.
32+
#' @param value Function to handle the values returned from evaluation.
33+
#' * If it has one argument, it called on visible values.
34+
#' * If it has two arguments, it handles all values, with the second
35+
#' argument indicating whether or not the value is visible.
36+
#' @param calling_handlers List of [calling handlers][withCallingHandlers].
37+
#' These handlers have precedence over the exiting handler installed
38+
#' by [evaluate()] when `stop_on_error` is set to 0.
39+
#' @return A new `output_handler` object
40+
#' @aliases output_handler
41+
#' @export
42+
new_output_handler <- function(source = identity,
43+
text = identity, graphics = identity,
44+
message = identity, warning = identity,
45+
error = identity, value = render,
46+
calling_handlers = list()) {
47+
source <- match.fun(source)
48+
stopifnot(length(formals(source)) >= 1)
49+
text <- match.fun(text)
50+
stopifnot(length(formals(text)) >= 1)
51+
graphics <- match.fun(graphics)
52+
stopifnot(length(formals(graphics)) >= 1)
53+
message <- match.fun(message)
54+
stopifnot(length(formals(message)) >= 1)
55+
warning <- match.fun(warning)
56+
stopifnot(length(formals(warning)) >= 1)
57+
error <- match.fun(error)
58+
stopifnot(length(formals(error)) >= 1)
59+
value <- match.fun(value)
60+
stopifnot(length(formals(value)) >= 1)
61+
62+
check_handlers(calling_handlers)
63+
64+
structure(list(source = source, text = text, graphics = graphics,
65+
message = message, warning = warning, error = error,
66+
value = value, calling_handlers = calling_handlers),
67+
class = "output_handler")
68+
}
69+
70+
check_handlers <- function(x) {
71+
if (!is.list(x)) {
72+
stop_bad_handlers()
73+
}
74+
75+
if (!length(x)) {
76+
return()
77+
}
78+
79+
names <- names(x)
80+
if (!is.character(names) || anyNA(names) || any(names == "")) {
81+
stop_bad_handlers()
82+
}
83+
84+
for (elt in x) {
85+
if (!is.function(elt)) {
86+
stop_bad_handlers()
87+
}
88+
}
89+
}
90+
stop_bad_handlers <- function() {
91+
stop(simpleError(
92+
"`calling_handlers` must be a named list of functions.",
93+
call = call("new_output_handler")
94+
))
95+
}

‎R/output.R

-134
Original file line numberDiff line numberDiff line change
@@ -1,29 +1,3 @@
1-
#' Object class tests
2-
#'
3-
#' @keywords internal
4-
#' @rdname is.message
5-
#' @export
6-
is.message <- function(x) inherits(x, "message")
7-
#' @rdname is.message
8-
#' @export
9-
is.warning <- function(x) inherits(x, "warning")
10-
#' @rdname is.message
11-
#' @export
12-
is.error <- function(x) inherits(x, "error")
13-
#' @rdname is.message
14-
#' @export
15-
is.value <- function(x) inherits(x, "value")
16-
#' @rdname is.message
17-
#' @export
18-
is.source <- function(x) inherits(x, "source")
19-
#' @rdname is.message
20-
#' @export
21-
is.recordedplot <- function(x) inherits(x, "recordedplot")
22-
23-
new_value <- function(value, visible = TRUE) {
24-
structure(list(value = value, visible = visible), class = "value")
25-
}
26-
271
new_source <- function(src, call, handler = NULL) {
282
src <- structure(list(src = src), class = "source")
293
if (is.null(handler)) {
@@ -61,111 +35,3 @@ handle_value <- function(handler, value, visible) {
6135
}
6236

6337
render <- function(x) if (isS4(x)) methods::show(x) else print(x)
64-
65-
#' Custom output handlers
66-
#'
67-
#' An `output_handler` handles the results of [evaluate()],
68-
#' including the values, graphics, conditions. Each type of output is handled by
69-
#' a particular function in the handler object.
70-
#'
71-
#' The handler functions should accept an output object as their first argument.
72-
#' The return value of the handlers is ignored, except in the case of the
73-
#' `value` handler, where a visible return value is saved in the output
74-
#' list.
75-
#'
76-
#' Calling the constructor with no arguments results in the default handler,
77-
#' which mimics the behavior of the console by printing visible values.
78-
#'
79-
#' Note that recursion is common: for example, if `value` does any
80-
#' printing, then the `text` or `graphics` handlers may be called.
81-
#'
82-
#' @param source Function to handle the echoed source code under evaluation.
83-
#' This function should take two arguments (`src` and `call`), and return
84-
#' an object that will be inserted into the evaluate outputs. `src` is the
85-
#' unparsed text of the source code, and `call` is the parsed language object
86-
#' If `src` is unparsable, `call` will be `expression()`.
87-
#'
88-
#' Return `src` for the default evaluate behaviour. Return `NULL` to
89-
#' drop the source from the output.
90-
#' @param text Function to handle any textual console output.
91-
#' @param graphics Function to handle graphics, as returned by
92-
#' [recordPlot()].
93-
#' @param message Function to handle [message()] output.
94-
#' @param warning Function to handle [warning()] output.
95-
#' @param error Function to handle [stop()] output.
96-
#' @param value Function to handle the values returned from evaluation.
97-
#' * If it has one argument, it called on visible values.
98-
#' * If it has two arguments, it handles all values, with the second
99-
#' argument indicating whether or not the value is visible.
100-
#' @param calling_handlers List of [calling handlers][withCallingHandlers].
101-
#' These handlers have precedence over the exiting handler installed
102-
#' by [evaluate()] when `stop_on_error` is set to 0.
103-
#' @return A new `output_handler` object
104-
#' @aliases output_handler
105-
#' @export
106-
new_output_handler <- function(source = identity,
107-
text = identity,
108-
graphics = identity,
109-
message = identity,
110-
warning = identity,
111-
error = identity,
112-
value = render,
113-
calling_handlers = list()) {
114-
source <- match.fun(source)
115-
stopifnot(length(formals(source)) >= 1)
116-
text <- match.fun(text)
117-
stopifnot(length(formals(text)) >= 1)
118-
graphics <- match.fun(graphics)
119-
stopifnot(length(formals(graphics)) >= 1)
120-
message <- match.fun(message)
121-
stopifnot(length(formals(message)) >= 1)
122-
warning <- match.fun(warning)
123-
stopifnot(length(formals(warning)) >= 1)
124-
error <- match.fun(error)
125-
stopifnot(length(formals(error)) >= 1)
126-
value <- match.fun(value)
127-
stopifnot(length(formals(value)) >= 1)
128-
129-
check_handlers(calling_handlers)
130-
131-
structure(
132-
list(
133-
source = source,
134-
text = text,
135-
graphics = graphics,
136-
message = message,
137-
warning = warning,
138-
error = error,
139-
value = value,
140-
calling_handlers = calling_handlers
141-
),
142-
class = "output_handler"
143-
)
144-
}
145-
146-
check_handlers <- function(x) {
147-
if (!is.list(x)) {
148-
stop_bad_handlers()
149-
}
150-
151-
if (!length(x)) {
152-
return()
153-
}
154-
155-
names <- names(x)
156-
if (!is.character(names) || anyNA(names) || any(names == "")) {
157-
stop_bad_handlers()
158-
}
159-
160-
for (elt in x) {
161-
if (!is.function(elt)) {
162-
stop_bad_handlers()
163-
}
164-
}
165-
}
166-
stop_bad_handlers <- function() {
167-
stop(simpleError(
168-
"`calling_handlers` must be a named list of functions.",
169-
call = call("new_output_handler")
170-
))
171-
}

‎man/is.message.Rd

+1-1
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎man/new_output_handler.Rd

+1-1
Some generated files are not rendered by default. Learn more about customizing how changed files appear on GitHub.

‎tests/testthat/_snaps/output-handler.md

+31
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
# calling handlers are checked
2+
3+
Code
4+
check_handlers(list(condition = 1))
5+
Condition
6+
Error in `new_output_handler()`:
7+
! `calling_handlers` must be a named list of functions.
8+
Code
9+
check_handlers(list(function(...) NULL))
10+
Condition
11+
Error in `new_output_handler()`:
12+
! `calling_handlers` must be a named list of functions.
13+
Code
14+
check_handlers(stats::setNames(list(function(...) NULL), NA))
15+
Condition
16+
Error in `new_output_handler()`:
17+
! `calling_handlers` must be a named list of functions.
18+
Code
19+
check_handlers(stats::setNames(list(function(...) NULL), ""))
20+
Condition
21+
Error in `new_output_handler()`:
22+
! `calling_handlers` must be a named list of functions.
23+
24+
# can conditionally omit output with output handler
25+
26+
Code
27+
replay(out)
28+
Output
29+
> x
30+
[1] 1
31+

‎tests/testthat/_snaps/output.md

-31
Original file line numberDiff line numberDiff line change
@@ -1,34 +1,3 @@
1-
# calling handlers are checked
2-
3-
Code
4-
check_handlers(list(condition = 1))
5-
Condition
6-
Error in `new_output_handler()`:
7-
! `calling_handlers` must be a named list of functions.
8-
Code
9-
check_handlers(list(function(...) NULL))
10-
Condition
11-
Error in `new_output_handler()`:
12-
! `calling_handlers` must be a named list of functions.
13-
Code
14-
check_handlers(stats::setNames(list(function(...) NULL), NA))
15-
Condition
16-
Error in `new_output_handler()`:
17-
! `calling_handlers` must be a named list of functions.
18-
Code
19-
check_handlers(stats::setNames(list(function(...) NULL), ""))
20-
Condition
21-
Error in `new_output_handler()`:
22-
! `calling_handlers` must be a named list of functions.
23-
24-
# can conditionally omit output with output handler
25-
26-
Code
27-
replay(out)
28-
Output
29-
> x
30-
[1] 1
31-
321
# handles various numbers of arguments
332

343
Code

0 commit comments

Comments
 (0)