Browse code

gheatmap supports collapsed tree

git-svn-id: file:///home/git/hedgehog.fhcrc.org/bioconductor/trunk/madman/Rpacks/ggtree@130759 bc3139a8-67e5-0310-9ffc-ced21a209358

Guangchuang Yu authored on 29/06/2017 05:20:54
Showing10 changed files

... ...
@@ -1,3 +1,4 @@
1
+
1 2
 Justin Silverman
2 3
 ----------------
3 4
 + `geom_balance`
... ...
@@ -2,7 +2,7 @@ Package: ggtree
2 2
 Type: Package
3 3
 Title: an R package for visualization and annotation of phylogenetic trees with
4 4
     their covariates and other associated data
5
-Version: 1.9.0
5
+Version: 1.9.2
6 6
 Authors@R: c(
7 7
 	   person("Guangchuang", "Yu", email = "guangchuangyu@gmail.com", role = c("aut", "cre", "cph")),
8 8
 	   person("Tommy Tsan-Yuk", "Lam", email = "tylam.tommy@gmail.com", rol = c("aut", "ths")),
... ...
@@ -1,3 +1,13 @@
1
+CHANGES IN VERSION 1.9.2
2
+------------------------
3
+ o gheatmap support handling collapsed tree <2017-06-29, Thu>
4
+   + https://github.com/GuangchuangYu/ggtree/issues/137
5
+
6
+CHANGES IN VERSION 1.9.1
7
+------------------------
8
+ o now mapping parameter will passed to segment layer in geom_tiplab(align=T) <2017-06-19, Mon>
9
+ o geom_cladelabel support `angle="auto"` for circular layout tree <2017-05-05, Fri>
10
+
1 11
 CHANGES IN VERSION 1.8.0
2 12
 ------------------------
3 13
  o BioC 3.5 release <2017-04-26, Wed>
4 14
deleted file mode 100644
... ...
@@ -1,281 +0,0 @@
1
-
2
-## ##' read beast output
3
-## ##'
4
-## ##'
5
-## ##' @title read.beast
6
-## ##' @param file beast file
7
-## ##' @return \code{beast} object
8
-## ##' @importFrom ape read.nexus
9
-## ##' @export
10
-## ##' @author Guangchuang Yu \url{http://ygc.name}
11
-## ##' @examples
12
-## ##' file <- system.file("extdata/BEAST", "beast_mcc.tree", package="ggtree")
13
-## ##' read.beast(file)
14
-## read.beast <- function(file) {
15
-##     translation <- read.trans_beast(file)
16
-##     treetext <- read.treetext_beast(file)
17
-##     stats <- read.stats_beast(file)
18
-##     phylo <- read.nexus(file)
19
-
20
-##     if (length(treetext) == 1) {
21
-##         obj <- BEAST(file, treetext, translation, stats, phylo)
22
-##     } else {
23
-##         obj <- lapply(seq_along(treetext), function(i) {
24
-##             BEAST(file, treetext[i], translation, stats[[i]], phylo[[i]])
25
-##         })
26
-##         class(obj) <- "beastList"
27
-##     }
28
-##     return(obj)
29
-## }
30
-
31
-
32
-## BEAST <- function(file, treetext, translation, stats, phylo) {
33
-##     stats$node %<>% gsub("\"*'*", "", .)
34
-
35
-##     fields <- sub("_lower|_upper", "", names(stats)) %>% unique
36
-##     fields %<>% `[`(.!="node")
37
-
38
-##     phylo <- remove_quote_in_tree_label(phylo)
39
-
40
-##     obj <- new("beast",
41
-##                fields      = fields,
42
-##                treetext    = treetext,
43
-##                phylo       = phylo,
44
-##                translation = translation,
45
-##                stats       = stats,
46
-##                file        = filename(file)
47
-##                )
48
-##     return(obj)
49
-## }
50
-
51
-## remove_quote_in_tree_label <- function(phylo) {
52
-##     if (!is.null(phylo$node.label)) {
53
-##         phylo$node.label %<>% gsub("\"*'*", "", .)
54
-##     }
55
-##     if ( !is.null(phylo$tip.label)) {
56
-##         phylo$tip.label %<>% gsub("\"*'*", "", .)
57
-##     }
58
-##     return(phylo)
59
-## }
60
-
61
-
62
-## ##' @rdname get.fields-methods
63
-## ##' @exportMethod get.fields
64
-## setMethod("get.fields", signature(object="beast"),
65
-##           function(object, ...) {
66
-##               get.fields.tree(object)
67
-##           }
68
-##           )
69
-
70
-
71
-## read.treetext_beast <- function(file) {
72
-##     beast <- readLines(file)
73
-
74
-##     ii <- grep("[Bb]egin trees;", beast)
75
-##     jj <- grep("[Ee]nd;", beast)
76
-##     jj <- jj[jj > max(ii)][1]
77
-##     jj <- c(ii[-1], jj)
78
-
79
-##     trees <- sapply(seq_along(ii), function(i) {
80
-##         tree <- beast[(ii[i]+1):(jj[i]-1)]
81
-##         tree <- tree[grep("\\s*[Tt]ree", tree)]
82
-##         ## if (length(tree) > 1) {
83
-##         ##     tree <- paste0(tree, collapse='')
84
-##         ## }
85
-##         sub("[^(]*", "", tree)
86
-##     })
87
-
88
-##     return(trees)
89
-## }
90
-
91
-## read.trans_beast <- function(file) {
92
-##     beast <- readLines(file)
93
-##     i <- grep("TRANSLATE", beast, ignore.case = TRUE)
94
-##     if (length(i) == 0) {
95
-##         return(matrix())
96
-##     }
97
-##     end <- grep(";", beast)
98
-##     j <- end[end %>% `>`(i) %>% which %>% `[`(1)]
99
-##     trans <- beast[(i+1):j]
100
-##     trans %<>% gsub("\\t+", "", .)
101
-##     trans %<>% gsub(",|;", "", .)
102
-##     trans %<>% `[`(nzchar(trans))
103
-##     ## remove quote if strings were quoted
104
-##     trans %<>% gsub("'|\"", "",.)
105
-##     trans %<>% sapply(., strsplit, split="\\s+")
106
-##     trans %<>% do.call(rbind, .)
107
-##     ## trans is a matrix
108
-##     return(trans)
109
-## }
110
-
111
-
112
-## read.stats_beast <- function(file) {
113
-##     beast <- readLines(file)
114
-##     trees <- read.treetext_beast(file)
115
-##     if (length(trees) == 1) {
116
-##         return(read.stats_beast_internal(beast, trees))
117
-##     }
118
-##     lapply(trees, read.stats_beast_internal, beast=beast)
119
-## }
120
-
121
-## read.stats_beast_internal <- function(beast, tree) {
122
-##     tree2 <- gsub("\\[[^\\[]*\\]", "", tree)
123
-##     phylo <- read.tree(text = tree2)
124
-
125
-##     tree2 <- add_pseudo_nodelabel(phylo, tree2)
126
-
127
-##     ## node name corresponding to stats
128
-##     nn <- strsplit(tree2, split=",") %>% unlist %>%
129
-##         strsplit(., split="\\)") %>% unlist %>%
130
-##         gsub("\\(*", "", .) %>%
131
-##         gsub("[:;].*", "", .)
132
-
133
-##     phylo <- read.tree(text = tree2)
134
-##     root <- getRoot(phylo)
135
-##     nnode <- phylo$Nnode
136
-
137
-##     ## phylo2 <- read.nexus(file)
138
-##     ## treeinfo <- fortify.phylo(phylo)
139
-##     ## treeinfo2 <- fortify.phylo(phylo2)
140
-##     ## treeinfo$label2 <- NA
141
-##     ## treeinfo$label2[treeinfo$isTip] <- treeinfo2$node[as.numeric(treeinfo$label[treeinfo$isTip])]
142
-##     ## treeinfo$visited <- FALSE
143
-##     ## root <- getRoot(phylo2)
144
-##     ## treeinfo[root, "visited"] <- TRUE
145
-##     ## currentNode <- 1:Ntip(phylo2)
146
-##     ## while(any(treeinfo$visited == FALSE)) {
147
-##     ##     pNode <- c()
148
-##     ##     for (kk in currentNode) {
149
-##     ##         i <- which(treeinfo$label2 == kk)
150
-##     ##         treeinfo[i, "visited"] <- TRUE
151
-##     ##         j <- which(treeinfo2$node == kk)
152
-##     ##         ip <- treeinfo$parent[i]
153
-##     ##         if (ip != root) {
154
-##     ##             ii <- which(treeinfo$node == ip)
155
-##     ##             if (treeinfo$visited[ii] == FALSE) {
156
-##     ##                 jp <- treeinfo2$parent[j]
157
-##     ##                 jj <- which(treeinfo2$node == jp)
158
-##     ##                 treeinfo[ii, "label2"] <- treeinfo2[jj, "node"]
159
-##     ##                 pNode <- c(pNode, jp)
160
-##     ##             }
161
-##     ##             treeinfo[ii, "visited"] <- TRUE
162
-##     ##         }
163
-##     ##     }
164
-##     ##     currentNode <- unique(pNode)
165
-##     ## }
166
-##     ## treeinfo[root, "label2"] <- root
167
-##     ## ## convert nn to node that encoded in phylo2
168
-##     ## node <- treeinfo$label2[match(nn, treeinfo$label)]
169
-
170
-
171
-##     ####################################################
172
-##     ##                                                ##
173
-##     ##  after doing it in the hard way                ##
174
-##     ##  I finally figure out the following easy way   ##
175
-##     ##                                                ##
176
-##     ####################################################
177
-##     treeinfo <- fortify.phylo(phylo)
178
-
179
-##     if (any(grepl("TRANSLATE", beast, ignore.case = TRUE))) {
180
-##         label2 <- c(treeinfo[treeinfo$isTip, "label"],
181
-##                     root:(root+nnode-1))
182
-##         node <- label2[match(nn, treeinfo$label)]
183
-##     } else {
184
-##         node <- as.character(treeinfo$node[match(nn, treeinfo$label)])
185
-##     }
186
-
187
-##     ## stats <- unlist(strsplit(tree, "\\["))[-1]
188
-##     ## stats <- sub(":.+$", "", stats
189
-##     stats <- strsplit(tree, ":") %>% unlist
190
-##     names(stats) <- node
191
-##     stats <- stats[grep("\\[", stats)]
192
-##     stats <- sub("[^\\[]+\\[", "", stats)
193
-
194
-##     stats <- sub("^&", "", stats)
195
-##     stats <- sub("];*$", "", stats)
196
-
197
-##     stats2 <- lapply(stats, function(x) {
198
-##         y <- unlist(strsplit(x, ","))
199
-##         sidx <- grep("=\\{", y)
200
-##         eidx <- grep("\\}$", y)
201
-
202
-##         flag <- FALSE
203
-##         if (length(sidx) > 0) {
204
-##             flag <- TRUE
205
-##             SETS <- sapply(seq_along(sidx), function(k) {
206
-##                 p <- y[sidx[k]:eidx[k]]
207
-##                 gsub(".*=\\{", "", p) %>% gsub("\\}$", "", .) %>% list
208
-##             })
209
-##             names(SETS) <- gsub("=.*", "", y[sidx])
210
-
211
-##             kk <- sapply(seq_along(sidx), function(k) sidx[k]:eidx[k]) %>% unlist
212
-##             y <- y[-kk]
213
-##         }
214
-
215
-
216
-##         name <- gsub("=.*", "", y)
217
-##         val <- gsub(".*=", "", y) %>% gsub("^\\{", "", .) %>%
218
-##             gsub("\\}$", "", .)
219
-
220
-
221
-##         if (flag) {
222
-##             nn <- c(name, names(SETS))
223
-##         } else {
224
-##             nn <- name
225
-##         }
226
-
227
-##         res <- character(length(nn))
228
-##         names(res) <- nn
229
-
230
-##         for (i in seq_along(name)) {
231
-##             res[i] <- val[i]
232
-##         }
233
-##         if (flag) {
234
-##             j <- i
235
-##             for (i in seq_along(SETS)) {
236
-##                 res[i+j] <- SETS[i]
237
-##             }
238
-##         }
239
-
240
-##         return(res)
241
-##     })
242
-
243
-##     nn <- lapply(stats2, names) %>% unlist %>%
244
-##         unique %>% sort
245
-
246
-##     ## stats3 is a matrix
247
-##     stats3 <- t(sapply(stats2, function(x) {
248
-##         for (ii in nn[!nn %in% names(x)]) {
249
-##             x[ii] <- NA
250
-##         }
251
-##         x[nn]
252
-##     }))
253
-
254
-##     stats3 <- as.data.frame(stats3)
255
-##     if (nrow(stats3) == 1) {
256
-##         ## only has one evidence
257
-##         ## transpose
258
-##         stats3 <- data.frame(X=unlist(stats3[1,]))
259
-##         colnames(stats3) <- nn
260
-##     }
261
-##     colnames(stats3) <- gsub("(\\d+)%", "0.\\1", colnames(stats3))
262
-
263
-##     ## stats3$node <- node
264
-##     stats3$node <- names(stats)
265
-##     return(stats3)
266
-## }
267
-
268
-## add_pseudo_nodelabel <- function(phylo, treetext) {
269
-##     if(is.null(phylo$node.label)) {
270
-##         nnode <- phylo$Nnode
271
-##         nlab <- paste("X", 1:nnode, sep="")
272
-##         for (i in 1:nnode) {
273
-##             treetext <- sub("\\)([:;])", paste0("\\)", nlab[i], "\\1"), treetext)
274
-##         }
275
-##     }
276
-
277
-##    return(treetext)
278
-## }
279
-
280
-
281
-
... ...
@@ -69,7 +69,7 @@ geom_cladelabel <- function(node, label, offset=0, offset.text=0,
69 69
                                         mapping=mapping, data=data, geom=geom, hjust=hjust,
70 70
                                         position=position, show.legend = show.legend,
71 71
                                         inherit.aes = inherit.aes, na.rm=na.rm,
72
-                                        parse = parse, ...)
72
+                                        parse = parse,  ...)
73 73
         }
74 74
 
75 75
         layer_bar <- stat_cladeBar(node=node, offset=offset, align=align,
... ...
@@ -84,7 +84,7 @@ geom_cladelabel <- function(node, label, offset=0, offset.text=0,
84 84
                                         align=align, size=fontsize, angle=angle, color=labelcolor, family=family,
85 85
                                         mapping=mapping, data=data, geom=geom, hjust=hjust,
86 86
                                         position=position, show.legend = show.legend,
87
-                                        inherit.aes = inherit.aes, na.rm=na.rm, parse=parse, ...)
87
+                                        inherit.aes = inherit.aes, na.rm=na.rm, parse=parse,  ...)
88 88
 
89 89
         } else {
90 90
             layer_text = stat_cladeText(node=node, label=label, offset=offset+offset.text,
... ...
@@ -92,7 +92,7 @@ geom_cladelabel <- function(node, label, offset=0, offset.text=0,
92 92
                                         mapping=mapping, data=data, geom=geom, hjust=hjust,
93 93
                                         position=position, show.legend = show.legend,
94 94
                                         inherit.aes = inherit.aes, na.rm=na.rm,
95
-                                        parse = parse, ...)
95
+                                        parse = parse,  ...)
96 96
         }
97 97
 
98 98
         layer_bar <- stat_cladeBar(node=node, offset=offset, align=align,
... ...
@@ -112,10 +112,10 @@ geom_cladelabel <- function(node, label, offset=0, offset.text=0,
112 112
 
113 113
 stat_cladeText <- function(mapping=NULL, data=NULL,
114 114
                            geom="text", position="identity",
115
-                           node, label, offset, align, ...,
115
+                           node, label, offset, align, ..., angle,
116 116
                            show.legend=NA, inherit.aes=FALSE,
117 117
                            na.rm=FALSE, parse=FALSE) {
118
-    default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent)
118
+    default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent, angle=~angle)
119 119
     if (is.null(mapping)) {
120 120
         mapping <- default_aes
121 121
     } else {
... ...
@@ -135,6 +135,7 @@ stat_cladeText <- function(mapping=NULL, data=NULL,
135 135
                       align  = align,
136 136
                       na.rm  = na.rm,
137 137
                       parse  = parse,
138
+                      angle_ = angle,
138 139
                       ...),
139 140
           check.aes = FALSE
140 141
           )
... ...
@@ -169,38 +170,45 @@ stat_cladeBar <- function(mapping=NULL, data=NULL,
169 170
 }
170 171
 
171 172
 StatCladeText <- ggproto("StatCladeText", Stat,
172
-                         compute_group = function(self, data, scales, params, node, label, offset, align) {
173
-                             df <- get_cladelabel_position(data, node, offset, align, adjustRatio = 1.03)
173
+                         compute_group = function(self, data, scales, params, node, label, offset, align, angle_) {
174
+                             df <- get_cladelabel_position(data, node, offset, align, adjustRatio = 1.03, angle_)
174 175
                              df$y <- mean(c(df$y, df$yend))
175 176
                              df$label <- label
176 177
                              return(df)
177 178
                          },
178
-                         required_aes = c("x", "y", "label")
179
+                         required_aes = c("x", "y", "label", "angle")
179 180
                          )
180 181
 
181 182
 
182 183
 
183 184
 StatCladeBar <- ggproto("StatCladBar", Stat,
184 185
                         compute_group = function(self, data, scales, params, node, offset, align) {
185
-                            get_cladelabel_position(data, node, offset, align, adjustRatio=1.02)
186
+                            get_cladelabel_position(data, node, offset, align, adjustRatio=1.02, angle=0)
186 187
                         },
187 188
                         required_aes = c("x", "y", "xend", "yend")
188 189
                         )
189 190
 
190 191
 
191
-get_cladelabel_position <- function(data, node, offset, align, adjustRatio) {
192
-    df <- get_cladelabel_position_(data, node)
192
+get_cladelabel_position <- function(data, node, offset, align, adjustRatio, angle="auto") {
193
+    df <- get_cladelabel_position_(data, node, angle)
193 194
     if (align) {
194 195
         mx <- max(data$x, na.rm=TRUE)
195 196
     } else {
196 197
         mx <- df$x
197 198
     }
199
+
200
+    angle <- df$angle
201
+    ## if (angle >= 90 & angle <=270) {
202
+    ##     angle <- angle + 180
203
+    ## }
204
+
198 205
     mx <- mx * adjustRatio + offset
199
-    data.frame(x=mx, xend=mx, y=df$y, yend=df$yend)
206
+    
207
+    data.frame(x=mx, xend=mx, y=df$y, yend=df$yend, angle=angle)
200 208
 }
201 209
 
202 210
 
203
-get_cladelabel_position_ <- function(data, node) {
211
+get_cladelabel_position_ <- function(data, node, angle="auto") {
204 212
     sp <- get.offspring.df(data, node)
205 213
     sp2 <- c(sp, node)
206 214
     sp.df <- data[match(sp2, data$node),]
... ...
@@ -208,6 +216,16 @@ get_cladelabel_position_ <- function(data, node) {
208 216
     y <- sp.df$y
209 217
     y <- y[!is.na(y)]
210 218
     mx <- max(sp.df$x, na.rm=TRUE)
211
-    data.frame(x=mx, y=min(y), yend=max(y))
219
+
220
+    d <- data.frame(x=mx, y=min(y), yend=max(y))
221
+    if (missing(angle))
222
+        return(d)
223
+
224
+    if (angle == "auto") {
225
+        d$angle <- mean(range(sp.df$angle))
226
+    } else {
227
+        d$angle <- angle
228
+    }
229
+    return(d)
212 230
 }
213 231
 
... ...
@@ -18,7 +18,7 @@
18 18
 ##' require(ape)
19 19
 ##' tr <- rtree(10)
20 20
 ##' ggtree(tr) + geom_tiplab()
21
-geom_tiplab <- function(mapping=NULL, hjust = 0,  align = FALSE, linetype = "dotted", linesize=1, geom="text", offset = 0, ...) {
21
+geom_tiplab <- function(mapping=NULL, hjust = 0,  align = FALSE, linetype = "dotted", linesize=1, geom="text",  offset=0, ...) {
22 22
     geom <- match.arg(geom, c("text", "label"))
23 23
     if (geom == "text") {
24 24
         text_geom <- geom_text2
... ...
@@ -43,6 +43,12 @@ geom_tiplab <- function(mapping=NULL, hjust = 0,  align = FALSE, linetype = "dot
43 43
     show_segment <- FALSE
44 44
     if (align && (!is.na(linetype) && !is.null(linetype))) {
45 45
         show_segment <- TRUE
46
+        segment_mapping <- aes(x = max(x, na.rm=TRUE),
47
+                               xend = x + diff(range(x, na.rm=TRUE))/200,
48
+                               y = y, yend = y,
49
+                               subset=isTip)
50
+        if (!is.null(mapping))
51
+            segment_mapping <- modifyList(segment_mapping, mapping)
46 52
     }
47 53
 
48 54
     list(
... ...
@@ -50,10 +56,14 @@ geom_tiplab <- function(mapping=NULL, hjust = 0,  align = FALSE, linetype = "dot
50 56
                   hjust = hjust, nudge_x = offset, ...)
51 57
         ,
52 58
         if (show_segment)
53
-            geom_tipsegment(mapping = aes(subset=isTip),
54
-                            offset = offset,
55
-                            linetype = linetype,
56
-                            size = linesize, ...)
59
+            geom_segment2(mapping = segment_mapping,
60
+                          linetype = linetype,
61
+                          size = linesize, ...)
62
+
63
+            ## geom_tipsegment(mapping = segment_mapping,
64
+            ##                 offset = offset,
65
+            ##                 linetype = linetype,
66
+            ##                 size = linesize, ...)
57 67
     )
58 68
 }
59 69
 
... ...
@@ -88,47 +98,47 @@ geom_tiplab2 <- function(mapping=NULL, hjust=0, ...) {
88 98
          )
89 99
 }
90 100
 
91
-geom_tipsegment <- function(mapping=NULL, data=NULL,
92
-                            geom=GeomSegmentGGtree, position = "identity",
93
-                            offset,  ...,
94
-                            show.legend=NA, inherit.aes=FALSE,
95
-                            na.rm=TRUE) {
96
-
97
-    default_aes <- aes_(x=~x, y=~y)
98
-    if (is.null(mapping)) {
99
-        mapping <- default_aes
100
-    } else {
101
-        mapping <- modifyList(default_aes, mapping)
102
-    }
103
-
104
-    layer(stat=StatTipSegment,
105
-          data = data,
106
-          mapping = mapping,
107
-          geom = geom,
108
-          position = position,
109
-          show.legend = show.legend,
110
-          inherit.aes = inherit.aes,
111
-          params = list(offset = offset,
112
-                        na.rm = na.rm,
113
-                        ...),
114
-          check.aes = FALSE
115
-          )
116
-}
117
-
118
-StatTipSegment <- ggproto("StatTipSegment", Stat,
119
-                        compute_group = function(self, data, scales, params, offset) {
120
-                            get_tipsegment_position(data, offset)
121
-                        },
122
-                        required_aes = c("x", "y")
123
-                        )
124
-
125
-
126
-get_tipsegment_position <- function(data, offset, adjustRatio=1/200) {
127
-    adjust <- diff(range(data$x, na.rm=TRUE)) * adjustRatio
128
-    xend <- data$x + adjust
129
-    x <- max(data$x, na.rm = TRUE)  + offset
130
-    y <- data$y
131
-    data.frame(x=x, xend=xend, y=y, yend=y)
132
-}
101
+## geom_tipsegment <- function(mapping=NULL, data=NULL,
102
+##                             geom=GeomSegmentGGtree, position = "identity",
103
+##                             offset,  ...,
104
+##                             show.legend=NA, inherit.aes=FALSE,
105
+##                             na.rm=TRUE) {
106
+
107
+##     default_aes <- aes_(x=~x, y=~y)
108
+##     if (is.null(mapping)) {
109
+##         mapping <- default_aes
110
+##     } else {
111
+##         mapping <- modifyList(default_aes, mapping)
112
+##     }
113
+
114
+##     layer(stat=StatTipSegment,
115
+##           data = data,
116
+##           mapping = mapping,
117
+##           geom = geom,
118
+##           position = position,
119
+##           show.legend = show.legend,
120
+##           inherit.aes = inherit.aes,
121
+##           params = list(offset = offset,
122
+##                         na.rm = na.rm,
123
+##                         ...),
124
+##           check.aes = FALSE
125
+##           )
126
+## }
127
+
128
+## StatTipSegment <- ggproto("StatTipSegment", Stat,
129
+##                         compute_group = function(self, data, scales, params, offset) {
130
+##                             get_tipsegment_position(data, offset)
131
+##                         },
132
+##                         required_aes = c("x", "y")
133
+##                         )
134
+
135
+
136
+## get_tipsegment_position <- function(data, offset, adjustRatio=1/200) {
137
+##     adjust <- diff(range(data$x, na.rm=TRUE)) * adjustRatio
138
+##     xend <- data$x + adjust
139
+##     x <- max(data$x, na.rm = TRUE)  + offset
140
+##     y <- data$y
141
+##     data.frame(x=x, xend=xend, y=y, yend=y)
142
+## }
133 143
 
134 144
 
... ...
@@ -1,6 +1,6 @@
1 1
 ##' append a heatmap of a matrix to right side of phylogenetic tree
2 2
 ##'
3
-##' 
3
+##'
4 4
 ##' @title gheatmap
5 5
 ##' @param p tree view
6 6
 ##' @param data matrix or data.frame
... ...
@@ -31,26 +31,32 @@
31 31
 gheatmap <- function(p, data, offset=0, width=1, low="green", high="red", color="white",
32 32
                      colnames=TRUE, colnames_position="bottom", colnames_angle=0, colnames_level=NULL,
33 33
                      colnames_offset_x = 0, colnames_offset_y = 0, font.size=4, hjust=0.5) {
34
-    
34
+
35 35
     colnames_position %<>% match.arg(c("bottom", "top"))
36 36
     variable <- value <- lab <- y <- NULL
37
-    
37
+
38 38
     ## if (is.null(width)) {
39 39
     ##     width <- (p$data$x %>% range %>% diff)/30
40 40
     ## }
41
-    
41
+
42 42
     ## convert width to width of each cell
43
-    width <- width * (p$data$x %>% range %>% diff) / ncol(data)
44
-    
43
+    width <- width * (p$data$x %>% range(na.rm=TRUE) %>% diff) / ncol(data)
44
+
45 45
     isTip <- x <- y <- variable <- value <- from <- to <- NULL
46
-    
46
+
47 47
     df <- p$data
48 48
     df <- df[df$isTip,]
49
-    start <- max(df$x) + offset
50
-    
49
+    start <- max(df$x, na.rm=TRUE) + offset
50
+
51 51
     dd <- as.data.frame(data)
52 52
     ## dd$lab <- rownames(dd)
53
-    lab <- df$label[order(df$y)]
53
+    i <- order(df$y)
54
+
55
+    ## handle collapsed tree
56
+    ## https://github.com/GuangchuangYu/ggtree/issues/137
57
+    i <- i[!is.na(df$y[i])]
58
+
59
+    lab <- df$label[i]
54 60
     dd <- dd[lab, , drop=FALSE]
55 61
     dd$y <- sort(df$y)
56 62
     dd$lab <- lab
... ...
@@ -69,10 +75,10 @@ gheatmap <- function(p, data, offset=0, width=1, low="green", high="red", color=
69 75
     V2 <- start + as.numeric(dd$variable) * width
70 76
     mapping <- data.frame(from=dd$variable, to=V2)
71 77
     mapping <- unique(mapping)
72
-    
78
+
73 79
     dd$x <- V2
74 80
     dd$width <- width
75
-    
81
+
76 82
     if (is.null(color)) {
77 83
         p2 <- p + geom_tile(data=dd, aes(x, y, fill=value), width=width, inherit.aes=FALSE)
78 84
     } else {
... ...
@@ -83,7 +89,7 @@ gheatmap <- function(p, data, offset=0, width=1, low="green", high="red", color=
83 89
     } else {
84 90
         p2 <- p2 + scale_fill_discrete(na.value=NA) #"white")
85 91
     }
86
-    
92
+
87 93
     if (colnames) {
88 94
         if (colnames_position == "bottom") {
89 95
             y <- 0
... ...
@@ -94,10 +100,10 @@ gheatmap <- function(p, data, offset=0, width=1, low="green", high="red", color=
94 100
         p2 <- p2 + geom_text(data=mapping, aes(x=to, y = y, label=from), size=font.size, inherit.aes = FALSE,
95 101
                              angle=colnames_angle, nudge_x=colnames_offset_x, nudge_y = colnames_offset_y, hjust=hjust)
96 102
     }
97
-    
103
+
98 104
     p2 <- p2 + theme(legend.position="right", legend.title=element_blank())
99 105
     ## p2 <- p2 + guides(fill = guide_legend(override.aes = list(colour = NULL)))
100
-    
106
+
101 107
     attr(p2, "mapping") <- mapping
102 108
     return(p2)
103 109
 }
... ...
@@ -8,6 +8,9 @@ fortify.treedata <- function(model, data, layout="rectangular", yscale="none",
8 8
     model <- set_branch_length(model, branch.length)
9 9
 
10 10
     x <- reorder.phylo(get.tree(model), "postorder")
11
+    if (ladderize == TRUE) {
12
+        x <- ladderize(x, right=right)
13
+    }
11 14
     if (is.null(x$edge.length) || branch.length == "none") {
12 15
         xpos <- getXcoord_no_length(x)
13 16
     } else {
... ...
@@ -1078,6 +1081,7 @@ getXcoord2 <- function(x, root, parent, child, len, start=0, rev=FALSE) {
1078 1081
     if (rev == TRUE) {
1079 1082
         direction <- -1
1080 1083
     }
1084
+
1081 1085
     while(anyNA(x)) {
1082 1086
         idx <- which(parent %in% currentNode)
1083 1087
         newNode <- child[idx]
... ...
@@ -1186,9 +1190,15 @@ getYcoord <- function(tr, step=1) {
1186 1190
     y[tip.idx] <- 1:Ntip * step
1187 1191
     y[-tip.idx] <- NA
1188 1192
 
1193
+    ## use lookup table
1194
+    pvec <- integer(max(tr$edge))
1195
+    pvec[child] = parent
1196
+
1189 1197
     currentNode <- 1:Ntip
1190 1198
     while(anyNA(y)) {
1191
-        pNode <- unique(parent[child %in% currentNode])
1199
+        ## pNode <- unique(parent[child %in% currentNode])
1200
+        pNode <- unique(pvec[currentNode])
1201
+
1192 1202
         ## piping of magrittr is slower than nested function call.
1193 1203
         ## pipeR is fastest, may consider to use pipeR
1194 1204
         ##
... ...
@@ -4,9 +4,9 @@ ggtree: an R package for visualization and annotation of phylogenetic trees with
4 4
 
5 5
 <img src="https://raw.githubusercontent.com/Bioconductor/BiocStickers/master/ggtree/ggtree.png" height="200" align="right" />
6 6
 
7
-[![](https://img.shields.io/badge/release%20version-1.8.0-green.svg?style=flat)](https://bioconductor.org/packages/ggtree) [![](https://img.shields.io/badge/devel%20version-1.9.0-green.svg?style=flat)](https://github.com/guangchuangyu/ggtree) [![Bioc](http://www.bioconductor.org/shields/years-in-bioc/ggtree.svg)](https://www.bioconductor.org/packages/devel/bioc/html/ggtree.html#since) [![](https://img.shields.io/badge/download-14583/total-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) [![](https://img.shields.io/badge/download-1385/month-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree)
7
+[![](https://img.shields.io/badge/release%20version-1.8.1-green.svg?style=flat)](https://bioconductor.org/packages/ggtree) [![](https://img.shields.io/badge/devel%20version-1.9.1-green.svg?style=flat)](https://github.com/guangchuangyu/ggtree) [![Bioc](http://www.bioconductor.org/shields/years-in-bioc/ggtree.svg)](https://www.bioconductor.org/packages/devel/bioc/html/ggtree.html#since) [![](https://img.shields.io/badge/download-16674/total-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) [![](https://img.shields.io/badge/download-1117/month-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree)
8 8
 
9
-[![Project Status: Active - The project has reached a stable, usable state and is being actively developed.](http://www.repostatus.org/badges/latest/active.svg)](http://www.repostatus.org/#active) [![codecov](https://codecov.io/gh/GuangchuangYu/ggtree/branch/master/graph/badge.svg)](https://codecov.io/gh/GuangchuangYu/ggtree) [![Last-changedate](https://img.shields.io/badge/last%20change-2017--04--28-green.svg)](https://github.com/GuangchuangYu/ggtree/commits/master) [![GitHub forks](https://img.shields.io/github/forks/GuangchuangYu/ggtree.svg)](https://github.com/GuangchuangYu/ggtree/network) [![GitHub stars](https://img.shields.io/github/stars/GuangchuangYu/ggtree.svg)](https://github.com/GuangchuangYu/ggtree/stargazers) [![Awesome](https://cdn.rawgit.com/sindresorhus/awesome/d7305f38d29fed78fa85652e3a63e154dd8e8829/media/badge.svg)](https://awesome-r.com/#awesome-r-graphic-displays)
9
+[![Project Status: Active - The project has reached a stable, usable state and is being actively developed.](http://www.repostatus.org/badges/latest/active.svg)](http://www.repostatus.org/#active) [![codecov](https://codecov.io/gh/GuangchuangYu/ggtree/branch/master/graph/badge.svg)](https://codecov.io/gh/GuangchuangYu/ggtree) [![Last-changedate](https://img.shields.io/badge/last%20change-2017--06--29-green.svg)](https://github.com/GuangchuangYu/ggtree/commits/master) [![GitHub forks](https://img.shields.io/github/forks/GuangchuangYu/ggtree.svg)](https://github.com/GuangchuangYu/ggtree/network) [![GitHub stars](https://img.shields.io/github/stars/GuangchuangYu/ggtree.svg)](https://github.com/GuangchuangYu/ggtree/stargazers) [![Awesome](https://cdn.rawgit.com/sindresorhus/awesome/d7305f38d29fed78fa85652e3a63e154dd8e8829/media/badge.svg)](https://awesome-r.com/#awesome-r-graphic-displays)
10 10
 
11 11
 [![platform](http://www.bioconductor.org/shields/availability/devel/ggtree.svg)](https://www.bioconductor.org/packages/devel/bioc/html/ggtree.html#archives) [![Build Status](http://www.bioconductor.org/shields/build/devel/bioc/ggtree.svg)](https://bioconductor.org/checkResults/devel/bioc-LATEST/ggtree/) [![Linux/Mac Travis Build Status](https://img.shields.io/travis/GuangchuangYu/ggtree/master.svg?label=Mac%20OSX%20%26%20Linux)](https://travis-ci.org/GuangchuangYu/ggtree) [![AppVeyor Build Status](https://img.shields.io/appveyor/ci/Guangchuangyu/ggtree/master.svg?label=Windows)](https://ci.appveyor.com/project/GuangchuangYu/ggtree)
12 12
 
... ...
@@ -27,56 +27,56 @@ Please cite the following article when using `ggtree`:
27 27
 
28 28
 **G Yu**, DK Smith, H Zhu, Y Guan, TTY Lam<sup>\*</sup>. ggtree: an R package for visualization and annotation of phylogenetic trees with their covariates and other associated data. ***Methods in Ecology and Evolution***. 2017, 8(1):28-36.
29 29
 
30
-[![](https://img.shields.io/badge/doi-10.1111/2041--210X.12628-green.svg?style=flat)](http://dx.doi.org/10.1111/2041-210X.12628) [![](https://img.shields.io/badge/Altmetric-347-green.svg?style=flat)](https://www.altmetric.com/details/10533079)
30
+[![](https://img.shields.io/badge/doi-10.1111/2041--210X.12628-green.svg?style=flat)](http://dx.doi.org/10.1111/2041-210X.12628) [![](https://img.shields.io/badge/Altmetric-345-green.svg?style=flat)](https://www.altmetric.com/details/10533079)
31 31
 
32 32
 ------------------------------------------------------------------------
33 33
 
34 34
 ### Citation
35 35
 
36
-[![citation](https://img.shields.io/badge/cited%20by-16-green.svg?style=flat)](https://scholar.google.com.hk/scholar?oi=bibs&hl=en&cites=7268358477862164627)
36
+[![citation](https://img.shields.io/badge/cited%20by-22-green.svg?style=flat)](https://scholar.google.com.hk/scholar?oi=bibs&hl=en&cites=7268358477862164627)
37 37
 
38 38
        +-+---------+---------+---------+---------+---------+---+
39
-    15 +                                                   *   +
39
+    20 +                                                   *   +
40 40
        |                                                       |
41 41
        |                                                       |
42
+    15 +                                                       +
42 43
        |                                                       |
43
-    10 +                                                       +
44 44
        |                                                       |
45
+    10 +                                                       +
45 46
        |                                                       |
46 47
        |                                                       |
47 48
      5 +                                                       +
48
-       |                                                       |
49 49
        |                                                       |
50 50
        | *                                                     |
51
-       +-+---------+---------+---------+---------+---------+---+
51
+     0 +-+---------+---------+---------+---------+---------+---+
52 52
        2016     2016.2    2016.4    2016.6    2016.8     2017   
53 53
 
54 54
 ### Download stats
55 55
 
56
-[![download](http://www.bioconductor.org/shields/downloads/ggtree.svg)](https://bioconductor.org/packages/stats/bioc/ggtree) [![](https://img.shields.io/badge/download-14583/total-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) [![](https://img.shields.io/badge/download-1385/month-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree)
56
+[![download](http://www.bioconductor.org/shields/downloads/ggtree.svg)](https://bioconductor.org/packages/stats/bioc/ggtree) [![](https://img.shields.io/badge/download-16674/total-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree) [![](https://img.shields.io/badge/download-1117/month-blue.svg?style=flat)](https://bioconductor.org/packages/stats/bioc/ggtree)
57 57
 
58
-         ++-------------------+------------------+-------------------+------------------+--------------+
59
-    3000 +                                                                                        *    +
58
+         ++------------------+-----------------+-----------------+-----------------+------------------++
59
+    3000 +                                                                                  *          +
60 60
          |                                                                                             |
61 61
          |                                                                                             |
62 62
     2500 +                                                                                             +
63 63
          |                                                                                             |
64 64
          |                                                                                             |
65 65
          |                                                                                             |
66
-    2000 +                                                                                             +
67
-         |                                                                           *     *  *        |
68
-         |                                                                    *   *                    |
66
+    2000 +                                                                                     *   *   +
67
+         |                                                                      *     *  *             |
68
+         |                                                                *  *                         |
69 69
     1500 +                                                                                             +
70 70
          |                                                                                             |
71
-         |                                                          *                                  |
72
-         |                                                 *            *  *            *              |
73
-    1000 +                                                    *  *                                     +
74
-         |                                    *     *                                                  |
75
-         |                                *      *     *                                               |
76
-         |                             *                                                               |
77
-     500 +                   *      *                                                                  +
78
-         |                *      *                                                                     |
79
-         |             *                                                                               |
80
-       0 +   *  *   *                                                                                  +
81
-         ++-------------------+------------------+-------------------+------------------+--------------+
82
-        2015               2015.5              2016               2016.5              2017
71
+         |                                                       *                                     |
72
+         |                                              *           *  *           *                   |
73
+    1000 +                                                 *  *                                        +
74
+         |                                  *     *                                                    |
75
+         |                               *     *     *                                                 |
76
+         |                            *                                                                |
77
+     500 +                  *      *                                                                   +
78
+         |               *     *                                                                       |
79
+         |            *                                                                                |
80
+       0 +   *  *  *                                                                                   +
81
+         ++------------------+-----------------+-----------------+-----------------+------------------++
82
+        2015              2015.5             2016             2016.5             2017            2017.5
... ...
@@ -6,7 +6,7 @@ author: "Guangchuang Yu and Tommy Tsan-Yuk Lam\\
6 6
 date: "`r Sys.Date()`"
7 7
 bibliography: ggtree.bib
8 8
 csl: nature.csl
9
-output: 
9
+output:
10 10
   prettydoc::html_pretty:
11 11
     toc: true
12 12
     theme: cayman
... ...
@@ -52,7 +52,7 @@ This project arose from our needs to annotate nucleotide substitutions in the ph
52 52
 
53 53
 Previously, phylogenetic trees were much smaller. Annotation of phylogenetic trees was not as necessary as nowadays much more data is becomming available. We want to associate our experimental data, for instance antigenic change, with the evolution relationship. Visualizing these associations in a phylogenetic tree can help us to identify evolution patterns. We believe we need a next generation tree viewer that should be programmable and extensible. It can view a phylogenetic tree easily as we did with classical software and support adding annotation data in a layer above the tree. This is the objective of developing the `ggtree`. Common tasks of annotating a phylogenetic tree should be easy and complicated tasks can be possible to achieve by adding multiple layers of annotation.
54 54
 
55
-The `ggtree` is designed by extending the `ggplot2`[@wickham_ggplot2_2009] package. It is based on the grammar of graphics and takes all the good parts of `ggplot2`. There are other R packages that implement tree viewer using `ggplot2`, including `OutbreakTools`, `phyloseq`[@mcmurdie_phyloseq_2013] and [ggphylo](https://github.com/gjuggler/ggphylo); they mostly create complex tree view functions for their specific needs. Internally, these packages interpret a phylogenetic as a collection of `lines`, which makes it hard to annotate diverse user input that are related to node (taxa). The `ggtree` is different to them by interpreting a tree as a collection of `taxa` and allowing general flexibilities of annotating phylogenetic tree with diverse types of user inputs. 
55
+The `ggtree` is designed by extending the `ggplot2`[@wickham_ggplot2_2009] package. It is based on the grammar of graphics and takes all the good parts of `ggplot2`. There are other R packages that implement tree viewer using `ggplot2`, including `OutbreakTools`, `phyloseq`[@mcmurdie_phyloseq_2013] and [ggphylo](https://github.com/gjuggler/ggphylo); they mostly create complex tree view functions for their specific needs. Internally, these packages interpret a phylogenetic as a collection of `lines`, which makes it hard to annotate diverse user input that are related to node (taxa). The `ggtree` is different to them by interpreting a tree as a collection of `taxa` and allowing general flexibilities of annotating phylogenetic tree with diverse types of user inputs.
56 56
 
57 57
 
58 58
 # Getting data into `R`
... ...
@@ -84,7 +84,7 @@ Most of the phylogenetic trees are scaled by evolutionary distance (substitution
84 84
 The `ggtree` package provides several layers to annotate a phylogenetic tree, including:
85 85
 
86 86
 + `geom_cladelabel` for labelling selected clades
87
-+ `geom_hilight` for highlighting selected clades 
87
++ `geom_hilight` for highlighting selected clades
88 88
 + `geom_range` to indicate uncertainty of branch lengths
89 89
 + `geom_strip` for adding strip/bar to label associated taxa (with optional label)
90 90
 + `geom_taxalink` for connecting related taxa
... ...
@@ -107,7 +107,7 @@ Visualizing an annotated phylogenetic tree with numerical matrix (e.g. genotype
107 107
 + [Tree Annotation](treeAnnotation.html)
108 108
 + [Advance Tree Annotation](advanceTreeAnnotation.html)
109 109
 + [ggtree utilities](ggtreeUtilities.html)
110
-
110
++ [Phylomoji](https://cran.r-project.org/web/packages/emojifont/vignettes/phylomoji.html)
111 111
 
112 112
 More documents can be found in <https://guangchuangyu.github.io/ggtree>.
113 113
 
... ...
@@ -115,7 +115,7 @@ More documents can be found in <https://guangchuangyu.github.io/ggtree>.
115 115
 
116 116
  - For bugs or feature request, please post to [github issue](https://github.com/GuangchuangYu/ggtree/issues).
117 117
  - For user questions, please post to [google group](https://groups.google.com/forum/#!forum/bioc-ggtree) or post to [Bioconductor support site](https://support.bioconductor.org/) or [Biostars](https://www.biostars.org/). We are following every post tagged with **ggtree**.
118
-  
118
+
119 119
 
120 120
 # Session info
121 121