rrenderdiagrammer

DiagrammeR: render_graph() produces inaccurate node font color


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()

Graph rendered with generate_dot() |> grViz()


Solution

  • 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()