Permalink
Branch: master
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
136 lines (116 sloc) 3.29 KB
#' Display tree of references
#'
#' This tree display focusses on the distinction between names and values.
#' For each reference-type object (lists, environments, and optional character
#' vectors), it displays the location of each component. The display
#' shows the connection between shared references using a locally unique id.
#'
#' @param ... One or more objects
#' @param character If `TRUE`, show references from character vector in to
#' global string pool
#' @export
#' @examples
#' x <- 1:100
#' ref(x)
#'
#' y <- list(x, x, x)
#' ref(y)
#' ref(x, y)
#'
#' e <- new.env()
#' e$e <- e
#' e$x <- x
#' e$y <- list(x, e)
#' ref(e)
#'
#' # Can also show references to global string pool if requested
#' ref(c("x", "x", "y"))
#' ref(c("x", "x", "y"), character = TRUE)
ref <- function(..., character = FALSE) {
x <- list(...)
seen <- child_env(emptyenv(), `__next_id` = 1)
out <- lapply(x, ref_tree, character = character, seen = seen)
n <- length(x)
if (n > 1) {
out[-n] <- lapply(out[-n], function(x) c(x, ""))
}
new_raw(unlist(out))
}
ref_tree <- function(x, character = FALSE, seen = child_env(emptyenv()), layout = box_chars()) {
addr <- obj_addr(x)
has_seen <- env_has(seen, addr)
id <- obj_id(seen, addr)
desc <- obj_desc(addr, type_sum(x), has_seen, id)
# Not recursive or already seen
if (!has_references(x, character) || has_seen) {
return(desc)
}
# Remove classes to avoid custom methods (note that environments cannot be unclasse()ed)
attr(x, "class") <- NULL
# recursive cases
if (is.list(x)) {
subtrees <- lapply(x, ref_tree, layout = layout, seen = seen, character = character)
} else if (is.environment(x)) {
subtrees <- lapply(as.list(x), ref_tree, layout = layout, seen = seen, character = character)
} else if (is.character(x)) {
subtrees <- ref_tree_chr(x, layout = layout, seen = seen)
}
subtrees <- name_subtree(subtrees)
self <- str_indent(desc, paste0(layout$n, " "), paste0(layout$v, " "))
n <- length(subtrees)
if (n == 0) {
return(self)
}
c(
self,
unlist(lapply(subtrees[-n],
str_indent,
paste0(layout$j, layout$h),
paste0(layout$v, " ")
)),
str_indent(subtrees[[n]],
paste0(layout$l, layout$h),
" "
)
)
}
type_sum <- function(x) {
if (is_installed("pillar")) {
pillar::type_sum(x)
} else {
typeof(x)
}
}
obj_desc <- function(addr, type, has_seen, id) {
if (has_seen) {
paste0("[", grey(paste0(id, ":", addr)), "]")
} else {
paste0("[", crayon::bold(id), ":", addr, "] ", "<", type, ">")
}
}
has_references <- function(x, character = FALSE) {
is_list(x) || is.environment(x) || (character && is_character(x))
}
ref_tree_chr <- function(x, layout = box_chars(), seen = child_env(emptyenv())) {
addrs <- obj_addrs(x)
has_seen <- logical(length(x))
ids <- integer(length(x))
for (i in seq_along(addrs)) {
has_seen[[i]] <- env_has(seen, addrs[[i]])
ids[[i]] <- obj_id(seen, addrs[[i]])
}
type <- paste0('string: "', str_truncate(x, 10), '"')
out <- Map(obj_desc, addrs, type, has_seen, ids)
names(out) <- names(x)
out
}
obj_id <- function(env, ref) {
if (env_has(env, ref)) {
env_get(env, ref)
} else {
id <- env_get(env, "__next_id")
env_poke(env, "__next_id", id + 1)
env_poke(env, ref, id)
id
}
}