Browse code

fortify.phylo4d via converting phylo4d to treedata object

guangchuang yu authored on 28/12/2016 13:49:47
Showing 5 changed files

... ...
@@ -184,6 +184,7 @@ importFrom(magrittr,equals)
184 184
 importFrom(methods,is)
185 185
 importFrom(methods,missingArg)
186 186
 importFrom(tidyr,gather)
187
+importFrom(treeio,as.phylo)
187 188
 importFrom(treeio,as.treedata)
188 189
 importFrom(treeio,get.placements)
189 190
 importFrom(treeio,groupClade)
... ...
@@ -1,5 +1,6 @@
1 1
 CHANGES IN VERSION 1.7.5
2 2
 ------------------------
3
+ o fortify.phylo4d via converting phylo4d to treedata object <2016-12-28, Wed>
3 4
  o improve viewClade function, use coord_cartesian instead of xlim <2016-12-28, Wed>
4 5
  o remove codes that move to treeio and now ggtree depends treeio <2016-12-20, Tue>
5 6
 
... ...
@@ -389,10 +389,11 @@ scaleY <- function(phylo, df, yscale, layout, ...) {
389 389
 
390 390
 
391 391
 ##' @method fortify phylo4
392
+##' @importFrom treeio as.phylo
392 393
 ##' @export
393 394
 fortify.phylo4 <- function(model, data, layout="rectangular", yscale="none",
394 395
                            ladderize=TRUE, right=FALSE, mrsd=NULL, ...) {
395
-    phylo <- as.phylo.phylo4(model)
396
+    phylo <- as.phylo(model)
396 397
     df <- fortify.phylo(phylo, data,
397 398
                         layout, ladderize, right, mrsd=mrsd, ...)
398 399
     scaleY(phylo, df, yscale, layout, ...)
... ...
@@ -403,36 +404,17 @@ fortify.phylo4 <- function(model, data, layout="rectangular", yscale="none",
403 404
 fortify.phylo4d <- function(model, data, layout="rectangular", yscale="none",
404 405
                             ladderize=TRUE, right=FALSE, branch.length="branch.length",
405 406
                             mrsd=NULL, ...) {
406
-    model <- set_branch_length(model, branch.length)
407
-    phylo <- as.phylo.phylo4(model)
408
-    res <- fortify(phylo, data, layout, branch.length=branch.length,
409
-                   ladderize, right, mrsd, ...)
410
-    tdata <- model@data[match(res$node, rownames(model@data)), , drop=FALSE]
411
-    df <- cbind(res, tdata)
412
-    scaleY(as.phylo.phylo4(model), df, yscale, layout, ...)
407
+    ## model <- set_branch_length(model, branch.length)
408
+    ## phylo <- as.phylo.phylo4(model)
409
+    ## res <- fortify(phylo, data, layout, branch.length=branch.length,
410
+    ##                ladderize, right, mrsd, ...)
411
+    ## tdata <- model@data[match(res$node, rownames(model@data)), , drop=FALSE]
412
+    ## df <- cbind(res, tdata)
413
+    ## scaleY(as.phylo.phylo4(model), df, yscale, layout, ...)
414
+    fortify(as.treedata(model), data, layout, yscale, ladderize, right, branch.length, mrsd, ...)
413 415
 }
414 416
 
415
-as.phylo.phylo4 <- function(phylo4) {
416
-    edge <- phylo4@edge
417
-    edge <- edge[edge[,1] != 0, ]
418
-    edge.length <- phylo4@edge.length
419
-    edge.length <- edge.length[!is.na(edge.length)]
420
-    tip.id <- sort(setdiff(edge[,2], edge[,1]))
421
-    tip.label <- phylo4@label[tip.id]
422
-    phylo <- list(edge = edge,
423
-                  edge.length = edge.length,
424
-                  tip.label = tip.label)
425
-
426
-    node.id <- sort(unique(edge[,1]))
427
-    node.id <- node.id[node.id != 0]
428
-    node.label <- phylo4@label[node.id]
429
-    if (!all(is.na(node.label))) {
430
-        phylo$node.label <- node.label
431
-    }
432
-    phylo$Nnode <- length(node.id)
433
-    class(phylo) <- "phylo"
434
-    return(phylo)
435
-}
417
+
436 418
 
437 419
 ##' fortify a phylo to data.frame
438 420
 ##'
... ...
@@ -1,10 +1,12 @@
1 1
 ##' @importFrom ggplot2 fortify
2 2
 ##' @method fortify treedata
3 3
 ##' @export
4
-fortify.treedata <- function(model, data, layout="rectangular", branch.length ="branch.length",
5
-                             ladderize=TRUE, right=FALSE, mrsd=NULL, ...) {
4
+fortify.treedata <- function(model, data, layout="rectangular", yscale="none",
5
+                             ladderize=TRUE, right=FALSE, branch.length ="branch.length",
6
+                             mrsd=NULL, ...) {
7
+
6 8
     model <- set_branch_length(model, branch.length)
7
-    
9
+
8 10
     x <- reorder.phylo(get.tree(model), "postorder")
9 11
     if (is.null(x$edge.length) || branch.length == "none") {
10 12
         xpos <- getXcoord_no_length(x)
... ...
@@ -27,7 +29,7 @@ fortify.treedata <- function(model, data, layout="rectangular", branch.length ="
27 29
 
28 30
     ## ## angle for all layout, if 'rectangular', user use coord_polar, can still use angle
29 31
     res <- calculate_angle(res)
30
-    res
32
+    scaleY(as.phylo(model), res, yscale, layout, ...)
31 33
 }
32 34
 
33 35
 ##' @method as.data.frame treedata
... ...
@@ -824,11 +826,7 @@ set_branch_length <- function(tree_object, branch.length) {
824 826
     if (branch.length == "branch.length") {
825 827
         return(tree_object)
826 828
     } else if (branch.length == "none") {
827
-        if (is(tree_object, "phylo4d")) {
828
-            tree_object@edge.length <- NULL
829
-        } else { 
830
-            tree_object@phylo$edge.length <- NULL
831
-        }
829
+        tree_object@phylo$edge.length <- NULL
832 830
         return(tree_object)
833 831
     }
834 832
 
... ...
@@ -836,11 +834,7 @@ set_branch_length <- function(tree_object, branch.length) {
836 834
         return(tree_object)
837 835
     }
838 836
 
839
-    if (is(tree_object, "phylo4d")) {
840
-        phylo <- as.phylo.phylo4(tree_object)
841
-        d <- tree_object@data
842
-        tree_anno <- data.frame(node=rownames(d), d)
843
-    } else if (is(tree_object, "codeml")) {
837
+    if (is(tree_object, "codeml")) {
844 838
         tree_anno <- tree_object@mlc@dNdS
845 839
     } else if (is(tree_object, "codeml_mlc")) {
846 840
         tree_anno <- tree_object@dNdS
... ...
@@ -850,10 +844,8 @@ set_branch_length <- function(tree_object, branch.length) {
850 844
         tree_anno <- get_tree_data(tree_object)
851 845
     }
852 846
 
853
-    if (!is(tree_object, "phylo4d")) {
854
-        phylo <- get.tree(tree_object)
855
-    }
856
-    
847
+    phylo <- get.tree(tree_object)
848
+
857 849
     cn <- colnames(tree_anno)
858 850
     cn <- cn[!cn %in% c('node', 'parent')]
859 851
 
... ...
@@ -876,11 +868,7 @@ set_branch_length <- function(tree_object, branch.length) {
876 868
 
877 869
     phylo$edge.length <- len
878 870
 
879
-    if (is(tree_object, "phylo4d")) {
880
-        tree_object@edge.length <- phylo$edge.length
881
-    } else {
882
-        tree_object@phylo <- phylo
883
-    }
871
+    tree_object@phylo <- phylo
884 872
     return(tree_object)
885 873
 }
886 874
 
... ...
@@ -12,163 +12,3 @@ get.tree <- treeio::get.tree
12 12
 drop.tip <- treeio::drop.tip
13 13
 get.fields <- treeio::get.fields
14 14
 
15
-
16
-## filename <- function(file) {
17
-##     ## textConnection(text_string) will work just like a file
18
-##     ## in this case, just set the filename as ""
19
-##     file_name <- ""
20
-##     if (is.character(file)) {
21
-##         file_name <- file
22
-##     }
23
-##     return(file_name)
24
-## }
25
-
26
-## ##' read nhx tree file
27
-## ##'
28
-## ##'
29
-## ##' @title read.nhx
30
-## ##' @param file nhx file
31
-## ##' @return nhx object
32
-## ##' @export
33
-## ##' @author Guangchuang Yu \url{https://guangchuangyu.github.io}
34
-## read.nhx <- function(file) {
35
-##     treetext <- suppressWarnings(readLines(file))
36
-##     treetext <- treetext[treetext != ""]
37
-##     treetext <- treetext[treetext != " "]
38
-
39
-##     if (length(treetext) > 1) {
40
-##         treetext <- paste0(treetext, collapse = '')
41
-##     }
42
-##     treetext %<>% gsub(" ", "",. )
43
-
44
-##     phylo <- read.tree(text=treetext)
45
-##     nnode <- phylo$Nnode + Ntip(phylo)
46
-##     nlab <- paste("X", 1:nnode, sep="")
47
-##     tree2 <- treetext
48
-
49
-##     for (i in 1:nnode) {
50
-##         tree2 <- sub("(\\w+)?(:?\\d*\\.?\\d*[Ee]?[\\+\\-]?\\d*)?\\[&&NHX.*?\\]", paste0("\\", nlab[i], "\\2"), tree2)
51
-##     }
52
-
53
-##     phylo2 <- read.tree(text = tree2)
54
-##     treeinfo <- fortify(phylo2)
55
-##     node <- treeinfo$node[match(nlab, sub(".+(X\\d+)$","\\1",treeinfo$label))] # as.character
56
-
57
-##     nhx.matches <- gregexpr("(\\w+)?(:?\\d*\\.?\\d*[Ee]?[\\+\\-]?\\d*)?\\[&&NHX.*?\\]", treetext)
58
-##     matches <- nhx.matches[[1]]
59
-##     match.pos <- as.numeric(matches)
60
-##     if (length(match.pos) == 1 && (match.pos == -1)) {
61
-##         nhx_tags <- data.frame(node = as.numeric(treeinfo$node))
62
-##     } else {
63
-##         match.len <- attr(matches, 'match.length')
64
-
65
-##         nhx_str <- substring(treetext, match.pos, match.pos+match.len-1)
66
-
67
-##         ## nhx_features <- gsub("^(\\w+)?:?\\d*\\.?\\d*[Ee]?[\\+\\-]?\\d*", "", nhx_str) %>%
68
-##         nhx_features <- gsub("^[^\\[]*", "", nhx_str) %>%
69
-##             gsub("\\[&&NHX:", "", .) %>%
70
-##             gsub("\\]", "", .)
71
-
72
-##         nhx_tags <- get_nhx_feature(nhx_features)
73
-##         fields <- names(nhx_tags)
74
-##         for (i in ncol(nhx_tags)) {
75
-##             if(any(grepl("\\D+", nhx_tags[,i])) == FALSE) {
76
-##                 ## should be numerical varialbe
77
-##                 nhx_tags[,i] <- as.numeric(nhx_tags[,i])
78
-##             }
79
-##         }
80
-##         nhx_tags$node <- as.numeric(node)
81
-##     }
82
-
83
-##     # Order rows by row number to facilitate downstream manipulations
84
-##     nhx_tags=nhx_tags[order(nhx_tags$node),]
85
-
86
-##     new("nhx",
87
-##         file = filename(file),
88
-##         fields = fields,
89
-##         phylo = phylo,
90
-##         nhx_tags = nhx_tags
91
-##         )
92
-## }
93
-
94
-
95
-## get_nhx_feature <- function(nhx_features) {
96
-##     nameSET <- strsplit(nhx_features, split=":") %>% unlist %>%
97
-##         gsub("=.*", "", .) %>% unique
98
-##     lapply(nhx_features, get_nhx_feature_internal, nameSET=nameSET) %>%
99
-##         do.call(rbind, .) %>% as.data.frame(., stringsAsFactors = FALSE)
100
-## }
101
-
102
-## get_nhx_feature_internal <- function(feature, nameSET) {
103
-##     x <- strsplit(feature, ":") %>% unlist
104
-##     name <- gsub("=.*", "", x)
105
-##     val <- gsub(".*=", "", x)
106
-
107
-##     names(val) <- name
108
-##     y <- character(length(nameSET))
109
-##     for (i in seq_along(nameSET)) {
110
-##         if (nameSET[i] %in% name) {
111
-##             y[i] <- val[nameSET[i]]
112
-##         } else {
113
-##             y[i] <- NA
114
-##         }
115
-##     }
116
-##     names(y) <- nameSET
117
-##     return(y)
118
-## }
119
-
120
-
121
-
122
-
123
-
124
-## ##' @rdname get.fields-methods
125
-## ##' @exportMethod get.fields
126
-## setMethod("get.fields", signature(object="nhx"),
127
-##           function(object, ...) {
128
-##               get.fields.tree(object)
129
-##           }
130
-##           )
131
-
132
-
133
-## Ntip <- function(tree) {
134
-##     phylo <- get.tree(tree)
135
-##     length(phylo$tip.label)
136
-## }
137
-
138
-## Nnode <- function(tree, internal.only=TRUE) {
139
-##     phylo <- get.tree(tree)
140
-##     if (internal.only)
141
-##         return(phylo$Nnode)
142
-
143
-##     Ntip(phylo) + phylo$Nnode
144
-## }
145
-
146
-
147
-## has.extraInfo <- function(object) {
148
-##     if (!is.tree(object)) {
149
-##         return(FALSE)
150
-##     }
151
-
152
-##     if (! .hasSlot(object, "extraInfo")) {
153
-##         return(FALSE)
154
-##     }
155
-
156
-##     extraInfo <- object@extraInfo
157
-
158
-##     if (nrow(extraInfo) > 0) {
159
-##         return(TRUE)
160
-##     }
161
-
162
-##     return(FALSE)
163
-## }
164
-
165
-## ##' @importFrom methods .hasSlot is missingArg new slot slot<-
166
-## has.slot <- function(object, slotName) {
167
-##     if (!isS4(object)) {
168
-##         return(FALSE)
169
-##     }
170
-##     .hasSlot(object, slotName)
171
-##     ## slot <- tryCatch(slot(object, slotName), error=function(e) NULL)
172
-##     ## ! is.null(slot)
173
-## }
174
-