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

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

CodePudding user response：

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