/
pkg_metric.R
89 lines (68 loc) · 2.24 KB
/
pkg_metric.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
#' A helper for structuring assessment return objects for dispatch with the
#' score function
#'
#' @param x data to store as a \code{pkg_metric}
#' @param ... additional attributes to bind to the \code{pkg_metric} object
#' @param class a subclass to differentiate the \code{pkg_metric} object
#'
#' @return a \code{pkg_metric} object
#'
#' @export
pkg_metric <- function(x = NA, ..., class = c()) {
if (is.null(x)) x <- list()
structure(x, ..., class = c(class, "pkg_metric", class(x)))
}
#' Convert an object to a \code{pkg_metric}
#'
#' @inheritParams pkg_metric
#' @return a \code{pkg_metric} object
#' @export
as_pkg_metric <- function(x, class = c()) {
UseMethod("as_pkg_metric")
}
#' @export
as_pkg_metric.default <- function(x, class = c()) {
pkg_metric(x, class = class)
}
#' @export
as_pkg_metric.expr_output <- function(x, class = c()) {
x_metric <- pkg_metric(x, class = class)
if (is_error(x))
x_metric <- as_pkg_metric_error(x_metric)
x_metric
}
#' Evaluate a metric
#'
#' Evalute code relevant to a metric, capturing the evaluated code as well as
#' any messages, warnings or errors that are thrown in the process.
#'
#' @param expr An expression to evaluate in order to calculate a
#' \code{pkg_metric}
#' @param env An environment in which \code{expr} is to be evaluated
#' @inheritParams pkg_metric
#'
#' @return a \code{pkg_metric} object containing the result of \code{expr}
#' @keywords internal
pkg_metric_eval <- function(expr, ..., class = c(), env = parent.frame()) {
out <- capture_expr_output(substitute(expr), env = env, quoted = TRUE)
out_metric <- as_pkg_metric(out, class = class)
if (inherits(out, "error")) out_metric <- as_pkg_metric_error(out_metric)
out_metric
}
#' @importFrom vctrs vec_ptype_abbr
#' @method vec_ptype_abbr pkg_metric
#' @export
vec_ptype_abbr.pkg_metric <- function(x, ...) {
"pkg_metric"
}
#' @export
format.pkg_metric_error <- function(x, ...) {
class_str <- gsub("^pkg_metric_", "", class(x)[[1]])
pillar::style_na(paste0("<", class_str, ">"))
}
#' @export
format.pkg_metric <- function(x, ...) {
class_str <- gsub("^pkg_metric_", "", class(x)[[1]])
data_str <- with_unclassed_to(x, "pkg_metric", pillar::pillar_shaft(x))
paste0(capture.output(data_str), collapse = "")
}