Browse code

Merge pull request #461 from xiangpin/graph_layout

Graph layout

Guangchuang Yu authored on 10/12/2021 09:31:38 • GitHub committed on 10/12/2021 09:31:38
Showing4 changed files

... ...
@@ -45,7 +45,8 @@ Suggests:
45 45
     rmarkdown,
46 46
     stats,
47 47
     testthat,
48
-    tibble
48
+    tibble,
49
+    glue
49 50
 Remotes:
50 51
     GuangchuangYu/treeio
51 52
 VignetteBuilder: knitr
... ...
@@ -16,6 +16,7 @@
16 16
 ##' @param branch.length variable for scaling branch, if 'none' draw cladogram
17 17
 ##' @param root.position position of the root node (default = 0)
18 18
 ##' @param xlim x limits, only works for 'inward_circular' layout
19
+##' @param layout.params list, the parameters of layout, when layout is a function.
19 20
 ##' @return tree
20 21
 ##' @importFrom ggplot2 ggplot
21 22
 ##' @importFrom ggplot2 xlab
... ...
@@ -53,12 +54,22 @@ ggtree <- function(tr,
53 54
                    branch.length  = "branch.length",
54 55
                    root.position  = 0,
55 56
                    xlim = NULL,
57
+                   layout.params = list(),
56 58
                    ...) {
57 59
 
58 60
     # Check if layout string is valid.
59
-    layout %<>% match.arg(c("rectangular", "slanted", "fan", "circular", 'inward_circular',
61
+    trash <- try(silent = TRUE,
62
+                 expr = {
63
+                   layout %<>% match.arg(c("rectangular", "slanted", "fan", "circular", 'inward_circular',
60 64
                             "radial", "unrooted", "equal_angle", "daylight", "dendrogram",
61 65
                             "ape", "ellipse", "roundrect"))
66
+                  }
67
+             )
68
+
69
+    dd <- check.graph.layout(tr, trash, layout, layout.params)
70
+    if (inherits(trash, "try-error") && !is.null(dd)){
71
+        layout <- "rectangular"
72
+    }
62 73
 
63 74
     if (layout == "unrooted") {
64 75
         layout <- "daylight"
... ...
@@ -89,6 +100,17 @@ ggtree <- function(tr,
89 100
                 root.position = root.position,
90 101
                 ...)
91 102
 
103
+    if (!is.null(dd)){
104
+        message_wrap("The tree object will be displayed with graph layout since 
105
+                      layout argument was specified the graph layout function.")
106
+        p$data <- dplyr::left_join(
107
+                    p$data %>% select(-c("x", "y")), 
108
+                    dd, 
109
+                    by = "node"
110
+        )
111
+        layout <- "equal_angle"
112
+    }
113
+
92 114
     if (is(tr, "multiPhylo")) {
93 115
         multiPhylo <- TRUE
94 116
     } else {
... ...
@@ -154,3 +176,30 @@ ggtree_references <- function() {
154 176
            "<http://yulab-smu.top/treedata-book/>\n"
155 177
            )
156 178
 }
179
+
180
+check.graph.layout <- function(tr, trash, layout, layout.params){
181
+    if (inherits(trash, "try-error")){
182
+        gp <- ape::as.igraph.phylo(as.phylo(tr), use.labels = FALSE)
183
+        #dd <- ggraph::create_layout(gp, layout = layout)
184
+        if (is.function(layout)){
185
+            dd <- do.call(layout, c(list(gp), layout.params))
186
+            if (!inherits(dd, "matrix")){
187
+                if ("xy" %in% names(dd)){
188
+                    dd <- dd$xx
189
+                }else if ("layout" %in% names(dd)){
190
+                    dd <- dd$layout
191
+                }else{
192
+                    stop(trash, call. = FALSE)
193
+                }
194
+            }
195
+            dd <- data.frame(dd)
196
+            colnames(dd) <- c("x", "y")
197
+            dd$node <- seq_len(nrow(dd))
198
+        }else{
199
+            stop(trash, call. = FALSE)
200
+        }
201
+    }else{
202
+        dd <- NULL
203
+    }
204
+    return(dd)
205
+}
... ...
@@ -117,6 +117,17 @@ getCols <- function (n) {
117 117
     grDevices::colorRampPalette(col3)(n)
118 118
 }
119 119
 
120
+message_wrap <- function(...){
121
+    msg <- .return_wrap(...)
122
+    message(msg)
123
+}
124
+
125
+.return_wrap <- function(...){
126
+    msg <- paste(..., collapse = "", sep = "")
127
+    wrapped <- strwrap(msg, width = getOption("width") - 2) %>%
128
+        glue::glue_collapse(., "\n", last = "\n")
129
+    wrapped
130
+}
120 131
 
121 132
 ##
122 133
 ##
... ...
@@ -21,6 +21,7 @@ ggtree(
21 21
   branch.length = "branch.length",
22 22
   root.position = 0,
23 23
   xlim = NULL,
24
+  layout.params = list(),
24 25
   ...
25 26
 )
26 27
 }
... ...
@@ -54,6 +55,8 @@ right-hand side? See \code{\link[ape:ladderize]{ape::ladderize()}} for more info
54 55
 
55 56
 \item{xlim}{x limits, only works for 'inward_circular' layout}
56 57
 
58
+\item{layout.params}{list, the parameters of layout, when layout is a function.}
59
+
57 60
 \item{...}{additional parameter
58 61
 
59 62
 some dot arguments: