I've been exploring the possibilities of the DiagrammeR package in R to make flow charts and graphs in general. It seems quite nice, but I ran into a curious situation: the render_graph()
function produces wrong font color on the nodes and I can't understand why.
In the reproducible example below:
The node font color is by default set to "gray50" (line 12 in the global graph attributes below), but the font color is black when rendering with the render_graph()
function (see 1st image below).
It is, however, displayed properly when rendered with the generate_dot() |> grViz()
sequence of functions (see 2nd image).
I haven't spotted any other inaccuracies yet, but I can't rule them out.
I wonder, is this a bug or a feature? Does this mean I should not trust render_graph()
? And does anyone know why there is this discrepancy?
Thank you!
# Create a minimal graph with just 2 nodes and no edges
nodes <- DiagrammeR::create_node_df(2,label=c("a","b"))
graph <- DiagrammeR::create_graph(nodes_df=nodes,edges_df=NULL)
# Show its global attributes
graph |> DiagrammeR::get_global_graph_attr_info()
attr | value | attr_type | |
---|---|---|---|
1 | layout | neato | graph |
2 | outputorder | edgesfirst | graph |
3 | bgcolor | white | graph |
4 | fontname | Helvetica | node |
5 | fontsize | 10 | node |
6 | shape | circle | node |
7 | fixedsize | true | node |
8 | width | 0.5 | node |
9 | style | filled | node |
10 | fillcolor | aliceblue | node |
11 | color | gray70 | node |
12 | fontcolor | gray50 | node |
13 | fontname | Helvetica | edge |
14 | fontsize | 8 | edge |
15 | len | 1.5 | edge |
16 | color | gray80 | edge |
17 | arrowsize | 0.5 | edge |
# Render it with one method
graph |> DiagrammeR::render_graph()
Graph rendered with render_graph()
# Render it with another method
graph |> DiagrammeR::generate_dot() |> DiagrammeR::grViz()
render_graph
attempts to set a contrasting text color if not explicitly stated. The relevant part of the function is
# pseudocode
...
if (!("fontcolor" %in% colnames(graph$nodes_df)) &
"fillcolor" %in% colnames(graph$nodes_df)) {
graph$nodes_df$fontcolor <- tibble::tibble(value = graph$nodes_df$fillcolor) %>%
dplyr::mutate(value_x = DiagrammeR:::contrasting_text_color(background_color = value)) %>%
dplyr::pull(value_x)
}
...
To generate the same graph as the alternative method in the post, you can remove this section, overwriting the function. Insert internal DiagrammeR
functions where needed using :::
.
render_graph <- function (graph, layout = NULL, output = NULL, as_svg = FALSE,
title = NULL, width = NULL, height = NULL)
{
fcn_name <- DiagrammeR:::get_calling_fcn()
if (DiagrammeR:::graph_object_valid(graph) == FALSE) {
emit_error(fcn_name = fcn_name, reasons = "The graph object is not valid")
}
if (is.null(output)) {
output <- "graph"
}
if (output == "graph") {
if (!is.null(title)) {
graph <- DiagrammeR:::add_global_graph_attrs(graph, "label",
title, "graph")
graph <- DiagrammeR:::add_global_graph_attrs(graph, "labelloc",
"t", "graph")
graph <- DiagrammeR:::add_global_graph_attrs(graph, "labeljust",
"c", "graph")
graph <- DiagrammeR:::add_global_graph_attrs(graph, "fontname",
"Helvetica", "graph")
graph <- DiagrammeR:::add_global_graph_attrs(graph, "fontcolor",
"gray30", "graph")
}
if (nrow(graph$nodes_df) > 0) {
if (!("fillcolor" %in% colnames(graph$nodes_df))) {
if ("fillcolor" %in% graph$global_attrs$attr) {
graph$nodes_df$fillcolor <- graph$global_attrs %>%
dplyr::filter(attr == "fillcolor" &
attr_type == "node") %>% dplyr::select(value) %>%
purrr::flatten_chr()
}
else {
graph$nodes_df$fillcolor <- "white"
}
}
}
if (nrow(graph$nodes_df) > 0) {
if ("fillcolor" %in% colnames(graph$nodes_df)) {
if ("fillcolor" %in% graph$global_attrs$attr) {
graph$nodes_df$fillcolor[which(is.na(graph$nodes_df$fillcolor))] <- graph$global_attrs[which(graph$global_attrs$attr ==
"fillcolor"), 2]
}
}
}
if ("fillcolor" %in% colnames(graph$nodes_df)) {
graph$nodes_df <- graph$nodes_df %>% dplyr::left_join(x11_hex() %>%
dplyr::as_tibble() %>% dplyr::mutate(hex = toupper(hex)),
by = c(fillcolor = "x11_name")) %>% dplyr::mutate(new_fillcolor = dplyr::coalesce(hex,
fillcolor)) %>% dplyr::select(-fillcolor, -hex) %>%
dplyr::rename(fillcolor = new_fillcolor)
}
if (!is.null(layout)) {
if (layout %in% c("circle", "tree", "kk",
"fr", "nicely")) {
graph <- graph %>% add_global_graph_attrs(attr = "layout",
value = "neato", attr_type = "graph")
if ("x" %in% colnames(graph$nodes_df)) {
graph$nodes_df <- graph$nodes_df %>% dplyr::select(-x)
}
if ("y" %in% colnames(graph$nodes_df)) {
graph$nodes_df <- graph$nodes_df %>% dplyr::select(-y)
}
if (layout == "circle") {
coords <- graph %>% to_igraph() %>% igraph::layout_in_circle() %>%
dplyr::as_tibble() %>% dplyr::rename(x = V1,
y = V2) %>% dplyr::mutate(x = x * (((count_nodes(graph) +
(0.25 * count_nodes(graph))))/count_nodes(graph))) %>%
dplyr::mutate(y = y * (((count_nodes(graph) +
(0.25 * count_nodes(graph))))/count_nodes(graph)))
}
if (layout == "tree") {
coords <- (graph %>% to_igraph() %>% igraph::layout_with_sugiyama())[[2]] %>%
dplyr::as_tibble() %>% dplyr::rename(x = V1,
y = V2)
}
if (layout == "kk") {
coords <- graph %>% to_igraph() %>% igraph::layout_with_kk() %>%
dplyr::as_tibble() %>% dplyr::rename(x = V1,
y = V2)
}
if (layout == "fr") {
coords <- graph %>% to_igraph() %>% igraph::layout_with_fr() %>%
dplyr::as_tibble() %>% dplyr::rename(x = V1,
y = V2)
}
if (layout == "nicely") {
coords <- graph %>% to_igraph() %>% igraph::layout_nicely() %>%
dplyr::as_tibble() %>% dplyr::rename(x = V1,
y = V2)
}
graph$nodes_df <- graph$nodes_df %>% dplyr::bind_cols(coords)
}
}
if (("image" %in% colnames(graph %>% get_node_df()) ||
"fa_icon" %in% colnames(graph %>% get_node_df()) ||
as_svg) & requireNamespace("DiagrammeRsvg",
quietly = TRUE)) {
if (!("DiagrammeRsvg" %in% rownames(utils::installed.packages()))) {
emit_error(fcn_name = fcn_name, reasons = c("Cannot currently render the graph to an SVG",
"please install the `DiagrammeRsvg` package and retry",
"pkg installed using `install.packages('DiagrammeRsvg')`",
"otherwise, set `as_svg = FALSE`"))
}
dot_code <- generate_dot(graph)
svg_vec <- strsplit(DiagrammeRsvg::export_svg(grViz(diagram = dot_code)),
"\n") %>% unlist()
svg_tbl <- get_svg_tbl(svg_vec)
svg_lines <- "<svg display=\"block\" margin=\"0 auto\" position=\"absolute\" width=\"100%\" height=\"100%\""
svg_line_no <- svg_tbl %>% dplyr::filter(type ==
"svg") %>% dplyr::pull(index)
svg_vec[svg_line_no] <- svg_lines
if ("image" %in% colnames(graph %>% get_node_df())) {
node_id_images <- graph %>% get_node_df() %>%
dplyr::select(id, image) %>% dplyr::filter(image !=
"") %>% dplyr::pull(id)
filter_lines <- graph %>% get_node_df() %>% dplyr::select(id,
image) %>% dplyr::filter(image != "") %>%
dplyr::mutate(filter_lines = as.character(glue::glue("<filter id=\"{id}\" x=\"0%\" y=\"0%\" width=\"100%\" height=\"100%\"><feImage xlink:href=\"{image}\"/></filter>"))) %>%
dplyr::pull(filter_lines) %>% paste(collapse = "\n")
filter_shape_refs <- as.character(glue::glue(" filter=\"url(#{node_id_images})\" "))
svg_shape_nos <- svg_tbl %>% dplyr::filter(node_id %in%
node_id_images) %>% dplyr::filter(type == "node_block") %>%
dplyr::pull(index)
svg_shape_nos <- svg_shape_nos + 3
svg_text_nos <- svg_shape_nos + 1
for (i in seq(node_id_images)) {
svg_vec[svg_shape_nos[i]] <- sub(" ",
paste0(filter_shape_refs[i]), svg_vec[svg_shape_nos[i]])
svg_vec[svg_text_nos[i]] <- ""
}
svg_vec[svg_line_no + 1] <- paste0(svg_vec[svg_line_no +
1], "\n\n", filter_lines, "\n")
}
}
else {
dot_code <- generate_dot(graph)
grVizObject <- grViz(diagram = dot_code, width = width,
height = height)
display <- grVizObject
}
display
}
else if (output == "visNetwork") {
visnetwork(graph)
}
}
Then, both functions give the same result.
graph |> render_graph()