# Find all calls to a given function within a piece of code
#' @importFrom utils getParseText
find_function_calls <- function(pd, name, env) {
# summarize vs summarise hack
if (name == "summarise") pd$text <- gsub("summarize", "summarise", pd$text)
if (name == "summarize") pd$text <- gsub("summarise", "summarize", pd$text)
# Retrieve all function calls from parse information
fun_ids <- pd$parent[pd$text == name & pd$token == "SYMBOL_FUNCTION_CALL"]
lapply(fun_ids, get_call_data, pd = pd, env = env)
}
get_call_data <- function(fun_id, pd, env) {
expr_id <- pd$parent[pd$id == fun_id]
# if parent expression contains %>% on left hand side ...
siblings <- pd$id[pd$parent == pd$parent[pd$id == expr_id]]
if ("%>%" %in% pd$text[pd$id %in% siblings] && pd$id[pd$text == "%>%" & pd$id %in% siblings] < expr_id) {
# ... go one level up, normalize call, and return string
expr_id <- pd$parent[pd$id == expr_id]
expr_string <- deparse(unpipe(as.call(parse(text = getParseText(pd, expr_id)))[[1]]))
} else {
expr_string <- getParseText(pd, expr_id)
}
expr <- parse(text = expr_string)
original_call <- as.call(expr)[[1]]
standard_call <- standardize_call(original_call, expr_string, env)
function_pd <- get_sub_pd(pd = pd, expr_id)
arg_pds <- get_args(function_pd, standard_call)
list(call = standard_call, pd = function_pd, args = arg_pds)
}
# Find all operators in the parse data
#' @importFrom utils getParseText
find_operators <- function(pd, name, env) {
parent_ids <- pd$parent[pd$text == name]
lapply(parent_ids, function(id) {
call <- getParseText(pd, id)
pd <- pd[pd$id == id, ]
list(call = parse(text = call), pd = pd)
})
}
clean <- function(x) {
x <- gsub("\\s", "", x)
gsub("'", "\"", x)
}
get_args <- function(pd, standard_call) {
n <- length(standard_call)
if(n == 1) {
return(list())
}
params <- standard_call[-1]
args <- lapply(params, function(param) {
id <- pd$id[clean(deparse(param)) == clean(pd$text) & pd$token == "expr"]
list(expr = param, pd = get_sub_pd(pd, id))
})
# Some arguments are not named because passed via ...
# Group these arguments in a list
m <- length(args)
if (is.null(names(args))) {
# All are unnamed
args <- list("..." = args)
} else {
hits <- which(names(args) == "")
if (length(hits) > 0) {
# Some arguments not named
args[["..."]] <- args[hits]
args[hits] <- NULL
}
}
return(args)
}
# Expand argument names of a function call (borrowed from pryr standardise_call)
standardize_call <- function(call, call_string, env) {
stopifnot(is.call(call))
name <- as.character(call[[1]])
if (name[[1]] == "::") {
f <- getExportedValue(name[[2]], name[[3]])
} else if (name[[1]] == ":::") {
f <- get(name[[3]], envir = asNamespace(name[[2]]), inherits = FALSE)
} else {
f <- get(name, env)
}
a <- args(f)
e <- try(match.call(a, call), silent = TRUE)
e <- find_S3_call(matched_call = e, call = call, env = env)
if (inherits(e, "try-error")) {
check_that(failure(),
sprintf("There is something wrong in the following function call **%s**: _%s_",
call_string,
attr(e,"condition")$message))
} else {
return(e)
}
}
#' @importFrom utils getAnywhere methods
find_S3_call <- function(matched_call, call, env) {
if (inherits(matched_call, "try-error")) {
return(matched_call)
}
call_method <- as.character(matched_call[[1]])
met <- try(suppressWarnings(methods(call_method)), silent = TRUE)
if (inherits(met, "try-error")) {
return(matched_call)
} else if (length(met) == 0) {
return(matched_call)
} else if (length(matched_call) < 2) {
return(matched_call)
} else {
call_class <- try(class(eval(matched_call[[2]], env)), silent = TRUE)
if (inherits(call_class, "try-error")) {
return(matched_call)
}
call_dispatched <- paste(call_method, call_class, sep = ".")
find_call <- rep(FALSE, length(met))
for (one_call in call_dispatched) {
find_call <- met == one_call
if (any(find_call)) {
call_dispatched <- one_call
break
}
}
if (!any(find_call)) {
call_dispatched <- paste(call_method, "default", sep = ".")
cal_class <- "default"
find_call <- met == call_dispatched
if (!any(find_call)) {
# At this point, we are almost certain the call is a primitive.
# Just ignore.
return(matched_call)
}
}
find_call <- which(find_call)
vis <- attr(met, "info")$visible[find_call]
if (vis) {
f <- args(get(call_dispatched, env))
} else {
f <- args(getAnywhere(call_dispatched)[1])
}
return(try(match.call(f, call), silent = TRUE))
}
}
# Convert an expression that uses the pipe operator to a regular embedded expression.
unpipe <- function(expr) {
cnv <- function(x) {
lhs <- x[[2]]
rhs <- x[[3]]
if (any(all.names(rhs) == "%>%")) rhs <- decomp(rhs)
if (any(all.names(lhs) == "%>%")) lhs <- decomp(lhs)
# main
is_dot <- vapply(rhs, identical, logical(1L), as.name("."))
if(any(is_dot)) {
rhs[is_dot] <- as.expression(lhs)
rhs
} else if (is.symbol(rhs) || rhs[[1]] == "function" || rhs[[1]] == "(") {
as.call(c(rhs, lhs))
} else if (is.call(rhs)) {
as.call(c(rhs[[1]], lhs, lapply(rhs[-1], decomp)))
} else {
stop("missing condition error")
}
}
decomp <- function(x) {
if (length(x) == 1) x
else if (length(x) == 3 && x[[1]] == "%>%") cnv(x)
else if (is.pairlist(x)) as.pairlist(lapply(x, decomp))
else as.call(lapply(x, decomp))
}
decomp(expr)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.