#' Grab any bindings from a pattern match
#'
#' UNLIKE the `check_` functions which return `checkr_result` objects,
#' `grab_bindings` returns a list with the values matched to the keys.
#'
#' @param ex the expression to be searched for the patterns
#' @param ... the set of patterns. Each pattern must be be enclosed in `quote()`. See details.
#' @param key_list specify a set of patterns as a list of quoted expressions, rather than putting them
#' individually in `...`
#' @param one_for_all Logical. If `TRUE`, then all patterns must match at least one
#' expression in ex.
#' @param all_for_one Logical. If `TRUE`, then there must be an expression
#' that matches all patterns.
#' @param key for `grab_bindings_anywhere()`, a single pattern as a quoted expression
#'
#' @details The patterns in `...` will often have internal commas. To distinquish these
#' from separate arguments to `grab_bindings()`, each pattern must be quoted, e.g. `quote(plot(.(one), .(two)))`.
#' Note that the patterns should include assignment if there is to be any.
#'
#' @examples
#' ex <- for_checkr(quote(plot(mpg ~ wt, data = subset(mtcars, hp < 150))))
#' grab_bindings(ex, quote(.(fn)(.(formula), data = .(the_data))))
#' ex2 <- for_checkr(quote({x <- 1; y <- x^2}))
#' grab_bindings(ex2, quote(`<-`(x, ..(first))),
#' quote(`<-`(.(var), .(fn)(x, .(exponent)))), all_for_one = FALSE)
#' grab_bindings(ex2, quote(`<-`(x, ..(first))),
#' quote(`<-`(.(var), .(fn)(x, .(exponent)))))
#' grab_binding_anywhere(for_checkr(quote({4 - 7;sin(3 + 2)})), quote(`+`(.(a), .(b))))
#' grab_binding_anywhere(for_checkr(quote({4 - 7;sin(3 + 2)})), quote(.(fn)(3 + 2)))
#' grab_binding_anywhere(for_checkr(quote({4 - 7;sin(3 + 2)})), quote(`-`(.(a), .(b))))
#' @export
grab_bindings <- function(ex, ..., key_list = NULL,
all_for_one = TRUE,
one_for_all = FALSE) {
stopifnot(inherits(ex, "checkr_result"))
keys <-
if (!is.null(key_list)) {
if (is.list(key_list)) key_list
else list(key_list)
} else list(...)
bindings <- list()
if (length(keys) == 0) stop("No expressions given for argument 'keys'.")
expressions_matched <- rep(FALSE, length(ex$code))
for (m in seq_along(ex$code)) {
patterns_matched <- rep(FALSE, length(keys))
for (k in seq_along(keys)) {
# a formula whose RHS copies the environment
# that node_match will put in .data
pattern <- LHS ~ copy_env(.data)
rlang::f_lhs(pattern) <- rlang::expr( !! keys[[k]])
# Grab the list of bindings
new_bindings <-
try(redpen::node_match(ex$code[[m]], !!pattern),
silent = TRUE)
if (inherits(new_bindings, "try-error") || is.null(new_bindings)) {
next
} else {
expressions_matched[m] <- TRUE
patterns_matched[k] <- TRUE
new_bindings$. <- NULL
bindings <- c(bindings[! names(bindings) %in% names(new_bindings)], new_bindings)
}
}
}
if (all_for_one && ! all(patterns_matched)) return(NULL)
if (one_for_all && ! all(expressions_matched)) return(NULL)
# success!
bindings
}
#' @rdname grab_bindings
#' @export
grab_binding_anywhere <- function(ex, key) {
stopifnot(inherits(ex, "checkr_result"))
if (failed(ex)) return(ex) # short circuit
for (m in seq_along(ex$code)) {
pattern <- LHS ~ copy_env(.data)
rlang::f_lhs(pattern) <- rlang::expr( !! key)
bindings <-redpen::node_match(ex$code[[m]], !!pattern)
if ( ! is.null(bindings)) return(bindings)
else {# no match, so try recursively with arguments
if (is.call(ex$code[[m]])) {
args <- rlang::lang_args(ex$code[[m]])
tmp <- ex
for (k in seq_along(args)) {
tmp$code <- args[k]
res <- grab_binding_anywhere(tmp, key)
if (! is.null(res)) return(res)
}
}
}
}
NULL
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.