#' A single result.
#'
#' @param object Wrap object into a `result` class.
#' @param id Object identifier in [storage::object_store].
#'
result <- function (object, id)
{
structure(list(object = object, id = id), class = 'result')
}
#' A set (list) of results.
#'
#' @param res A `list` of objects to wrap in a `results` class.
#'
results <- function (res)
{
stopifnot(is.list(res), all_named(res))
structure(
mapply(result, object = res, id = names(res), SIMPLIFY = FALSE, USE.NAMES = FALSE),
class = 'results'
)
}
is_results <- function (x) inherits(x, "results")
#' @export
`.DollarNames.result` <- function (x, pattern = "")
{
grep(pattern, c('commit', 'object', 'id'), value = TRUE)
}
#' @export
`$.result` <- function (x, i)
{
if (identical(i, 'id') || identical(i, 'object')) {
return(x[[i]])
}
if (identical(i, 'commit')) {
g <- graph(internal_state$stash)
return(find_first_parent(g, x$id))
}
stop('unknown option: ', i, call. = FALSE)
}
#' @export
`.DollarNames.results` <- function (x, pattern = "")
{
ids <- vapply(x, `[[`, character(1), i = 'id')
srt <- storage::shorten(ids)
ids <- if (anyDuplicated(srt)) ids else srt
grep(pattern, c('tidy', ids), value = TRUE)
}
#' @export
`$.results` <- function (x, i)
{
ids <- vapply(x, `[[`, character(1), i = 'id')
short_ids <- storage::shorten(ids)
if (identical(i, 'tidy')) {
rows <- lapply(x, function (x) broom::tidy(x$object))
return(cbind(id = short_ids, do.call(rbind, rows)))
}
if (length(j <- match(i, short_ids))) return(x[[j]])
if (length(j <- match(i, ids))) return(x[[j]])
stop('unknown option: ', i, call. = FALSE)
}
# --- printing ---
#' @export
print.results <- function (x, ...)
{
stopifnot(is.list(x))
lapply(x, function (result) {
cat(crayon::green(storage::shorten(result[['id']])), ': ')
print(result, indent = 10)
})
}
print.result <- function (x, ...) print_result(x[['object']], ...)
print_result <- function (x, ...) UseMethod("print_result")
print_result.default <- function (x, ...)
{
print(x)
}
#' @importFrom stringi stri_sub
print_result.lm <- function (x, digits = 2, indent = 0, ...)
{
glance <- broom::glance(x)
values <- format(glance, digits = digits)
glance <- paste(names(glance), values, sep = ':', collapse = ' ')
cls <- paste(class(x), collapse = ' ')
frm <- format(x$call$formula)
indent <- indent + nchar(cls) + nchar(frm) + 5
glance <- strwrap(glance, width = getOption("width") - indent)
if (length(glance) > 1) {
glance <- paste0(stringi::stri_sub(glance[1], 1, -3), '...')
}
cat(crayon::red(cls),
'',
crayon::yellow(frm),
' ',
glance,
'\n')
}
# --- plotting ---
#' @export
`plot.results` <- function (x, xlab = 'adj.r.squared', ylab = 'AIC', ...)
{
stopifnot(is_results(x))
glance <- lapply(x, function (r) broom::glance(r$object))
shared <- Reduce(intersect, lapply(glance, names))
present <- function (v)
if (!isTRUE(v %in% shared)) stop(v, ' is not available for all objects', call. = FALSE)
present(xlab)
present(ylab)
X <- vapply(glance, `[[`, numeric(1), i = xlab)
Y <- vapply(glance, `[[`, numeric(1), i = ylab)
plot(X, Y, xlab = xlab, ylab = ylab)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.