remove dendrogram_data function, use fortify_data_frame instead

NAMESPACE

@@ -124,6 +124,8 @@ S3method(fortify_data_frame,Matrix)
 S3method(fortify_data_frame,character)
 S3method(fortify_data_frame,complex)
 S3method(fortify_data_frame,default)
+S3method(fortify_data_frame,dendrogram)
+S3method(fortify_data_frame,hclust)
 S3method(fortify_data_frame,logical)
 S3method(fortify_data_frame,matrix)
 S3method(fortify_data_frame,numeric)
@@ -409,7 +411,6 @@ export(continuous_limits)
 export(cross_link)
 export(cross_mark)
 export(cross_none)
-export(dendrogram_data)
 export(draw_key_draw)
 export(draw_key_draw2)
 export(element_curve)

R/align-dendrogram.R

@@ -16,35 +16,12 @@
 #' [`geom_segment`][ggplot2::geom_segment] layer with a data frame of the `edge`
 #' coordinates will be added when `plot_dendrogram = TRUE`.
 #'
-#' dendrogram `node` and `edge` contains following columns:
-#'
-#'   - `.panel`: Tree branch groups, used to create ggplot2 facet. Similar with
-#'              `panel` column, but always give the correct branch for usage of
-#'              the ggplot facet.
-#'  - `.names` and `.index`: a character names (only applicable when names
-#'    exists) and an integer index of the original data.
-#'   - `label`: node label text
-#'   - `x` and `y`: x-axis and y-axis coordinates for current node or the start
-#'                  node of the current edge.
-#'   - `xend` and `yend`: the x-axis and y-axis coordinates of the terminal node
-#'                        for current edge.
-#'   - `branch`: which branch current node or edge is. You can use this column
-#'               to color different groups.
-#'   - `leaf`: A logical value indicates whether current node is a leaf.
-#'   - `panel`: which panel current node is, if we split the plot into panel
-#'              using [`facet_grid`][ggplot2::facet_grid], this column will show
-#'              which panel current node or edge is from. Note: some nodes may
-#'              fall outside panel (between two panel), so there are possible
-#'              `NA` values in this column.
-#'   - `panel1` and `panel2`: The panel1 and panel2 variables have the same
-#'     functionality as `panel`, but they are specifically for the `edge` data
-#'     and correspond to both nodes of each edge.
-#'
+#' See [`fortify_data_frame.dendrogram()`] for details.
 #' @param merge_dendrogram A single boolean value, indicates whether we should
 #' merge multiple dendrograms, only used when previous groups have been
 #' established. Default: `FALSE`.
 #' @inheritParams align_hclust
-#' @inheritParams dendrogram_data
+#' @inheritParams fortify_data_frame.dendrogram
 #' @inheritParams ggalign
 #' @inheritSection align Discrete Axis Alignment
 #' @examples
@@ -173,7 +150,7 @@ AlignDendro <- ggproto("AlignDendro", AlignHclust,
                 tree <- .subset2(statistics, i)
                 n <- stats::nobs(tree)
                 end <- start + n
-                data[[i]] <- dendrogram_data(
+                data[[i]] <- fortify_data_frame(
                     tree,
                     priority = priority,
                     center = center,
@@ -186,11 +163,19 @@ AlignDendro <- ggproto("AlignDendro", AlignHclust,
                 )
                 start <- end
             }
-            data <- lapply(list_transpose(data), function(dat) {
-                ans <- vec_rbind(!!!dat, .names_to = "parent")
-                ans$ggpanel <- factor(.subset2(ans, "ggpanel"), branches)
-                ans
-            })
+            data <- lapply(
+                list(
+                    node = data,
+                    edge = lapply(data, ggalign_attr, "edge")
+                ),
+                function(dat) {
+                    ans <- vec_rbind(!!!dat, .names_to = "parent")
+                    ans$.panel <- factor(.subset2(ans, ".panel"), branches)
+                    ans
+                }
+            )
+            edge <- .subset2(data, "edge")
+            node <- .subset2(data, "node")
         } else {
             if (nlevels(panel) > 1L && type == "triangle" && self$in_linear) {
                 cli_warn(c(paste(
@@ -199,7 +184,7 @@ AlignDendro <- ggproto("AlignDendro", AlignHclust,
                 ), i = "will use {.filed rectangle} dendrogram instead"))
                 type <- "rectangle"
             }
-            data <- dendrogram_data(
+            data <- fortify_data_frame(
                 statistics,
                 priority = priority,
                 center = center,
@@ -210,11 +195,9 @@ AlignDendro <- ggproto("AlignDendro", AlignHclust,
                 root = root,
                 double = self$in_linear
             )
+            edge <- ggalign_attr(data, "edge")
+            node <- data
         }
-        node <- .subset2(data, "node")
-        edge <- .subset2(data, "edge")
-        node <- rename(node, c(ggpanel = ".panel", index = ".index"))
-        edge <- rename(edge, c(ggpanel = ".panel"))
 
         # add names
         if (!is.null(self$labels)) {

R/align-hclust.R

@@ -28,9 +28,7 @@
 #' (the height at which to cut the tree). By default,
 #' [`cutree()`][stats::cutree()] is used.
 #' @inheritSection align Discrete Axis Alignment
-#' @seealso
-#' - [`dendrogram_data()`]
-#' - [`hclust2()`]
+#' @seealso [`hclust2()`]
 #' @examples
 #' # align_hclust won't add a dendrogram
 #' ggheatmap(matrix(rnorm(81), nrow = 9)) +

R/align-phylo.R

@@ -182,15 +182,15 @@ AlignPhylo <- ggproto("AlignPhylo", Align,
     summary_align = function(self) c(TRUE, FALSE)
 )
 
-#' @inherit fortify_data_frame.default
-#' @inheritParams dendrogram_data
+#' @inherit fortify_data_frame.default title description
+#' @inheritParams rlang::args_dots_empty
+#' @inheritParams fortify_data_frame.dendrogram
 #' @param tree_type A single string, one of
 #' `r oxford_or(c("phylogram", "cladogram"))`, indicating the type of tree.
 #' Usually, you don't need to modify this.
 #' @param tip_pos The x-coordinates of the tip. Must be the same length
 #' of the number of tips in `tree`.
-#' @details
-#' A `data frame` with the node coordinates:
+#' @return A `data frame` with the node coordinates:
 #'   - `.index`: the original index in the tree for the the tip/node.
 #'   - `label`: the tip/node label text.
 #'   - `x` and `y`: x-axis and y-axis coordinates for the tip/node.
@@ -205,6 +205,7 @@ AlignPhylo <- ggproto("AlignPhylo", Align,
 fortify_data_frame.phylo <- function(data, ..., type = "rectangle",
                                      center = FALSE,
                                      tree_type = NULL, tip_pos = NULL) {
+    rlang::check_dots_empty()
     type <- arg_match0(type, c("rectangle", "triangle"))
     rectangle <- type == "rectangle"
     edge <- data$edge

R/dendrogram.R

@@ -109,10 +109,10 @@ make_dist <- function(matrix, distance, use_missing,
     d
 }
 
-#' Dengrogram x and y coordinates
+#' @inherit fortify_data_frame.default title description
 #'
-#' @param tree A [hclust][stats::hclust] or a [dendrogram][stats::as.dendrogram]
-#' object.
+#' @param data A [`hclust`][stats::hclust] or a
+#' [`dendrogram`][stats::as.dendrogram] object.
 #' @param priority A string of "left" or "right". if we draw from right to left,
 #' the left will override the right, so we take the `"left"` as the priority. If
 #' we draw from `left` to `right`, the right will override the left, so we take
@@ -135,50 +135,55 @@ make_dist <- function(matrix, distance, use_missing,
 #' should be doubled when segments span multiple branches. If `TRUE`, the
 #' horizontal lines will be repeated for each branch that the segment spans. If
 #' `FALSE`, only one horizontal line will be drawn.
-#' @return A list of 2 data.frame. One for node coordinates, another for edge
-#' coordinates.
-#' `node` and tree segments `edge` coordinates contains following columns:
-#'   - `index`: the original index in the tree for the current node
+#' @return A `data frame` with the node coordinates:
+#'   - `.panel`: Similar with `panel` column, but always give the correct
+#'              branch for usage of the ggplot facet.
+#'   - `.index`: the original index in the tree for the the node
 #'   - `label`: node label text
-#'   - `x` and `y`: x-axis and y-axis coordinates for current node or the start
-#'                  node of the current edge.
-#'   - `xend` and `yend`: the x-axis and y-axis coordinates of the terminal node
-#'                        for current edge.
-#'   - `branch`: which branch current node or edge is. You can use this column
-#'               to color different groups.
-#'   - `panel`: which panel current node is, if we split the plot into panel
+#'   - `x` and `y`: x-axis and y-axis coordinates for the node
+#'   - `branch`: which branch the node is. You can use this column to color
+#'               different groups.
+#'   - `panel`: which panel the node is, if we split the plot into panel
 #'              using [facet_grid][ggplot2::facet_grid], this column will show
-#'              which panel current node or edge is from. Note: some nodes may
+#'              which panel the node is from. Note: some nodes may
 #'              fall outside panel (between two panels), so there are possible
 #'              `NA` values in this column.
-#'   - `ggpanel`: Similar with `panel` column, but always give the correct
+#'   - `leaf`: A logical value indicates whether the node is a leaf.
+#' @section ggalign attributes:
+#'  `edge`: A `data frame` for edge coordinates:
+#'  - `.panel`: Similar with `panel` column, but always give the correct
 #'              branch for usage of the ggplot facet.
-#'   - `panel1` and `panel2`: The panel1 and panel2 variables have the same
+#'  - `x` and `y`: x-axis and y-axis coordinates for the start node of the edge.
+#'  - `xend` and `yend`: the x-axis and y-axis coordinates of the terminal node
+#'                       for edge.
+#'  - `branch`: which branch the edge is. You can use this column to color
+#'              different groups.
+#'  - `panel1` and `panel2`: The panel1 and panel2 columns have the same
 #'     functionality as `panel`, but they are specifically for the `edge` data
 #'     and correspond to both nodes of each edge.
-#'   - `leaf`: A logical value indicates whether current node is a leaf.
 #' @examples
-#' dendrogram_data(hclust(dist(USArrests), "ave"))
+#' fortify_data_frame(hclust(dist(USArrests), "ave"))
 #' @importFrom grid is.unit
 #' @importFrom stats order.dendrogram
 #' @importFrom rlang arg_match0
+#' @family fortify_data_frame methods
 #' @export
-dendrogram_data <- function(tree,
-                            priority = "right",
-                            center = FALSE,
-                            type = "rectangle",
-                            leaf_pos = NULL,
-                            leaf_braches = NULL,
-                            reorder_branches = TRUE,
-                            branch_gap = NULL,
-                            root = NULL,
-                            double = TRUE) {
-    dend <- check_dendrogram(tree)
+fortify_data_frame.dendrogram <- function(data, ...,
+                                          priority = "right",
+                                          center = FALSE,
+                                          type = "rectangle",
+                                          leaf_pos = NULL,
+                                          leaf_braches = NULL,
+                                          reorder_branches = TRUE,
+                                          branch_gap = NULL,
+                                          root = NULL,
+                                          double = TRUE) {
+    rlang::check_dots_empty()
     assert_bool(center)
     assert_bool(reorder_branches)
     type <- arg_match0(type, c("rectangle", "triangle"))
     priority <- arg_match0(priority, c("left", "right"))
-    N <- stats::nobs(dend)
+    N <- stats::nobs(data)
     rectangle <- type == "rectangle"
     if (is.null(leaf_pos)) {
         leaf_pos <- seq_len(N)
@@ -209,7 +214,7 @@ dendrogram_data <- function(tree,
     }
 
     if (!is.null(leaf_braches) && reorder_branches) {
-        leaf_braches <- .subset(leaf_braches, order.dendrogram(dend))
+        leaf_braches <- .subset(leaf_braches, order.dendrogram(data))
     }
 
     # check `branch_gap`
@@ -239,7 +244,7 @@ dendrogram_data <- function(tree,
     branch_levels <- NULL
     last_branch <- root
     total_gap <- 0
-    .dendrogram_data <- function(dend, from_root = TRUE) {
+    dendrogram_data <- function(dend, from_root = TRUE) {
         if (stats::is.leaf(dend)) { # base version
             index <- as.integer(dend) # the column index of the original data
             y <- attr(dend, "height") %||% 0
@@ -282,7 +287,7 @@ dendrogram_data <- function(tree,
 
             # for the children nodes ---------------------------------
             data <- list_transpose(
-                lapply(dend, .dendrogram_data, from_root = FALSE)
+                lapply(dend, dendrogram_data, from_root = FALSE)
             )
 
             # node should be the direct children
@@ -444,7 +449,7 @@ dendrogram_data <- function(tree,
             cli_abort("{.arg dend} must be a {.cls dendrogram} object")
         }
     }
-    ans <- .dendrogram_data(dend)
+    ans <- dendrogram_data(data)
     node <- .subset2(ans, "node")
     edge <- .subset2(ans, "edge")
 
@@ -460,7 +465,16 @@ dendrogram_data <- function(tree,
         edge$branch <- factor(.subset2(edge, "branch"), branch_levels)
         edge$ggpanel <- factor(.subset2(edge, "ggpanel"), panel_levels)
     }
-    list(node = node, edge = edge)
+    node <- rename(node, c(ggpanel = ".panel", index = ".index"))
+    edge <- rename(edge, c(ggpanel = ".panel"))
+    ggalign_attr_set(node, list(edge = edge))
+}
+
+#' @param ... Additional arguments passed to `dendrogram` method.
+#' @export
+#' @rdname fortify_data_frame.dendrogram
+fortify_data_frame.hclust <- function(data, ...) {
+    fortify_data_frame.dendrogram(stats::as.dendrogram(data), ...)
 }
 
 #' @param ggpanels Won't be `NA`
@@ -584,18 +598,3 @@ tree_branch_heights <- function(dend) {
         )
     }
 }
-
-#' @importFrom rlang caller_arg caller_env
-check_dendrogram <- function(tree, arg = caller_arg(tree),
-                             call = caller_call()) {
-    if (inherits(tree, "hclust")) {
-        stats::as.dendrogram(tree)
-    } else if (inherits(tree, "dendrogram")) {
-        tree
-    } else {
-        cli_abort(paste(
-            "{.arg {arg}} must be a {.cls hclust}",
-            "or a {.cls dendrogram} object."
-        ), call = call)
-    }
-}