r-lib / cli
1

2
#' Draw a tree
3
#'
4
#' Draw a tree using box drawing characters. Unicode characters are
5
#' used if available. (Set the `cli.unicode` option if auto-detection
6
#' fails.)
7
#'
8
#' A node might appear multiple times in the tree, or might not appear
9
#' at all.
10
#'
11
#' @param data Data frame that contains the tree structure.
12
#'   The first column is an id, and the second column is a list column,
13
#'   that contains the ids of the child nodes. The optional third column
14
#'   may contain the text to print to annotate the node.
15
#' @param root The name of the root node.
16
#' @param style Optional box style list.
17
#' @param width Maximum width of the output. Defaults to the `width`
18
#'   option, see [base::options()].
19
#' @param trim Whether to avoid traversing the same nodes multiple times.
20
#'   If `TRUE` and `data` has a `trimmed` column, then that is used for
21
#'   printing repeated noded.
22
#' @return Character vector, the lines of the tree drawing.
23
#'
24
#' @export
25
#' @examples
26
#' data <- data.frame(
27
#'   stringsAsFactors = FALSE,
28
#'   package = c("processx", "backports", "assertthat", "Matrix",
29
#'     "magrittr", "rprojroot", "clisymbols", "prettyunits", "withr",
30
#'     "desc", "igraph", "R6", "crayon", "debugme", "digest", "irlba",
31
#'     "rcmdcheck", "callr", "pkgconfig", "lattice"),
32
#'   dependencies = I(list(
33
#'     c("assertthat", "crayon", "debugme", "R6"), character(0),
34
#'     character(0), "lattice", character(0), "backports", character(0),
35
#'     c("magrittr", "assertthat"), character(0),
36
#'     c("assertthat", "R6", "crayon", "rprojroot"),
37
#'     c("irlba", "magrittr", "Matrix", "pkgconfig"), character(0),
38
#'     character(0), "crayon", character(0), "Matrix",
39
#'     c("callr", "clisymbols", "crayon", "desc", "digest", "prettyunits",
40
#'       "R6", "rprojroot", "withr"),
41
#'     c("processx", "R6"), character(0), character(0)
42
#'   ))
43
#' )
44
#' tree(data)
45
#' tree(data, root = "rcmdcheck")
46
#'
47
#' # Colored nodes
48
#' data$label <- paste(data$package,
49
#'   style_dim(paste0("(", c("2.0.0.1", "1.1.1", "0.2.0", "1.2-11",
50
#'     "1.5", "1.2", "1.2.0", "1.0.2", "2.0.0", "1.1.1.9000", "1.1.2",
51
#'     "2.2.2", "1.3.4", "1.0.2", "0.6.12", "2.2.1", "1.2.1.9002",
52
#'     "1.0.0.9000", "2.0.1", "0.20-35"), ")"))
53
#'   )
54
#' roots <- ! data$package %in% unlist(data$dependencies)
55
#' data$label[roots] <- col_cyan(style_italic(data$label[roots]))
56
#' tree(data)
57
#' tree(data, root = "rcmdcheck")
58
#'
59
#' # Trimming
60
#' pkgdeps <- list(
61
#'   "dplyr@0.8.3" = c("assertthat@0.2.1", "glue@1.3.1", "magrittr@1.5",
62
#'     "R6@2.4.0", "Rcpp@1.0.2", "rlang@0.4.0", "tibble@2.1.3",
63
#'     "tidyselect@0.2.5"),
64
#'   "assertthat@0.2.1" = character(),
65
#'   "glue@1.3.1" = character(),
66
#'   "magrittr@1.5" = character(),
67
#'   "pkgconfig@2.0.3" = character(),
68
#'   "R6@2.4.0" = character(),
69
#'   "Rcpp@1.0.2" = character(),
70
#'   "rlang@0.4.0" = character(),
71
#'   "tibble@2.1.3" = c("cli@1.1.0", "crayon@1.3.4", "fansi@0.4.0",
72
#'      "pillar@1.4.2", "pkgconfig@2.0.3", "rlang@0.4.0"),
73
#'   "cli@1.1.0" = c("assertthat@0.2.1", "crayon@1.3.4"),
74
#'   "crayon@1.3.4" = character(),
75
#'   "fansi@0.4.0" = character(),
76
#'   "pillar@1.4.2" = c("cli@1.1.0", "crayon@1.3.4", "fansi@0.4.0",
77
#'      "rlang@0.4.0", "utf8@1.1.4", "vctrs@0.2.0"),
78
#'   "utf8@1.1.4" = character(),
79
#'   "vctrs@0.2.0" = c("backports@1.1.5", "ellipsis@0.3.0",
80
#'      "digest@0.6.21", "glue@1.3.1", "rlang@0.4.0", "zeallot@0.1.0"),
81
#'   "backports@1.1.5" = character(),
82
#'   "ellipsis@0.3.0" = c("rlang@0.4.0"),
83
#'   "digest@0.6.21" = character(),
84
#'   "glue@1.3.1" = character(),
85
#'   "zeallot@0.1.0" = character(),
86
#'   "tidyselect@0.2.5" = c("glue@1.3.1", "purrr@1.3.1", "rlang@0.4.0",
87
#'      "Rcpp@1.0.2"),
88
#'   "purrr@0.3.3" = c("magrittr@1.5", "rlang@0.4.0")
89
#' )
90
#'
91
#' pkgs <- data.frame(
92
#'   stringsAsFactors = FALSE,
93
#'   name = names(pkgdeps),
94
#'   deps = I(unname(pkgdeps))
95
#' )
96
#'
97
#' tree(pkgs)
98
#' tree(pkgs, trim = TRUE)
99
#'
100
#' # Mark the trimmed nodes
101
#' pkgs$label <- pkgs$name
102
#' pkgs$trimmed <- paste(pkgs$name, " (trimmed)")
103
#' tree(pkgs, trim = TRUE)
104

105
tree <- function(data, root = data[[1]][[1]], style = NULL,
106
                 width = console_width(), trim = FALSE) {
107 1
  assert_that(
108 1
    is.data.frame(data), ncol(data) >= 2,
109 1
    is_string(root),
110 1
    is.null(style) || (is_tree_style(style)),
111 1
    is_count(width)
112
  )
113

114 1
  style <- style %||% box_chars()
115

116 1
  labels <- if (ncol(data) >= 3) data[[3]] else data[[1]]
117 1
  trimlabs <- data$trimmed %||% labels
118

119 1
  seen <- character()
120 1
  res <- character()
121

122 1
  pt <- function(root, n = integer(), mx = integer(), used = character()) {
123

124 1
    num_root <- match(root, data[[1]])
125 1
    if (is.na(num_root)) return()
126

127 1
    level <- length(n) - 1
128 1
    prefix <- vcapply(seq_along(n), function(i) {
129 1
      if (n[i] < mx[i]) {
130 1
        if (i == length(n)) {
131 1
          paste0(style$j, style$h)
132
        } else {
133 1
          paste0(style$v, " ")
134
        }
135 1
      } else if (n[i] == mx[i] && i == length(n)) {
136 1
        paste0(style$l, style$h)
137
      } else {
138
        "  "
139
      }
140
    })
141

142 1
    root_seen <- root %in% seen
143 1
    root_lab <- if (trim && root_seen) trimlabs[[num_root]] else labels[[num_root]]
144 1
    res <<- c(res, paste0(paste(prefix, collapse = ""), root_lab))
145

146
    # Detect infinite loops
147 1
    if (!trim && root %in% used) {
148 1
      warning(call. = FALSE,
149 1
              "Endless loop found in tree: ",
150 1
              paste0(c(used, root), collapse = " -> "))
151 1
    } else if (! trim || ! root_seen) {
152 1
      seen <<- c(seen, root)
153 1
      children <- data[[2]][[num_root]]
154 1
      for (d in seq_along(children)) {
155 1
        pt(children[[d]], c(n, d), c(mx, length(children)), c(used, root))
156
      }
157
    }
158
  }
159

160 1
  if (nrow(data)) pt(root)
161

162 1
  res <- col_substr(res, 1, width)
163

164 1
  class(res) <- unique(c("tree", class(res), "character"))
165 1
  res
166
}
167

168
box_chars <- function() {
169 1
  if (is_utf8_output()) {
170 1
    list(
171 1
      "h" = "\u2500",                   # horizontal
172 1
      "v" = "\u2502",                   # vertical
173 1
      "l" = "\u2514",                   # leaf
174 1
      "j" = "\u251C"                    # junction
175
    )
176
  } else {
177 1
    list(
178 1
      "h" = "-",                        # horizontal
179 1
      "v" = "|",                        # vertical
180 1
      "l" = "\\",                       # leaf
181 1
      "j" = "+"                         # junction
182
    )
183
  }
184
}
185

186
#' @importFrom methods setOldClass
187

188
setOldClass(c("tree", "character"))
189

190
#' @export
191

192
print.tree <- function(x, ..., sep = "\n") {
193 1
  cat(x, ..., sep = sep)
194 1
  invisible(x)
195
}

Read our documentation on viewing source code .

Loading