plot.GRiwrm.R

#' Plot of a diagram representing the network structure of a GRiwrm object
#'
#' @details
#' `header` parameter allows to add any mermaid code injected before the `graph`
#' instruction. It is notably useful for injecting directives that impact the
#' format of the graph. See [mermaid documentation on directives](https://mermaid.js.org/config/directives.html) for
#' more details and also the
#' [complete list of available directives](https://github.com/mermaid-js/mermaid/blob/master/packages/mermaid/src/schemas/config.schema.yaml#L1878).
#'
#' @param x \[GRiwrm object\] data to display. See [CreateGRiwrm] for details
#' @param display [logical] if `TRUE` plots the diagram, returns the mermaid code otherwise
#' @param orientation [character] orientation of the graph. Possible values are
#'        "LR" (left-right), "RL" (right-left), "TB" (top-bottom), or "BT" (bottom-top).
#' @param with_donors [logical] for drawing boxes around ungauged nodes and their donors
#' @param box_colors [list] containing the color used for the different types of nodes
#' @param defaultClassDef [character] default style apply to all boxes
#' @param header mermaid script to add before the generated script (see Details)
#' @param footer mermaid script to add after the generated script
#' @param ... further parameters passed to [mermaid]
#'
#' @return Mermaid code of the diagram if display is `FALSE`, otherwise the function returns the diagram itself.
#'
#' @export plot.GRiwrm
#' @export
#' @seealso [CreateGRiwrm()]
#'
#' @example man-examples/CreateGRiwrm.R
#'
plot.GRiwrm <- function(x,
                        display = TRUE,
                        orientation = "LR",
                        with_donors = TRUE,
                        box_colors = c(UpstreamUngauged = "#eef",
                                       UpstreamGauged = "#aaf",
                                       IntermediateUngauged = "#efe",
                                       IntermediateGauged = "#afa",
                                       Reservoir = "#9de",
                                       DirectInjection = "#faa"),
                        defaultClassDef = "stroke:#333",
                        header = "%%{init: {'theme': 'neutral'} }%%",
                        footer = NULL,
                        ...) {

  stopifnot(inherits(x, "GRiwrm"),
            is.logical(display),
            length(display) == 1,
            is.character(orientation),
            length(orientation) == 1,
            is.character(box_colors),
            length(setdiff(names(box_colors), c("UpstreamUngauged", "UpstreamGauged",
                                                "IntermediateUngauged",   "IntermediateGauged",
                                                "DirectInjection", "Reservoir"))) == 0)
  x <- sortGRiwrm4plot(x)
  nodes <- unlist(sapply(unique(x$donor), plotGriwrmCluster, x = x, with_donors = with_donors))
  g2 <- x[!is.na(x$down),]
  if (nrow(g2) > 0) {
    links <- paste(
      sprintf("id_%1$s", g2$id),
      "-->|",
      round(g2$length, digits = 0),
      "km|",
      sprintf("id_%1$s", g2$down)
    )
  } else {
    links <- ""
  }
  x$nodeclass <- sapply(x$id, getNodeClass, griwrm = x)
  node_class <- lapply(unique(x$nodeclass), function(nc) {
    x$id[x$nodeclass == nc]
  })