#' @title Prepare the workflow graph for visualization
#' `r lifecycle::badge("stable")`
#' @description With the returned data frames,
#' you can plot your own custom `visNetwork` graph.
#' @export
#' @return A list of three data frames: one for nodes,
#' one for edges, and one for
#' the legend nodes. The list also contains the
#' default title of the graph.
#' @seealso [vis_drake_graph()]
#' @param ... Arguments to [make()], such as `plan` and `targets`.
#'
#' @param config Deprecated.
#'
#' @param from Optional collection of target/import names.
#' If `from` is nonempty,
#' the graph will restrict itself to
#' a neighborhood of `from`.
#' Control the neighborhood with
#' `mode` and `order`.
#'
#' @param mode Which direction to branch out in the graph
#' to create a neighborhood around `from`.
#' Use `"in"` to go upstream,
#' `"out"` to go downstream,
#' and `"all"` to go both ways and disregard
#' edge direction altogether.
#'
#' @param order How far to branch out to create
#' a neighborhood around `from`. Defaults to
#' as far as possible. If a target is in the neighborhood, then
#' so are all of its custom [file_out()] files if
#' `show_output_files` is `TRUE`.
#' That means the actual graph order may be slightly greater than
#' you might expect, but this ensures consistency
#' between `show_output_files = TRUE` and
#' `show_output_files = FALSE`.
#'
#' @param subset Optional character vector.
#' Subset of targets/imports to display in the graph.
#' Applied after `from`, `mode`, and `order`.
#' Be advised: edges are only kept for adjacent nodes in `subset`.
#' If you do not select all the intermediate nodes,
#' edges will drop from the graph.
#'
#' @param targets_only Logical,
#' whether to skip the imports and only include the
#' targets in the workflow plan.
#'
#' @param font_size Numeric, font size of the node labels in the graph
#'
#' @param build_times Character string or logical.
#' If character, the choices are
#' 1. `"build"`: runtime of the command plus the time
#' it take to store the target or import.
#' 2. `"command"`: just the runtime of the command.
#' 3. `"none"`: no build times.
#' If logical, `build_times` selects whether to show the
#' times from `build_times(..., type = "build")`` or use
#' no build times at all. See [build_times()] for details.
#'
#' @param digits Number of digits for rounding the build times
#'
#' @param from_scratch Logical, whether to assume all the targets
#' will be made from scratch on the next [make()].
#' Makes all targets outdated, but keeps information about
#' build progress in previous [make()]s.
#'
#' @param make_imports Logical, whether to make the imports first.
#' Set to `FALSE` to increase speed and risk using obsolete information.
#'
#' @param full_legend Logical. If `TRUE`, all the node types
#' are printed in the legend. If `FALSE`, only the
#' node types used are printed in the legend.
#'
#' @param group Optional character scalar, name of the column used to
#' group nodes into columns. All the columns names of your original `drake`
#' plan are choices. The other choices (such as `"status"`) are column names
#' in the `nodes` . To group nodes into clusters in the graph,
#' you must also supply the `clusters` argument.
#'
#' @param clusters Optional character vector of values to cluster on.
#' These values must be elements of the column of the `nodes` data frame
#' that you specify in the `group` argument to `drake_graph_info()`.
#'
#' @param show_output_files Logical, whether to include
#' [file_out()] files in the graph.
#'
#' @param hover Logical, whether to show text (file contents,
#' commands, etc.) when you hover your cursor over a node.
#' @param on_select_col Optional string corresponding to the column name
#' in the plan that should provide data for the `on_select` event.
#' @examples
#' \dontrun{
#' isolate_example("Quarantine side effects.", {
#' if (requireNamespace("visNetwork", quietly = TRUE)) {
#' if (suppressWarnings(require("knitr"))) {
#' load_mtcars_example() # Get the code with drake_example("mtcars").
#' vis_drake_graph(my_plan)
#' # Get a list of data frames representing the nodes, edges,
#' # and legend nodes of the visNetwork graph from vis_drake_graph().
#' raw_graph <- drake_graph_info(my_plan)
#' # Choose a subset of the graph.
#' smaller_raw_graph <- drake_graph_info(
#' my_plan,
#' from = c("small", "reg2"),
#' mode = "in"
#' )
#' # Inspect the raw graph.
#' str(raw_graph)
#' # Use the data frames to plot your own custom visNetwork graph.
#' # For example, you can omit the legend nodes
#' # and change the direction of the graph.
#' library(visNetwork)
#' graph <- visNetwork(nodes = raw_graph$nodes, edges = raw_graph$edges)
#' visHierarchicalLayout(graph, direction = 'UD')
#' }
#' }
#' })
#' }
drake_graph_info <- function(
...,
from = NULL,
mode = c("out", "in", "all"),
order = NULL,
subset = NULL,
build_times = "build",
digits = 3,
targets_only = FALSE,
font_size = 20,
from_scratch = FALSE,
make_imports = TRUE,
full_legend = FALSE,
group = NULL,
clusters = NULL,
show_output_files = TRUE,
hover = FALSE,
on_select_col = NULL,
config = NULL
) {
}
#' @title Internal function
#' @export
#' @keywords internal
#' @description Not a user-side function.
#' @param config A [drake_config()] object.
drake_graph_info_impl <- function(
config,
from = NULL,
mode = c("out", "in", "all"),
order = NULL,
subset = NULL,
build_times = "build",
digits = 3,
targets_only = FALSE,
font_size = 20,
from_scratch = FALSE,
make_imports = TRUE,
full_legend = FALSE,
group = NULL,
clusters = NULL,
show_output_files = TRUE,
hover = FALSE,
on_select_col = NULL
) {
assert_pkg("visNetwork")
assert_config(config)
if (!length(V(config$graph)$name)) {
return(null_graph())
}
config$build_times <- resolve_build_times(build_times)
config$digits <- digits
config$font_size <- font_size
config$from_scratch <- from_scratch
config$make_imports <- make_imports
config$group <- as.character(group)
config$clusters <- as.character(clusters)
config$hover <- hover
config$on_select_col <- on_select_col
config$file_out <- lapply(all_targets(config), function(target) {
config$spec[[target]]$deps_build$file_out
})
names(config$file_out) <- all_targets(config)
if (!show_output_files) {
vertices <- igraph::V(config$graph)$name
imported <- igraph::V(config$graph)$imported
vertices <- vertices[!(!imported & is_encoded_path(vertices))]
config$graph <- subset_graph(config$graph, vertices)
}
if (!is.null(from)) {
config$graph <- nbhd_graph(
graph = config$graph,
vertices = from,
mode = match.arg(mode),
order = order %||% igraph::gorder(config$graph)
)
}
if (!is.null(subset)) {
config$graph <- subset_graph(graph = config$graph, subset = subset)
}
config$import_names <- all_imports(config)
if (targets_only) {
config$graph <- igraph::delete_vertices(
graph = config$graph,
v = igraph::V(config$graph)$name[igraph::V(config$graph)$imported]
)
}
config <- get_raw_node_category_data(config)
network_data <- visNetwork::toVisNetworkData(config$graph)
network_data$nodes
config$nodes <- network_data$nodes[igraph::topo_sort(config$graph)$name, ]
if (!is.null(group)) {
config$nodes[[group]] <- get_cluster_grouping(config, group)
}
config <- trim_node_categories(config)
config$nodes <- configure_nodes(config = config)
if (show_output_files) {
config$nodes <- append_output_file_nodes(config)
}
config$nodes <- coord_set(config$nodes)
config$edges <- network_data$edges
if (nrow(config$edges)) {
config$edges$arrows <- "to"
}
if (!is.null(config$on_select_col)) {
config$nodes$on_select_col <- get_select_col(config)
}
if (length(config$group)) {
config <- cluster_nodes(config)
}
out <- list(
nodes = weak_as_tibble(config$nodes),
edges = weak_as_tibble(config$edges),
legend_nodes = filtered_legend_nodes(
all_nodes = config$nodes,
full_legend = full_legend,
font_size = font_size
),
default_title = default_graph_title()
)
class(out) <- "drake_graph_info"
out
}
#' @export
print.drake_graph_info <- function(x, ...) {
cat(
"drake graph visual info:",
nrow(x$nodes),
"nodes and",
nrow(x$edges),
"edges:\n"
)
min_str(x)
}
body(drake_graph_info) <- config_util_body(drake_graph_info_impl)
get_raw_node_category_data <- function(config) {
all_labels <- V(config$graph)$name
config$targets <- all_targets(config)
is_dynamic <- vapply(
config$targets,
is_dynamic,
FUN.VALUE = logical(1),
config = config
)
config$dynamic <- config$targets[is_dynamic]
config$outdated <- resolve_graph_outdated(config = config)
prog <- config$cache$get_progress(config$targets)
config$running <- config$targets[prog == "running"]
config$cancelled <- config$targets[prog == "cancelled"]
config$failed <- config$targets[prog == "failed"]
config$files <- all_labels[is_encoded_path(all_labels)]
config$functions <- parallel_filter(
x = config$import_names,
f = function(x) {
is.function(get_import_from_memory(x, config = config))
},
jobs = config$settings$jobs_preprocess
)
config$missing <- parallel_filter(
x = config$import_names,
f = function(x) {
missing_import(x, config = config)
},
jobs = config$settings$jobs_preprocess
)
config
}
trim_node_categories <- function(config) {
elts <- c(
"cancelled", "failed", "files", "functions", "running", "missing",
"outdated", "targets"
)
for (elt in elts) {
config[[elt]] <- intersect(config[[elt]], config$nodes$id)
}
config
}
resolve_graph_outdated <- function(config) {
if (config$from_scratch) {
config$outdated <- all_targets(config)
} else {
config$outdated <- outdated_impl(
config = config,
make_imports = config$make_imports
)
}
}
append_output_file_nodes <- function(config) {
with(config, {
cols <- setdiff(colnames(nodes), c("id", "label", "level", "shape", "type"))
for (target in intersect(names(file_out), nodes$id)) {
files <- intersect(file_out[[target]], nodes$id)
if (length(files)) {
for (col in cols) {
nodes[files, col] <- nodes[target, col]
}
}
}
nodes
})
}
resolve_build_times <- function(build_times) {
if (is.logical(build_times)) {
warning(
"The build_times argument to the visualization functions ",
"should be a character string: \"build\", \"command\", or \"none\". ",
"The change will be forced in a later version of `drake`. ",
"see the `build_times()` function for details."
)
if (build_times) {
build_times <- "build"
} else {
build_times <- "none"
}
}
build_times
}
get_select_col <- function(config) {
get_cluster_grouping(config, config$on_select_col)
}
get_cluster_grouping <- function(config, group) {
vapply(
X = config$nodes$id,
FUN = function(x) {
out <- config$spec[[x]][[group]]
if (!is.character(out)) {
out <- safe_deparse(out, backtick = TRUE)
}
out %||% NA_character_
},
FUN.VALUE = character(1)
)
}
#' @title Return the default title for graph visualizations
#' `r lifecycle::badge("soft-deprecated")`
#' @description For internal use only.
#' @export
#' @keywords internal
#' @return A character scalar with the default graph title.
#' @examples
#' default_graph_title()
default_graph_title <- function() {
"Dependency graph"
}
null_graph <- function() {
assert_pkg("visNetwork")
nodes <- data.frame(id = 1, label = "Nothing to plot.")
visNetwork::visNetwork(
nodes = nodes,
edges = data.frame(from = NA_character_, to = NA_character_),
main = "Nothing to plot."
)
}
filtered_legend_nodes <- function(all_nodes, full_legend, font_size) {
legend_nodes <- legend_nodes(font_size = font_size)
if (full_legend) {
legend_nodes
} else {
filter_legend_nodes(legend_nodes = legend_nodes, all_nodes = all_nodes)
}
}
filter_legend_nodes <- function(legend_nodes, all_nodes) {
colors <- c(unique(all_nodes$color), node_color("object"))
shapes <- unique(all_nodes$shape)
ln <- legend_nodes
ln[ln$color %in% colors & ln$shape %in% shapes, , drop = FALSE] # nolint
}
#' @title Create the nodes data frame used in the legend
#' of the graph visualizations.
#' `r lifecycle::badge("soft-deprecated")`
#' @export
#' @description Output a `visNetwork`-friendly
#' data frame of nodes. It tells you what
#' the colors and shapes mean
#' in the graph visualizations.
#' @param font_size Font size of the node label text.
#' @return A data frame of legend nodes for the graph visualizations.
#' @examples
#' \dontrun{
#' # Show the legend nodes used in graph visualizations.
#' # For example, you may want to inspect the color palette more closely.
#' if (requireNamespace("visNetwork", quietly = TRUE)) {
#' # visNetwork::visNetwork(nodes = legend_nodes()) # nolint
#' }
#' }
legend_nodes <- function(font_size = 20) {
out <- weak_tibble(
label = c(
"Up to date",
"Outdated",
"Running",
"Cancelled",
"Failed",
"Imported",
"Missing",
"Object",
"Dynamic",
"Function",
"File",
"Cluster"
),
color = node_color(c(
"up_to_date",
"outdated",
"running",
"cancelled",
"failed",
"import",
"missing",
rep("generic", 5)
)),
shape = node_shape(c(
rep("object", 8),
"dynamic",
"funct",
"file",
"cluster"
)),
font.color = "black",
font.size = font_size
)
out$id <- seq_len(nrow(out))
out
}
cluster_nodes <- function(config) {
for (cluster in config$clusters) {
index <- config$nodes[[config$group]] == cluster
index[is.na(index)] <- FALSE
if (!any(index)) {
next
}
new_node <- config$nodes[index, ]
status <- cluster_status(new_node$status)
new_node <- new_node[which.max(new_node$level), ]
new_node$status <- status
new_node$type <- "cluster"
new_node <- style_nodes(
config = list(nodes = new_node, font_size = config$font_size))
new_node$label <- new_node$id <-
paste0(config$group, ": ", cluster)
if (!is.null(config$on_select_col)) {
new_node$on_select_col <- config$nodes[index, "on_select_col"][[1]]
}
matching <- config$nodes$id[index]
new_node$title <- paste(matching, collapse = ", ")
new_node$title <- crop_text(new_node$title, width = hover_width)
config$nodes <- rbind(config$nodes[!index, ], new_node)
config$edges$from[config$edges$from %in% matching] <- new_node$id
config$edges$to[config$edges$to %in% matching] <- new_node$id
}
config$nodes$level <- as.integer(ordered(config$nodes$level))
config$edges <- config$edges[!duplicated(config$edges), ]
config$edges <- config$edges[config$edges$from != config$edges$to, ]
config
}
cluster_status <- function(statuses) {
precedence <- c(
"other",
"imported",
"up to date",
"missing",
"outdated",
"running",
"failed"
)
out <- "other"
for (status in precedence) {
if (status %in% statuses) {
out <- status
}
}
out
}
configure_nodes <- function(config) {
rownames(config$nodes) <- config$nodes$id
config$nodes$label <- config$cache$display_keys(config$nodes$label)
config$nodes <- categorize_nodes(config = config)
config$nodes <- style_nodes(config = config)
config$nodes <- resolve_levels(config = config)
config$nodes <- wrap_labels(config = config)
if (config$build_times != "none") {
config$nodes <- append_build_times(config = config)
}
hover_text(config = config)
}
categorize_nodes <- function(config) {
with(config, {
nodes$status <- "imported"
nodes[targets, "status"] <- "up to date"
nodes[missing, "status"] <- "missing"
nodes[outdated, "status"] <- "outdated"
nodes[running, "status"] <- "running"
nodes[cancelled, "status"] <- "cancelled"
nodes[failed, "status"] <- "failed"
nodes$type <- "object"
nodes[dynamic, "type"] <- "dynamic"
nodes[is_encoded_path(nodes$id), "type"] <- "file"
nodes[functions, "type"] <- "function"
nodes
})
}
resolve_levels <- function(config) {
config$nodes$level <- level <- 0
graph <- config$graph
check_drake_graph(graph)
while (length(V(graph))) {
level <- level + 1
leaves <- leaf_nodes(graph)
leaves <- intersect(leaves, config$nodes$id)
config$nodes[leaves, "level"] <- level
graph <- igraph::delete_vertices(graph = graph, v = leaves)
}
config$nodes
}
wrap_labels <- function(config) {
config$nodes$label <- hard_wrap(config$nodes$label, width = hover_width)
config$nodes
}
style_nodes <- function(config) {
with(config, {
nodes$font.size <- font_size # nolint
nodes[nodes$status == "imported", "color"] <- node_color("import")
nodes[nodes$status == "running", "color"] <- node_color("running")
nodes[nodes$status == "cancelled", "color"] <- node_color("cancelled")
nodes[nodes$status == "failed", "color"] <- node_color("failed")
nodes[nodes$status == "missing", "color"] <- node_color("missing")
nodes[nodes$status == "outdated", "color"] <- node_color("outdated")
nodes[nodes$status == "up to date", "color"] <- node_color("up_to_date")
nodes[nodes$type == "object", "shape"] <- node_shape("object")
nodes[nodes$type == "dynamic", "shape"] <- node_shape("dynamic")
nodes[nodes$type == "file", "shape"] <- node_shape("file")
nodes[nodes$type == "function", "shape"] <- node_shape("funct")
nodes[nodes$type == "cluster", "shape"] <- node_shape("cluster")
nodes
})
}
node_color <- Vectorize(function(x) {
color <- switch(
x,
default = "dodgerblue3",
fail = "red",
up_to_date = "forestgreen",
outdated = "#000000",
cancelled = "#ecb753",
failed = "#aa0000",
import = "dodgerblue3",
missing = "darkorchid3",
running = "#ff7221",
"#888888"
)
col2hex(color)
},
"x", USE.NAMES = FALSE)
col2hex <- function(cname) {
assert_pkg("grDevices")
col_mat <- grDevices::col2rgb(cname)
grDevices::rgb(
red = col_mat[1, ] / 255,
green = col_mat[2, ] / 255,
blue = col_mat[3, ] / 255
)
}
node_shape <- Vectorize(function(x) {
switch(
x,
object = "dot",
dynamic = "star",
file = "square",
funct = "triangle",
cluster = "diamond",
"dot"
)
},
"x", USE.NAMES = FALSE)
append_build_times <- function(config) {
time_data <- build_times(
list = all_targets(config),
digits = config$digits,
cache = config$cache,
type = config$build_times
)
nodes <- config$nodes
timed <- intersect(time_data$target, nodes$id)
if (!length(timed)) {
return(nodes)
}
time_data <- aggregate_dynamic_times(time_data, config)
time_labels <- as.character(time_data$elapsed)
if (any(time_data$dynamic)) {
time_labels[time_data$dynamic] <- paste0(
time_data$subtargets[time_data$dynamic],
" sub-targets\n",
time_labels[time_data$dynamic],
" elapsed\n(time depends on jobs)"
)
}
names(time_labels) <- time_data$target
time_labels <- time_labels[timed]
nodes[timed, "label"] <- paste(
nodes[timed, "label"],
time_labels,
sep = "\n"
)
nodes
}
aggregate_dynamic_times <- function(time_data, config) {
time_data$dynamic <- vlapply(time_data$target, is_dynamic, config = config)
time_data$subtargets <- 0L
dynamic <- which(time_data$dynamic)
for (i in dynamic) {
target <- time_data$target[i]
meta <- config$cache$get(target, namespace = "meta")
time_data$subtargets[i] <- length(meta$subtargets)
}
time_data
}
hover_text <- function(config) {
with(config, {
if (!hover) {
nodes$title <-
"Call drake_graph_info(hover = TRUE) for informative text."
return(nodes)
}
nodes$title <- nodes$id
import_files <- setdiff(files, targets)
nodes[import_files, "title"] <-
file_hover_text(encoded_file = import_files, targets, config)
nodes[functions, "title"] <-
function_hover_text(function_name = functions, envir = config$envir)
nodes[targets, "title"] <-
target_hover_text(targets = targets, config = config)
nodes
})
}
file_hover_text <- Vectorize(function(encoded_file, targets, config) {
decoded_file <- config$cache$decode_path(encoded_file)
if (encoded_file %in% targets || !file.exists(decoded_file)) {
return(encoded_file)
}
tryCatch({
x <- readLines(decoded_file, n = 20, warn = FALSE)
x <- crop_lines(x, n = hover_lines)
x <- crop_text(x, width = hover_width)
paste0(x, collapse = "<br>")
},
error = function(e) encoded_file,
warning = function(w) encoded_file
)
},
"encoded_file")
function_hover_text <- Vectorize(function(function_name, envir) {
x <- tryCatch(
get(x = function_name, envir = envir),
error = function(e) function_name
)
x <- unwrap_function(x)
style_hover_text(x)
},
"function_name")
target_hover_text <- function(targets, config) {
commands <- vapply(
X = targets,
FUN = function(target) {
config$spec[[target]]$command_standardized
},
FUN.VALUE = character(1),
USE.NAMES = FALSE
)
vapply(
X = commands,
FUN = style_hover_text,
FUN.VALUE = character(1),
USE.NAMES = FALSE
)
}
# I would use styler for indentation here,
# but it adds a lot of processing time
# for large functions.
style_hover_text <- function(x) {
if (!is.character(x)) {
x <- safe_deparse(x, backtick = TRUE)
}
x <- crop_lines(x, n = hover_lines)
x <- crop_text(x, width = hover_width)
x <- gsub(pattern = " ", replacement = " ", x = x)
x <- gsub(pattern = "\n", replacement = "<br>", x = x)
paste0(x, collapse = "<br>")
}
crop_text <- Vectorize(function(x, width = getOption("width")) {
if (nchar(x) > width) {
x <- paste0(substr(x, 1, width - 3), "...")
}
x
},
"x", USE.NAMES = FALSE)
hover_lines <- 10
hover_width <- 49
crop_lines <- function(x, n = 10) {
if (length(x) > n) {
x <- x[1:(n - 1)]
x[n] <- "..."
}
x
}
coord_set <- function(nodes) {
nodes <- coord_x(nodes)
nodes <- coord_y(nodes)
nodes
}
coord_x <- function(nodes, min = -1, max = 1) {
nodes$x <- coord_rescale(nodes$level, min = min, max = max)
nodes
}
coord_y <- function(nodes, min = -1, max = 1) {
splits <- base::split(nodes, nodes$x)
out <- lapply(splits, coord_y_stage, min = min, max = max)
out <- do.call(rbind, out)
out$y <- coord_rescale(out$y, min = min, max = max)
out
}
coord_y_stage <- function(nodes, min, max) {
y <- seq(from = min, to = max, length.out = nrow(nodes) + 2)
nodes$y <- y[c(-1, -length(y))]
nodes
}
coord_rescale <- function(x, min, max) {
x <- x - min(x)
x <- x / max(x)
x <- x * (max - min)
x <- x + min
x [!is.finite(x)] <- (min + max) / 2
x
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.