Browse code

clean up code

guangchuang yu authored on 14/12/2017 08:47:21
Showing70 changed files

... ...
@@ -13,4 +13,4 @@ __init__.pyc
13 13
 .web_cache
14 14
 ggtree.Rproj
15 15
 .Rproj.user
16
-ggtree
17 16
\ No newline at end of file
17
+ggtree*.html
... ...
@@ -13,12 +13,11 @@ Description: 'ggtree' extends the 'ggplot2' plotting system which implemented
13 13
     the grammar of graphics. 'ggtree' is designed for visualization and annotation
14 14
     of phylogenetic trees with their covariates and other associated data.
15 15
 Depends:
16
-    R (>= 3.4.0),
17
-    ggplot2 (>= 2.2.0),
18
-    treeio (>= 1.3.3)
16
+    R (>= 3.4.0)
19 17
 Imports:
20 18
     ape,
21 19
     dplyr,
20
+    ggplot2 (>= 2.2.0),
22 21
     grDevices,
23 22
     grid,
24 23
     magrittr,
... ...
@@ -28,10 +27,12 @@ Imports:
28 27
     tibble,
29 28
     tidyr,
30 29
     tidytree,
30
+    treeio (>= 1.3.3),
31 31
     utils
32 32
 Suggests:
33 33
     Biostrings,
34 34
     colorspace,
35
+    cowplot,
35 36
     emojifont,
36 37
     ggimage,
37 38
     knitr,
... ...
@@ -1,7 +1,5 @@
1 1
 # Generated by roxygen2: do not edit by hand
2 2
 
3
-S3method(as.binary,phylo)
4
-S3method(as.data.frame,phylo)
5 3
 S3method(fortify,multiPhylo)
6 4
 S3method(fortify,obkData)
7 5
 S3method(fortify,phylo)
... ...
@@ -12,7 +10,6 @@ S3method(fortify,treedata)
12 10
 S3method(groupClade,ggtree)
13 11
 S3method(groupOTU,ggtree)
14 12
 S3method(identify,gg)
15
-S3method(print,beastList)
16 13
 export("%+>%")
17 14
 export("%<%")
18 15
 export("%<+%")
... ...
@@ -24,9 +21,8 @@ export(MRCA)
24 21
 export(StatBalance)
25 22
 export(StatHilight)
26 23
 export(add_colorbar)
24
+export(aes)
27 25
 export(annotation_image)
28
-export(apeBoot)
29
-export(as.binary)
30 26
 export(as.polytomy)
31 27
 export(collapse)
32 28
 export(decimal2Date)
... ...
@@ -39,16 +35,19 @@ export(geom_cladelabel)
39 35
 export(geom_cladelabel2)
40 36
 export(geom_hilight)
41 37
 export(geom_hilight_encircle)
38
+export(geom_label)
42 39
 export(geom_label2)
43 40
 export(geom_motif)
44 41
 export(geom_nodelab)
45 42
 export(geom_nodepoint)
43
+export(geom_point)
46 44
 export(geom_point2)
47 45
 export(geom_range)
48 46
 export(geom_rootpoint)
49 47
 export(geom_segment2)
50 48
 export(geom_strip)
51 49
 export(geom_taxalink)
50
+export(geom_text)
52 51
 export(geom_text2)
53 52
 export(geom_tiplab)
54 53
 export(geom_tiplab2)
... ...
@@ -62,8 +61,11 @@ export(get_balance_position)
62 61
 export(get_clade_position)
63 62
 export(get_heatmap_column_position)
64 63
 export(get_taxa_name)
64
+export(ggsave)
65 65
 export(ggtree)
66 66
 export(gheatmap)
67
+export(groupClade)
68
+export(groupOTU)
67 69
 export(gzoom)
68 70
 export(inset)
69 71
 export(msaplot)
... ...
@@ -74,11 +76,13 @@ export(nodepie)
74 76
 export(open_tree)
75 77
 export(phylopic)
76 78
 export(range_format)
79
+export(read.tree)
77 80
 export(reroot)
78 81
 export(rescale_tree)
79 82
 export(revts)
80 83
 export(rotate)
81 84
 export(rotate_tree)
85
+export(rtree)
82 86
 export(scaleClade)
83 87
 export(scale_color)
84 88
 export(scale_x_ggtree)
... ...
@@ -86,10 +90,12 @@ export(set_hilight_legend)
86 90
 export(stat_balance)
87 91
 export(stat_hilight)
88 92
 export(subview)
93
+export(theme)
89 94
 export(theme_inset)
90 95
 export(theme_tree)
91 96
 export(theme_tree2)
92 97
 export(viewClade)
98
+export(xlim)
93 99
 export(xlim_expand)
94 100
 export(xlim_tree)
95 101
 exportMethods(gzoom)
... ...
@@ -98,12 +104,12 @@ exportMethods(scale_color)
98 104
 importFrom(ape,di2multi)
99 105
 importFrom(ape,extract.clade)
100 106
 importFrom(ape,getMRCA)
101
-importFrom(ape,is.binary.tree)
102 107
 importFrom(ape,ladderize)
103 108
 importFrom(ape,read.tree)
104 109
 importFrom(ape,reorder.phylo)
105
-importFrom(ape,write.tree)
110
+importFrom(ape,rtree)
106 111
 importFrom(dplyr,full_join)
112
+importFrom(dplyr,mutate_)
107 113
 importFrom(ggplot2,Geom)
108 114
 importFrom(ggplot2,GeomCurve)
109 115
 importFrom(ggplot2,GeomLabel)
... ...
@@ -130,6 +136,8 @@ importFrom(ggplot2,facet_grid)
130 136
 importFrom(ggplot2,fortify)
131 137
 importFrom(ggplot2,geom_bar)
132 138
 importFrom(ggplot2,geom_blank)
139
+importFrom(ggplot2,geom_label)
140
+importFrom(ggplot2,geom_point)
133 141
 importFrom(ggplot2,geom_rect)
134 142
 importFrom(ggplot2,geom_segment)
135 143
 importFrom(ggplot2,geom_text)
... ...
@@ -138,6 +146,7 @@ importFrom(ggplot2,ggplot)
138 146
 importFrom(ggplot2,ggplotGrob)
139 147
 importFrom(ggplot2,ggplot_build)
140 148
 importFrom(ggplot2,ggproto)
149
+importFrom(ggplot2,ggsave)
141 150
 importFrom(ggplot2,guide_legend)
142 151
 importFrom(ggplot2,guides)
143 152
 importFrom(ggplot2,last_plot)
... ...
@@ -174,11 +183,11 @@ importFrom(grid,unit)
174 183
 importFrom(grid,viewport)
175 184
 importFrom(magrittr,"%<>%")
176 185
 importFrom(magrittr,"%>%")
177
-importFrom(magrittr,add)
178 186
 importFrom(magrittr,equals)
179 187
 importFrom(methods,is)
180 188
 importFrom(methods,missingArg)
181 189
 importFrom(methods,setGeneric)
190
+importFrom(methods,setOldClass)
182 191
 importFrom(rvcheck,get_fun_from_pkg)
183 192
 importFrom(scales,alpha)
184 193
 importFrom(tibble,data_frame)
... ...
@@ -1,5 +1,6 @@
1 1
 CHANGES IN VERSION 1.11.3
2 2
 ------------------------
3
+ o clean up code <2017-12-13, Thu>
3 4
  o remove paml_rst, codeml_mlc, codeml and jplace fortify methods according to the change of treeio (v = 1.3.3) <2017-12-07, Thu>
4 5
 
5 6
 CHANGES IN VERSION 1.11.2
... ...
@@ -1,12 +1,5 @@
1
-##' @title as.binary
2
-##' @param tree phylo, object
3
-##' @param ... additional parameter
4
-##' @rdname as.binary
5
-##' @export
6
-as.binary <- function(tree, ...) {
7
-    UseMethod("as.binary")
8
-}
9
-
1
+##' @importFrom methods setOldClass
2
+setOldClass("ggtree")
10 3
 
11 4
 ##' @docType methods
12 5
 ##' @name reroot
... ...
@@ -26,8 +19,7 @@ setGeneric("reroot", function(object, node, ...) standardGeneric("reroot"))
26 19
 ##' @name scale_color
27 20
 ##' @rdname scale_color-methods
28 21
 ##' @title scale_color method
29
-##' @param object supported objects, including phylo, paml_rst,
30
-##'               codeml_mlc, codeml, jplace, beast, hyphy
22
+##' @param object \code{treedata} object
31 23
 ##' @param by one of numerical attributes
32 24
 ##' @param ... additional parameter
33 25
 ##' @return color vector
... ...
@@ -8,7 +8,7 @@ scaleX_by_time <- function(df, as.Date=FALSE) {
8 8
     scaleX_by_time_from_mrsd(df, decimal2Date(time[latest]), as.Date)
9 9
 }
10 10
 
11
-
11
+##' @importFrom magrittr %<>%
12 12
 scaleX_by_time_from_mrsd <- function(df, mrsd, as.Date) {
13 13
     mrsd %<>% as.Date
14 14
     date <- Date2decimal(mrsd)
15 15
deleted file mode 100644
... ...
@@ -1,88 +0,0 @@
1
-##' neighbor-joining method
2
-##'
3
-##' 
4
-##' @title NJ
5
-##' @param X distance matrix
6
-##' @return phylo object
7
-##' @author ygc
8
-##' @examples
9
-##' \dontrun{
10
-##' X <- matrix(c(0,5,4,7,6,8,
11
-##'		5,0,7,10,9,11,
12
-##'		4,7,0,7,6,8,
13
-##'		7,10,7,0,5,9,
14
-##'		6,9,6,5,0,8,
15
-##'		8,11,8,9,8,0), ncol=6)
16
-##' rownames(X) <- colnames(X) <- LETTERS[1:6]
17
-##' tree <- NJ(X)
18
-##' print(tree)
19
-##' }
20
-NJ <- function(X) {
21
-    labels <- colnames(X)
22
-    N <- ncol(X)
23
-    otu_labs <- 1:N
24
-    
25
-    dm <- as.matrix(X)
26
-    S <- colSums(dm)
27
-
28
-    ## edge list of node 1 and node 2 
29
-    edge1 <- edge2 <- numeric(2*N-3)
30
-    edge_length <- numeric(2*N-3)
31
-    k <- 1
32
-    cur_node <- 2*N-2
33
-    while (N > 3) {
34
-        ds <- 1e50
35
-        for (i in 1:(N-1)) {
36
-            for (j in (i+1):N) {
37
-                A <- N * dm[i,j] - S[i] - S[j]
38
-                if (A < ds) {
39
-                    OUT1 <- i;
40
-                    OUT2 <- j;
41
-                    ds <- A
42
-                }
43
-            }
44
-        }
45
-        edge2[k] <- otu_labs[OUT1]
46
-        edge2[k+1] <- otu_labs[OUT2]
47
-        edge1[k] <- edge1[k+1] <- cur_node
48
-        dij <- dm[OUT1, OUT2]
49
-        B <- (S[OUT1]-S[OUT2]) / (N-2)
50
-        edge_length[k] <- (dij + B)/2
51
-        edge_length[k+1] <- (dij - B)/2
52
-        
53
-        ij <- 1
54
-        new_dist <- numeric(N-2)
55
-        ## d_kn <- 1/2 * (d_ik + d_jk - d_ij)
56
-        for (i in 1:N) {
57
-            if (i == OUT1 || i == OUT2) next
58
-            x <- dm[i, OUT1]
59
-            y <- dm[i, OUT2]
60
-            new_dist[ij] <- 1/2 * (x+y-dij)
61
-            ij <- ij + 1
62
-        }
63
-        ## update data
64
-        dm <- dm[-c(OUT1, OUT2), -c(OUT1, OUT2)]
65
-        dm <- rbind(dm, new_dist)
66
-        dm <- cbind(dm, c(new_dist, 0))
67
-        otu_labs <- otu_labs[-c(OUT1, OUT2)]
68
-        otu_labs <- c(otu_labs, cur_node)
69
-        rownames(dm) <- otu_labs
70
-        colnames(dm) <- otu_labs
71
-        S <- colSums(dm)
72
-        cur_node <- cur_node-1
73
-        k <- k+2
74
-        N <- N - 1
75
-    }
76
-
77
-    n <- length(edge1)
78
-    edge1[(n-2):n] <- cur_node
79
-    edge2[(n-2):n] <- otu_labs
80
-    edge_length[n-2] <- (dm[1,2]+dm[1,3]-dm[2,3])/2
81
-    edge_length[n-1] <- (dm[2,1]+dm[2,3]-dm[1,3])/2
82
-    edge_length[n] <- (dm[3,1]+dm[3,2]-dm[1,2])/2
83
-    obj <- list(edge=cbind(as.numeric(edge1), as.numeric(edge2)),
84
-                edge.length=edge_length,
85
-                tip.label=labels, Nnode=length(labels)-2)
86
-    class(obj) <- "phylo"
87
-    return(obj)
88
-}
89 0
deleted file mode 100644
... ...
@@ -1,62 +0,0 @@
1
-## ##' read baseml output
2
-## ##'
3
-## ##' 
4
-## ##' @title read.codeml 
5
-## ##' @param rstfile rst file
6
-## ##' @param mlcfile mlc file
7
-## ##' @return A \code{codeml} object
8
-## ##' @export
9
-## ##' @author ygc
10
-## ##' @examples
11
-## ##' rstfile <- system.file("extdata/PAML_Codeml", "rst", package="ggtree")
12
-## ##' mlcfile <- system.file("extdata/PAML_Codeml", "mlc", package="ggtree")
13
-## ##' read.codeml(rstfile, mlcfile) 
14
-## read.codeml <- function(rstfile, mlcfile) {
15
-##     rst <- read.paml_rst(rstfile)
16
-##     mlc <- read.codeml_mlc(mlcfile)
17
-##     ## rst@tip_seq <- mlc@tip_seq
18
-##     new("codeml",
19
-##         rst = set.paml_rst_(rst),
20
-##         mlc = mlc
21
-##         )
22
-## }
23
-
24
-
25
-
26
-
27
-## ##' @rdname scale_color-methods
28
-## ##' @exportMethod scale_color
29
-## setMethod("scale_color", signature(object="codeml"),
30
-##           function(object, by, ...) {
31
-##               scale_color_(object, by, ...)
32
-##           })
33
-
34
-
35
-
36
-
37
-## ##' @rdname get.tipseq-methods
38
-## ##' @exportMethod get.tipseq
39
-## setMethod("get.tipseq", signature(object = "codeml"),
40
-##           function(object, ...) {
41
-##               return(object@rst@tip_seq)
42
-##           })
43
-
44
-
45
-## ##' @rdname get.subs-methods
46
-## ##' @exportMethod get.subs
47
-## setMethod("get.subs", signature(object = "codeml"),
48
-##           function(object, type, ...) {
49
-##               get.subs(object@rst, type, ...)
50
-##           }
51
-##           )
52
-
53
-
54
-## ##' @rdname get.fields-methods
55
-## ##' @exportMethod get.fields
56
-## setMethod("get.fields", signature(object="codeml"),
57
-##           function(object, ...) {
58
-##               get.fields.tree(object)
59
-##           }
60
-##           )
61
-
62
-                        
63 0
deleted file mode 100644
... ...
@@ -1,85 +0,0 @@
1
-## ##' read mlc file of codeml output
2
-## ##'
3
-## ##' 
4
-## ##' @title read.codeml_mlc 
5
-## ##' @param mlcfile mlc file
6
-## ##' @return A \code{codeml_mlc} object
7
-## ##' @export
8
-## ##' @author ygc
9
-## ##' @examples
10
-## ##' mlcfile <- system.file("extdata/PAML_Codeml", "mlc", package="ggtree")
11
-## ##' read.codeml_mlc(mlcfile)
12
-## read.codeml_mlc <- function(mlcfile) {
13
-##     ## tip_seq <- read.tip_seq_mlc(mlcfile)
14
-##     dNdS <- read.dnds_mlc(mlcfile)
15
-    
16
-##     new("codeml_mlc",
17
-##         fields   = colnames(dNdS)[-c(1,2)],
18
-##         treetext = read.treetext_paml_mlc(mlcfile),
19
-##         phylo    = read.phylo_paml_mlc(mlcfile),
20
-##         dNdS     = dNdS,
21
-##         ## seq_type = get_seqtype(tip_seq),
22
-##         ## tip_seq  = tip_seq,
23
-##         mlcfile  = filename(mlcfile))
24
-## }
25
-
26
-
27
-## ##' @rdname gzoom-methods
28
-## ##' @exportMethod gzoom
29
-## setMethod("gzoom", signature(object="codeml_mlc"),
30
-##           function(object, focus, subtree=FALSE, widths=c(.3, .7)) {
31
-##               gzoom.phylo(get.tree(object), focus, subtree, widths)
32
-##           })
33
-
34
-
35
-
36
-## ##' @rdname groupClade-methods
37
-## ##' @exportMethod groupClade
38
-## setMethod("groupClade", signature(object="codeml_mlc"),
39
-##           function(object, node, group_name="group") {
40
-##               groupClade_(object, node, group_name)
41
-##           }
42
-##           )
43
-
44
-
45
-## ##' @rdname scale_color-methods
46
-## ##' @exportMethod scale_color
47
-## setMethod("scale_color", signature(object="codeml_mlc"),
48
-##           function(object, by, ...) {
49
-##               scale_color_(object, by, ...)
50
-##           })
51
-
52
-
53
-
54
-## ##' @rdname get.fields-methods
55
-## ##' @exportMethod get.fields
56
-## setMethod("get.fields", signature(object = "codeml_mlc"),
57
-##           function(object) {
58
-##               get.fields.tree(object)
59
-##           })
60
-
61
-
62
-
63
-## plot.codeml_mlc_<- function(p, position, annotation=NULL,
64
-##                             annotation.size, annotation.color){
65
-
66
-##     if (!is.null(annotation) && !is.na(annotation)) {
67
-##         p <- p + geom_text(aes_string(x=position,
68
-##                                       label = annotation),
69
-##                            size=annotation.size, vjust=-.5,
70
-##                            color = annotation.color)
71
-##     }
72
-##     p + theme_tree2()
73
-## }
74
-
75
-    
76
-## ##' @rdname get.tree-methods
77
-## ##' @exportMethod get.tree
78
-## setMethod("get.tree", signature(object = "codeml_mlc"),
79
-##           function(object, ...) {
80
-##               object@phylo
81
-##           }
82
-##           )
83
-
84
-
85
-
... ...
@@ -1,4 +1,3 @@
1
-
2 1
 ##' annotation taxa with images
3 2
 ##'
4 3
 ##'
... ...
@@ -63,3 +62,4 @@ phylopic <- function(tree_view, phylopic_id,
63 62
 subview <- function(mainview, subview, x, y, width=.1, height=.1) {
64 63
     stop("The subview function was deprecated, please use ggimage::geom_subview() instead.")
65 64
 }
65
+
66 66
new file mode 100644
... ...
@@ -0,0 +1,218 @@
1
+##' @importFrom tidytree get_tree_data
2
+set_branch_length <- function(tree_object, branch.length) {
3
+    if (branch.length == "branch.length") {
4
+        return(tree_object)
5
+    } else if (branch.length == "none") {
6
+        tree_object@phylo$edge.length <- NULL
7
+        return(tree_object)
8
+    }
9
+
10
+    if (is(tree_object, "phylo")) {
11
+        return(tree_object)
12
+    }
13
+
14
+    tree_anno <- get_tree_data(tree_object)
15
+    tree_anno$node <- as.integer(tree_anno$node)
16
+
17
+    phylo <- as.phylo(tree_object)
18
+
19
+    cn <- colnames(tree_anno)
20
+    cn <- cn[!cn %in% c('node', 'parent')]
21
+
22
+    length <- match.arg(branch.length, cn)
23
+
24
+    if (all(is.na(as.numeric(tree_anno[[length]])))) {
25
+        stop("branch.length should be numerical attributes...")
26
+    }
27
+
28
+    edge <- as_data_frame(phylo$edge)
29
+    colnames(edge) <- c("parent", "node")
30
+
31
+    dd <- full_join(edge, tree_anno, by = "node")
32
+
33
+    dd <- dd[match(edge[['node']], dd[['node']]),]
34
+    len <- unlist(dd[[length]])
35
+    len <- as.numeric(len)
36
+    len[is.na(len)] <- 0
37
+
38
+    phylo$edge.length <- len
39
+
40
+    tree_object@phylo <- phylo
41
+    return(tree_object)
42
+}
43
+
44
+
45
+calculate_angle <- function(data) {
46
+    data$angle <- 360/(diff(range(data$y)) + 1) * data$y
47
+    return(data)
48
+}
49
+
50
+
51
+
52
+scaleY <- function(phylo, df, yscale, layout, ...) {
53
+    if (yscale == "none") {
54
+        return(df)
55
+    }
56
+    if (! yscale %in% colnames(df)) {
57
+        warning("yscale is not available...\n")
58
+        return(df)
59
+    }
60
+    if (is.numeric(df[[yscale]])) {
61
+        y <- getYcoord_scale_numeric(phylo, df, yscale, ...)
62
+        ## if (order.y) {
63
+        ##     y <- getYcoord_scale2(phylo, df, yscale)
64
+        ## } else {
65
+        ##     y <- getYcoord_scale(phylo, df, yscale)
66
+        ## }
67
+    } else {
68
+        y <- getYcoord_scale_category(phylo, df, yscale, ...)
69
+    }
70
+
71
+    df[, "y"] <- y
72
+
73
+    return(df)
74
+}
75
+
76
+
77
+##
78
+##
79
+## old version of fortify.phylo
80
+## now use utilities from tidytree
81
+##
82
+##
83
+## ##' fortify a phylo to data.frame
84
+## ##'
85
+## ##'
86
+## ##' @rdname fortify
87
+## ##' @title fortify
88
+## ##' @param model phylo object
89
+## ##' @param data not use here
90
+## ##' @param layout layout
91
+## ##' @param ladderize ladderize, logical
92
+## ##' @param right logical
93
+## ##' @param mrsd most recent sampling date
94
+## ##' @param as.Date logical whether using Date class in time tree
95
+## ##' @param ... additional parameter
96
+## ##' @return data.frame
97
+## ##' @importFrom ape ladderize
98
+## ##' @importFrom ape reorder.phylo
99
+## ##' @importFrom ggplot2 fortify
100
+## ##' @method fortify phylo
101
+## ##' @export
102
+## ##' @author Yu Guangchuang
103
+## fortify.phylo <- function(model, data,
104
+##                           layout    = "rectangular",
105
+##                           ladderize = TRUE,
106
+##                           right     = FALSE,
107
+##                           mrsd      = NULL,
108
+##                           as.Date   = FALSE, ...) {
109
+##     ## tree <- reorder.phylo(model, 'postorder')
110
+##     tree <- model
111
+##     if (ladderize == TRUE) {
112
+##         tree <- ladderize(tree, right=right)
113
+##     }
114
+##     if (! is.null(tree$edge.length)) {
115
+##         if (anyNA(tree$edge.length)) {
116
+##             warning("'edge.length' contains NA values...\n## setting 'edge.length' to NULL automatically when plotting the tree...")
117
+##             tree$edge.length <- NULL
118
+##         }
119
+##     }
120
+##     df <- as.data.frame(tree, layout=layout, ...)
121
+##     idx <- is.na(df$parent)
122
+##     df$parent[idx] <- df$node[idx]
123
+##     rownames(df) <- df$node
124
+##     cn <- colnames(df)
125
+##     colnames(df)[grep("length", cn)] <- "branch.length"
126
+##     if(layout == "slanted") {
127
+##         df <- add_angle_slanted(df)
128
+##     }
129
+##     aa <- names(attributes(tree))
130
+##     group <- aa[ ! aa %in% c("names", "class", "order", "reroot", "node_map")]
131
+##     if (length(group) > 0) {
132
+##         for (group_ in group) {
133
+##             ## groupOTU & groupClade
134
+##             group_info <- attr(tree, group_)
135
+##             if (length(group_info) == nrow(df)) {
136
+##                 df[, group_] <- group_info
137
+##             }
138
+##         }
139
+##     }
140
+##     if (!is.null(mrsd)) {
141
+##         df <- scaleX_by_time_from_mrsd(df, mrsd, as.Date)
142
+##     }
143
+##     return(df)
144
+## }
145
+
146
+## ##' convert phylo to data.frame
147
+## ##'
148
+## ##'
149
+## ##' @title as.data.frame
150
+## ##' @param x phylo object
151
+## ##' @param row.names omitted here
152
+## ##' @param optional omitted here
153
+## ##' @param layout layout
154
+## ##' @param ... additional parameter
155
+## ##' @return data.frame
156
+## ##' @method as.data.frame phylo
157
+## ##' @export
158
+## ##' @author Yu Guangchuang
159
+## as.data.frame.phylo <- function(x, row.names, optional,
160
+##                                 layout="rectangular", ...) {
161
+##     if (layout %in% c("equal_angle", "daylight")) {
162
+##         return(layout.unrooted(x, layout.method = layout, ...))
163
+##     }
164
+##     as.data.frame.phylo_(x, layout, ...)
165
+## }
166
+
167
+
168
+## used by layoutEqualAngle
169
+## will change to tidytree::as_data_frame in future
170
+as.data.frame.phylo_ <- function(x, layout="rectangular",
171
+                                 branch.length="branch.length", ...) {
172
+    if (branch.length != 'none') {
173
+        branch.length = "branch.length"
174
+    }
175
+    tip.label <- x[["tip.label"]]
176
+    Ntip <- length(tip.label)
177
+    N <- getNodeNum(x)
178
+    edge <- as.data.frame(x[["edge"]])
179
+    colnames(edge) <- c("parent", "node")
180
+    if (! is.null(x$edge.length)) {
181
+        edge$length <- x$edge.length
182
+        if (branch.length == "none") {
183
+            xpos <- getXcoord_no_length(x)
184
+            ypos <- getYcoord(x)
185
+        } else {
186
+            xpos <- getXcoord(x)
187
+            ypos <- getYcoord(x)
188
+        }
189
+        ## } else  if (layout != "cladogram") {
190
+        ##     xpos <- getXcoord(x)
191
+        ##     ypos <- getYcoord(x)
192
+        ## } else {
193
+        ##     ## layout == "cladogram" && branch.length != "none"
194
+        ##     xy <- getXYcoord_cladogram(x)
195
+        ##     xpos <- xy$x
196
+        ##     ypos <- xy$y
197
+        ## }
198
+    } else {
199
+        xpos <- getXcoord_no_length(x)
200
+        ypos <- getYcoord(x)
201
+    }
202
+    xypos <- data.frame(node=1:N, x=xpos, y=ypos)
203
+    res <- merge(edge, xypos, by.x="node", by.y="node", all.y=TRUE)
204
+    label <- rep(NA, N)
205
+    label[1:Ntip] <- tip.label
206
+    if ( !is.null(x$node.label) ) {
207
+        label[(Ntip+1):N] <- x$node.label
208
+    }
209
+    res$label <- label
210
+    isTip <- rep(FALSE, N)
211
+    isTip[1:Ntip] <- TRUE
212
+    res$isTip <- isTip
213
+    ## add branch mid position
214
+    res <- calculate_branch_mid(res)
215
+    ## ## angle for all layout, if 'rectangular', user use coord_polar, can still use angle
216
+    res <- calculate_angle(res)
217
+    return(res)
218
+}
0 219
deleted file mode 100644
... ...
@@ -1,158 +0,0 @@
1
-##' @importFrom ggplot2 fortify
2
-##' @method fortify treedata
3
-##' @export
4
-fortify.treedata <- function(model, data,
5
-                             layout        = "rectangular",
6
-                             yscale        = "none",
7
-                             ladderize     = TRUE,
8
-                             right         = FALSE,
9
-                             branch.length = "branch.length",
10
-                             mrsd          = NULL,
11
-                             as.Date       = FALSE, ...) {
12
-
13
-    model <- set_branch_length(model, branch.length)
14
-
15
-    fortify.phylo(model, data,
16
-                  layout        = layout,
17
-                  yscale        = yscale,
18
-                  ladderize     = ladderize,
19
-                  right         = right,
20
-                  branch.length = branch.length,
21
-                  mrsd          = mrsd,
22
-                  as.Date       = as.Date, ...)
23
-}
24
-
25
-##' @importFrom ape ladderize
26
-##' @importFrom treeio as.phylo
27
-##' @importFrom treeio Nnode
28
-##' @importFrom tibble data_frame
29
-##' @importFrom dplyr full_join
30
-##' @importFrom tidytree as_data_frame
31
-##' @method fortify phylo
32
-##' @export
33
-fortify.phylo <- function(model, data,
34
-                          layout        = "rectangular",
35
-                          ladderize     = TRUE,
36
-                          right         = FALSE,
37
-                          branch.length = "branch.length",
38
-                          mrsd          = NULL,
39
-                          as.Date       = FALSE,
40
-                          yscale        = "none",
41
-                          ...) {
42
-
43
-    x <- as.phylo(model) ## reorder.phylo(get.tree(model), "postorder")
44
-    if (ladderize == TRUE) {
45
-        x <- ladderize(x, right=right)
46
-    }
47
-
48
-    if (! is.null(x$edge.length)) {
49
-        if (anyNA(x$edge.length)) {
50
-            warning("'edge.length' contains NA values...\n## setting 'edge.length' to NULL automatically when plotting the tree...")
51
-            x$edge.length <- NULL
52
-        }
53
-    }
54
-
55
-    if (is.null(x$edge.length) || branch.length == "none") {
56
-        xpos <- getXcoord_no_length(x)
57
-    } else {
58
-        xpos <- getXcoord(x)
59
-    }
60
-
61
-    ypos <- getYcoord(x)
62
-    N <- Nnode(x, internal.only=FALSE)
63
-    xypos <- data_frame(node=1:N, x=xpos, y=ypos)
64
-
65
-    df <- as_data_frame(model)
66
-
67
-    res <- full_join(df, xypos, by = "node")
68
-
69
-    ## add branch mid position
70
-    res <- calculate_branch_mid(res)
71
-
72
-    if (!is.null(mrsd)) {
73
-        res <- scaleX_by_time_from_mrsd(res, mrsd, as.Date)
74
-    }
75
-
76
-    if (layout == "slanted") {
77
-        res <- add_angle_slanted(res)
78
-    } else {
79
-        ## angle for all layout, if 'rectangular', user use coord_polar, can still use angle
80
-        res <- calculate_angle(res)
81
-    }
82
-    scaleY(as.phylo(model), res, yscale, layout, ...)
83
-}
84
-
85
-##' @importFrom tidytree get_tree_data
86
-set_branch_length <- function(tree_object, branch.length) {
87
-    if (branch.length == "branch.length") {
88
-        return(tree_object)
89
-    } else if (branch.length == "none") {
90
-        tree_object@phylo$edge.length <- NULL
91
-        return(tree_object)
92
-    }
93
-
94
-    if (is(tree_object, "phylo")) {
95
-        return(tree_object)
96
-    }
97
-
98
-    tree_anno <- get_tree_data(tree_object)
99
-    tree_anno$node <- as.integer(tree_anno$node)
100
-
101
-    phylo <- as.phylo(tree_object)
102
-
103
-    cn <- colnames(tree_anno)
104
-    cn <- cn[!cn %in% c('node', 'parent')]
105
-
106
-    length <- match.arg(branch.length, cn)
107
-
108
-    if (all(is.na(as.numeric(tree_anno[[length]])))) {
109
-        stop("branch.length should be numerical attributes...")
110
-    }
111
-
112
-    edge <- as_data_frame(phylo$edge)
113
-    colnames(edge) <- c("parent", "node")
114
-
115
-    dd <- full_join(edge, tree_anno, by = "node")
116
-
117
-    dd <- dd[match(edge[['node']], dd[['node']]),]
118
-    len <- unlist(dd[[length]])
119
-    len <- as.numeric(len)
120
-    len[is.na(len)] <- 0
121
-
122
-    phylo$edge.length <- len
123
-
124
-    tree_object@phylo <- phylo
125
-    return(tree_object)
126
-}
127
-
128
-
129
-calculate_angle <- function(data) {
130
-    data$angle <- 360/(diff(range(data$y)) + 1) * data$y
131
-    return(data)
132
-}
133
-
134
-
135
-
136
-scaleY <- function(phylo, df, yscale, layout, ...) {
137
-    if (yscale == "none") {
138
-        return(df)
139
-    }
140
-    if (! yscale %in% colnames(df)) {
141
-        warning("yscale is not available...\n")
142
-        return(df)
143
-    }
144
-    if (is.numeric(df[[yscale]])) {
145
-        y <- getYcoord_scale_numeric(phylo, df, yscale, ...)
146
-        ## if (order.y) {
147
-        ##     y <- getYcoord_scale2(phylo, df, yscale)
148
-        ## } else {
149
-        ##     y <- getYcoord_scale(phylo, df, yscale)
150
-        ## }
151
-    } else {
152
-        y <- getYcoord_scale_category(phylo, df, yscale, ...)
153
-    }
154
-
155
-    df[, "y"] <- y
156
-
157
-    return(df)
158
-}
... ...
@@ -94,50 +94,52 @@ stat_balance <- function(mapping=NULL, data=NULL, geom="rect",
94 94
                          show.legend=NA, inherit.aes=FALSE,
95 95
                          fill, color, alpha, extend=0, extendto=NULL,
96 96
                          ...) {
97
-  default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent, branch.length=~branch.length)
98
-  if (is.null(mapping)) {
99
-    mapping <- default_aes
100
-  } else {
101
-    mapping <- modifyList(mapping, default_aes)
102
-  }
103 97
 
104
-  l1 <- layer(
105
-    stat=StatBalance,
106
-    data = data,
107
-    mapping = mapping,
108
-    geom = geom,
109
-    position = position,
110
-    show.legend=show.legend,
111
-    inherit.aes = inherit.aes,
112
-    params = list(node=node,
113
-                  fill=fill,
114
-                  color=color,
115
-                  alpha=alpha,
116
-                  extend=extend,
117
-                  extendto=extendto,
118
-                  direction=1,
119
-                  ...),
120
-    check.aes = FALSE
121
-  )
122
-  l2 <- layer(
123
-    stat=StatBalance,
124
-    data = data,
125
-    mapping = mapping,
126
-    geom = geom,
127
-    position = position,
128
-    show.legend=show.legend,
129
-    inherit.aes = inherit.aes,
130
-    params = list(node=node,
131
-                  fill=fill,
132
-                  color=color,
133
-                  alpha=alpha,
134
-                  extend=extend,
135
-                  extendto=extendto,
136
-                  direction=2,
137
-                  ...),
138
-    check.aes = FALSE
139
-  )
140
-  return(c(l1,l2))
98
+    default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent, branch.length=~branch.length)
99
+    if (is.null(mapping)) {
100
+        mapping <- default_aes
101
+    } else {
102
+        mapping <- modifyList(mapping, default_aes)
103
+    }
104
+
105
+    l1 <- layer(
106
+        stat=StatBalance,
107
+        data = data,
108
+        mapping = mapping,
109
+        geom = geom,
110
+        position = position,
111
+        show.legend=show.legend,
112
+        inherit.aes = inherit.aes,
113
+        params = list(node=node,
114
+                      fill=fill,
115
+                      color=color,
116
+                      alpha=alpha,
117
+                      extend=extend,
118
+                      extendto=extendto,
119
+                      direction=1,
120
+                      ...),
121
+        check.aes = FALSE
122
+    )
123
+
124
+    l2 <- layer(
125
+        stat=StatBalance,
126
+        data = data,
127
+        mapping = mapping,
128
+        geom = geom,
129
+        position = position,
130
+        show.legend=show.legend,
131
+        inherit.aes = inherit.aes,
132
+        params = list(node=node,
133
+                      fill=fill,
134
+                      color=color,
135
+                      alpha=alpha,
136
+                      extend=extend,
137
+                      extendto=extendto,
138
+                      direction=2,
139
+                      ...),
140
+        check.aes = FALSE
141
+    )
142
+    return(c(l1,l2))
141 143
 }
142 144
 
143 145
 ##' StatBalance
... ...
@@ -148,20 +150,20 @@ stat_balance <- function(mapping=NULL, data=NULL, geom="rect",
148 150
 ##' @export
149 151
 StatBalance <- ggproto("StatBalance", Stat,
150 152
                        compute_group = function(self, data, scales, params, node, extend, extendto, direction) {
151
-                         df <- get_balance_position_(data, node, direction)
152
-
153
-                         df$xmax <- df$xmax + extend
154
-                         if (!is.null(extendto) && !is.na(extendto)) {
155
-                           if (extendto < df$xmax) {
156
-                             warning("extendto is too small, keep the original xmax value...")
157
-                           } else {
158
-                             df$xmax <- extendto
153
+                           df <- get_balance_position_(data, node, direction)
154
+
155
+                           df$xmax <- df$xmax + extend
156
+                           if (!is.null(extendto) && !is.na(extendto)) {
157
+                               if (extendto < df$xmax) {
158
+                                   warning("extendto is too small, keep the original xmax value...")
159
+                               } else {
160
+                                   df$xmax <- extendto
161
+                               }
159 162
                            }
160
-                         }
161
-                         return(df)
163
+                           return(df)
162 164
                        },
163 165
                        required_aes = c("x", "y", "branch.length")
164
-)
166
+                       )
165 167
 
166 168
 
167 169
 #' get position of balance (xmin, xmax, ymin, ymax)
... ...
@@ -175,39 +177,39 @@ StatBalance <- ggproto("StatBalance", Stat,
175 177
 #' @export
176 178
 #' @author Justin Silverman
177 179
 get_balance_position <- function(treeview, node, direction) {
178
-  get_balance_position_(treeview$data, node, direction)
180
+    get_balance_position_(treeview$data, node, direction)
179 181
 }
180 182
 
181 183
 get_balance_position_ <- function(data, node, direction) {
182
-  ch <- tryCatch(getChild.df(data, node), error=function(e) NULL)
183
-
184
-  if (length(ch) < 2 || is.null(ch)){
185
-    stop('balance cannot be a tip')
186
-  } else if (length(ch) > 2){
187
-    stop('balance has >2 direct child nodes, can use ape::multi2di to convert to binary tree')
188
-  }
189
-
190
-  i <- match(node, data$node)
191
-  sp <- tryCatch(get.offspring.df(data, ch[direction]), error=function(e) ch[direction])
192
-  sp.all <- get.offspring.df(data, i)
193
-  sp.df <- data[match(sp, data$node),]
194
-  sp.all.df <- data[match(sp.all, data$node),]
195
-  n.df <- data[i,]
196
-
197
-  # X direction is uniform for both children, but y is only based on range of
198
-  # one of the two children (direction)
199
-  x <- sp.all.df$x
200
-  y <- sp.df$y
201
-  #x.n <- n.df$x
202
-
203
-  if ("branch.length" %in% colnames(data)) {
204
-   xmin <- min(x)-data[i, "branch.length"]/2
205
-  } else {
206
-   xmin <- min(sp.df$branch)
207
-  }
208
-  #xmin <- x.n
209
-  data.frame(xmin=xmin,
210
-             xmax = max(x),
211
-             ymin=min(y)-0.5,
212
-             ymax=max(y)+0.5)
184
+    ch <- tryCatch(getChild.df(data, node), error=function(e) NULL)
185
+
186
+    if (length(ch) < 2 || is.null(ch)){
187
+        stop('balance cannot be a tip')
188
+    } else if (length(ch) > 2){
189
+        stop('balance has >2 direct child nodes, can use ape::multi2di to convert to binary tree')
190
+    }
191
+
192
+    i <- match(node, data$node)
193
+    sp <- tryCatch(get.offspring.df(data, ch[direction]), error=function(e) ch[direction])
194
+    sp.all <- get.offspring.df(data, i)
195
+    sp.df <- data[match(sp, data$node),]
196
+    sp.all.df <- data[match(sp.all, data$node),]
197
+    n.df <- data[i,]
198
+
199
+    ## X direction is uniform for both children, but y is only based on range of
200
+    ## one of the two children (direction)
201
+    x <- sp.all.df$x
202
+    y <- sp.df$y
203
+    ## x.n <- n.df$x
204
+
205
+    if ("branch.length" %in% colnames(data)) {
206
+        xmin <- min(x)-data[i, "branch.length"]/2
207
+    } else {
208
+        xmin <- min(sp.df$branch)
209
+    }
210
+    ## xmin <- x.n
211
+    data.frame(xmin=xmin,
212
+               xmax = max(x),
213
+               ymin=min(y)-0.5,
214
+               ymax=max(y)+0.5)
213 215
 }
... ...
@@ -1,6 +1,6 @@
1 1
 ##' add tree scale
2 2
 ##'
3
-##' 
3
+##'
4 4
 ##' @title geom_treescale
5 5
 ##' @param x x position
6 6
 ##' @param y y position
... ...
@@ -15,7 +15,7 @@
15 15
 ##' @author Guangchuang Yu
16 16
 geom_treescale <- function(x=NULL, y=NULL, width=NULL, offset=NULL, color="black",
17 17
                            linesize=0.5, fontsize=3.88, family="sans") {
18
-    
18
+
19 19
     data=NULL
20 20
     position="identity"
21 21
     show.legend=NA
... ...
@@ -24,14 +24,14 @@ geom_treescale <- function(x=NULL, y=NULL, width=NULL, offset=NULL, color="black
24 24
 
25 25
     default_aes <- aes_(x=~x, y=~y)
26 26
     mapping <- default_aes
27
-    
27
+
28 28
     list(
29 29
         stat_treeScaleLine(xx=x, yy=y, width=width, color=color, offset=offset, size=linesize,
30 30
                            mapping=mapping, data=data,
31 31
                            position=position, show.legend = show.legend,
32 32
                            inherit.aes = inherit.aes, na.rm=na.rm),
33 33
         stat_treeScaleText(xx=x, yy=y, width=width, color=color, offset=offset,
34
-                           size=fontsize, family = family, 
34
+                           size=fontsize, family = family,
35 35
                            mapping=mapping, data=data,
36 36
                            position=position, show.legend = show.legend,
37 37
                            inherit.aes = inherit.aes, na.rm=na.rm)
... ...
@@ -42,9 +42,9 @@ geom_treescale <- function(x=NULL, y=NULL, width=NULL, offset=NULL, color="black
42 42
 
43 43
 stat_treeScaleLine <- function(mapping=NULL, data=NULL,
44 44
                            geom="segment", position="identity",
45
-                           xx, yy, width, offset, color, ..., 
45
+                           xx, yy, width, offset, color, ...,
46 46
                            show.legend=NA, inherit.aes=FALSE, na.rm=FALSE){
47
-    
47
+
48 48
     default_aes <- aes_(x=~x, y=~y, xend=~x, yend=~y)
49 49
     if (is.null(mapping)) {
50 50
         mapping <- default_aes
... ...
@@ -120,17 +120,17 @@ get_treescale_position <- function(data, xx, yy, width, offset=NULL) {
120 120
     x <- xx
121 121
     y <- yy
122 122
     dx <- data$x %>% range %>% diff
123
-    
123
+
124 124
     if (is.null(x)) {
125 125
         x <- dx/2
126 126
     }
127
-    
127
+
128 128
     if (is.null(y)) {
129 129
         y <- 0
130 130
     }
131 131
 
132 132
     if (is.null(width) || is.na(width)) {
133
-        d <- dx/10 
133
+        d <- dx/10
134 134
         n <- 0
135 135
         while (d < 1) {
136 136
             d <- d*10
... ...
@@ -140,42 +140,11 @@ get_treescale_position <- function(data, xx, yy, width, offset=NULL) {
140 140
     } else {
141 141
         d <- width
142 142
     }
143
-    
143
+
144 144
     if (is.null(offset)) {
145 145
         offset <- 0.4
146 146
     }
147
-    
147
+
148 148
     list(LinePosition=data.frame(x=x, xend=x+d, y=y, yend=y),
149 149
          TextPosition=data.frame(x=x+d/2, y=y+offset, label=d))
150 150
 }
151
-
152
-## ##' add evolution distance legend
153
-## ##'
154
-## ##' 
155
-## ##' @title add_legend
156
-## ##' @param p tree view
157
-## ##' @param width width of legend
158
-## ##' @param x x position
159
-## ##' @param y y position
160
-## ##' @param offset offset of text and line
161
-## ##' @param font.size font size
162
-## ##' @param ... additional parameter
163
-## ##' @return tree view
164
-## ##' @importFrom grid linesGrob
165
-## ##' @importFrom grid textGrob
166
-## ##' @importFrom grid gpar
167
-## ##' @importFrom ggplot2 ylim
168
-## ##' @export
169
-## ##' @author Guangchuang Yu
170
-## add_legend <- function(p, width=NULL, x=NULL, y=NULL, offset=NULL, font.size=4, ...) {
171
-##     dd <- get_treescale_position(p$data, x, y, width, offset)
172
-##     x <- dd[[1]]$x
173
-##     y <- dd[[1]]$y
174
-##     d <- dd[[1]]$xend -x
175
-##     p <- p + annotation_custom(linesGrob(), xmin=x, xmax=x+d, ymin=y, ymax=y) +
176
-##         annotation_custom(textGrob(label=d, gp = gpar(fontsize = font.size)),
177
-##                           xmin=x+d/2, xmax=x+d/2, ymin=y+offset, ymax=y+offset)
178
-##     return(p)
179
-## }
180
-
181
-
... ...
@@ -1,6 +1,11 @@
1 1
 ##' visualizing phylogenetic tree and heterogenous associated data based on grammar of graphics
2 2
 ##' \code{ggtree} provides functions for visualizing phylogenetic tree and its associated data in R.
3 3
 ##'
4
+##' If you use ggtree in published research, please cite:
5
+##' Guangchuang Yu, David Smith, Huachen Zhu, Yi Guan, Tommy Tsan-Yuk Lam.
6
+##' ggtree: an R package for visualization and annotation of phylogenetic trees with their covariates and other associated data.
7
+##' Methods in Ecology and Evolution 2017, 8(1):28-36, doi:10.1111/2041-210X.12628
8
+##'
4 9
 ##' @docType package
5 10
 ##' @name ggtree
6 11
 ##' @aliases ggtree package-ggtree
... ...
@@ -13,7 +13,6 @@
13 13
 ##' @param ladderize logical
14 14
 ##' @param right logical
15 15
 ##' @param branch.length variable for scaling branch, if 'none' draw cladogram
16
-##' @param ndigits number of digits to round numerical annotation variable
17 16
 ##' @param ... additional parameter
18 17
 ##' @return tree
19 18
 ##' @importFrom ggplot2 ggplot
... ...
@@ -41,7 +40,6 @@ ggtree <- function(tr,
41 40
                    ladderize      = TRUE,
42 41
                    right          = FALSE,
43 42
                    branch.length  = "branch.length",
44
-                   ndigits        = NULL,
45 43
                    ...) {
46 44
 
47 45
     # Check if layout string is valid.
... ...
@@ -76,7 +74,7 @@ ggtree <- function(tr,
76 74
                 ladderize     = ladderize,
77 75
                 right         = right,
78 76
                 branch.length = branch.length,
79
-                ndigits       = ndigits, ...)
77
+                ...)
80 78
 
81 79
     if (is(tr, "multiPhylo")) {
82 80
         multiPhylo <- TRUE
83 81
deleted file mode 100644
... ...
@@ -1,229 +0,0 @@
1
-## ##' read HYPHY output
2
-## ##'
3
-## ##'
4
-## ##' @title read.hyphy
5
-## ##' @param nwk tree file in nwk format, one of hyphy output
6
-## ##' @param ancseq ancestral sequence file in nexus format,
7
-## ##'               one of hyphy output
8
-## ##' @param tip.fasfile tip sequence file
9
-## ##' @return A hyphy object
10
-## ## @importFrom Biostrings readBStringSet
11
-## ## @importFrom Biostrings toString
12
-## ##' @export
13
-## ##' @author Guangchuang Yu \url{http://ygc.name}
14
-## ##' @examples
15
-## ##' nwk <- system.file("extdata/HYPHY", "labelledtree.tree", package="ggtree")
16
-## ##' ancseq <- system.file("extdata/HYPHY", "ancseq.nex", package="ggtree")
17
-## ##' read.hyphy(nwk, ancseq)
18
-## read.hyphy <- function(nwk, ancseq, tip.fasfile=NULL) {
19
-##     anc <- scan(ancseq, what="", sep="\n", quiet=TRUE)
20
-##     end <- grep("END;", anc, ignore.case=TRUE)
21
-    
22
-##     seq.start <- grep("MATRIX", anc, ignore.case=TRUE)
23
-##     seq.end   <- end[end > seq.start][1]
24
-##     seq       <- anc[(seq.start+1):(seq.end-1)]
25
-##     seq       <- seq[seq != ";"]
26
-##     seq       <- seq[seq != ""]
27
-##     seq       <- gsub(" ", "", seq)
28
-##     seq       <- gsub(";", "", seq)
29
-    
30
-##     ## some files may only contains sequences (should have TAXALABELS block that contains seq names).
31
-##     ## some may contains sequence name like phylip format in MATRIX block (no need to have TAXALABELS block).
32
-##     ##
33
-##     ## extract sequence name if available
34
-##     if (all(grepl("\\s+", seq))) {
35
-##         ## if contains blank space, may contains seq name
36
-##         sn <- gsub("(\\w*)\\s.*", "\\1", seq)
37
-##     }
38
-    
39
-##     seq <- gsub("\\w*\\s+", "", seq)
40
-    
41
-##     label.start <- grep("TAXLABELS", anc, ignore.case = TRUE)
42
-##     if (length(label.start) == 0) {
43
-##         if (all(sn == "")) {
44
-##             stop("taxa labels is not available...")
45
-##         }
46
-##         label <- sn
47
-##     } else {
48
-##         label.end   <- end[end > label.start][1]
49
-##         label       <- anc[(label.start+1):(label.end-1)]
50
-        
51
-##         label <- sub("^\t+", "", label)
52
-##         label <- sub("\\s*;$", "", label)
53
-##         label <- unlist(strsplit(label, split="\\s+"))
54
-##         label <- gsub("'|\"", "", label)
55
-##     }
56
-    
57
-##     names(seq) <- label
58
-
59
-##     tr <- read.tree(nwk)
60
-##     nl <- tr$node.label
61
-##     ## root node may missing, which was supposed to be 'Node1'
62
-##     ##
63
-##     ## from a user's file, which is 'Node0', but it seems the file is not from the output of HYPHY.
64
-##     ##
65
-##     ## I am not sure. But it's safe to use "label[!label %in% nl]" instead of just assign it to "Node1".
66
-##     ##
67
-##     ## nl[nl == ""] <- "Node1"
68
-##     nl[nl == ""] <- label[!label %in% nl]
69
-    
70
-##     tr$node.label <- nl
71
-
72
-##     type <- get_seqtype(seq)
73
-##     fields <- "subs"
74
-##     if (type == "NT") {
75
-##         fields <- c(fields, "AA_subs")
76
-##     }
77
-
78
-##     res <- new("hyphy",
79
-##                fields = fields,
80
-##                treetext = scan(nwk, what='', quiet=TRUE),
81
-##                phylo = tr,
82
-##                seq_type = type,
83
-##                ancseq = seq,
84
-##                tree.file = filename(nwk),
85
-##                ancseq.file = ancseq
86
-##                )
87
-
88
-##     if ( !is.null(tip.fasfile) ) {
89
-##         readBStringSet <- get_fun_from_pkg("Biostrings", "readBStringSet")
90
-##         toString <- get_fun_from_pkg("Biostrings", "toString")
91
-        
92
-##         tip_seq <- readBStringSet(tip.fasfile)
93
-##         nn <- names(tip_seq)
94
-##         tip_seq <- sapply(seq_along(tip_seq), function(i) {
95
-##             toString(tip_seq[i])
96
-##         })
97
-##         names(tip_seq) <- nn
98
-##         res@tip_seq <- tip_seq
99
-##         res@tip.fasfile <- tip.fasfile
100
-##     }
101
-##     set.hyphy_(res)
102
-## }
103
-
104
-## ##' @rdname groupOTU-methods
105
-## ##' @exportMethod groupOTU
106
-## setMethod("groupOTU", signature(object="hyphy"),
107
-##           function(object, focus, group_name="group") {
108
-##               groupOTU_(object, focus, group_name)
109
-##           }
110
-##           )
111
-
112
-## ##' @rdname groupClade-methods
113
-## ##' @exportMethod groupClade
114
-## setMethod("groupClade", signature(object="hyphy"),
115
-##           function(object, node, group_name="group") {
116
-##               groupClade_(object, node, group_name)
117
-##           }
118
-##           )
119
-
120
-## ##' @rdname scale_color-methods
121
-## ##' @exportMethod scale_color
122
-## setMethod("scale_color", signature(object="hyphy"),
123
-##           function(object, by, ...) {
124
-##               scale_color_(object, by, ...)
125
-##           })
126
-
127
-
128
-## ##' @rdname gzoom-methods
129
-## ##' @exportMethod gzoom
130
-## setMethod("gzoom", signature(object="hyphy"),
131
-##           function(object, focus, subtree=FALSE, widths=c(.3, .7)) {
132
-##               gzoom.phylo(get.tree(object), focus, subtree, widths)
133
-##           })
134
-
135
-## ##' @rdname show-methods
136
-## ##' @exportMethod show
137
-## setMethod("show", signature(object = "hyphy"),
138
-##           function(object) {
139
-##               cat("'hyphy' S4 object that stored information of \n\t",
140
-##                   paste0("'", object@tree.file, "'"))
141
-##               if (length(object@tip_seq) == 0) {
142
-##                   cat(paste0("and '", object@ancseq.file, "'"), ".\n")
143
-##               } else {
144
-##                   cat(paste0(", \n\t'", object@ancseq.file, "'"),
145
-##                       paste0("and \n\t'", object@tip.fasfile, "'."),
146
-##                       "\n\n")
147
-##               }
148
-##               cat("...@ tree:")
149
-##               print.phylo(get.tree(object))
150
-##               cat("\nwith the following features available:\n")
151
-##               cat("\t", paste0("'",
152
-##                                paste(get.fields(object), collapse="',\t'"),
153
-##                                "'."),
154
-##                   "\n")
155
-              
156
-##           })
157
-
158
-## ##' @rdname get.tree-methods
159
-## ##' @exportMethod get.tree
160
-## ##' @examples
161
-## ##' nwk <- system.file("extdata/HYPHY", "labelledtree.tree", package="ggtree")
162
-## ##' ancseq <- system.file("extdata/HYPHY", "ancseq.nex", package="ggtree")
163
-## ##' hy <- read.hyphy(nwk, ancseq)
164
-## ##' get.tree(hy)
165
-## setMethod("get.tree", signature(object = "hyphy"),
166
-##           function(object) {
167
-##               object@phylo
168
-##           }
169
-##           )
170
-
171
-## ##' @rdname get.fields-methods
172
-## ##' @exportMethod get.fields
173
-## setMethod("get.fields", signature(object = "hyphy"),
174
-##           function(object, ...) {
175
-##               if(length(object@tip_seq) == 0) {
176
-##                   warning("tip sequence not available...\n")
177
-##               } else {
178
-##                   get.fields.tree(object)
179
-##               }
180
-##           })
181
-
182
-
183
-## ##' @rdname get.subs-methods
184
-## ##' @exportMethod get.subs
185
-## ##' @examples
186
-## ##' nwk <- system.file("extdata/HYPHY", "labelledtree.tree", package="ggtree")
187
-## ##' ancseq <- system.file("extdata/HYPHY", "ancseq.nex", package="ggtree")
188
-## ##' tipfas <- system.file("extdata", "pa.fas", package="ggtree")
189
-## ##' hy <- read.hyphy(nwk, ancseq, tipfas)
190
-## ##' get.subs(hy, type="AA_subs")
191
-## setMethod("get.subs", signature(object="hyphy"),
192
-##           function(object, type, ...) {
193
-##               if (length(object@tip_seq) == 0) {
194
-##                   stop("tip sequence not available...\n")
195
-##               }
196
-##               if (type == "subs") {
197
-##                   return(object@subs)
198
-##               } else {
199
-##                   return(object@AA_subs)
200
-##               }
201
-##           })
202
-
203
-
204
-## set.hyphy_ <- function(object, ...) {
205
-##     if (!is(object, "hyphy")) {
206
-##         stop("object should be an instance of 'hyphy'")
207
-##     }
208
-
209
-##     if (length(object@tip_seq) == 0) {
210
-##         return(object)
211
-##     }
212
-
213
-##     types <- get.fields(object)
214
-##     seqs <- c(object@tip_seq, object@ancseq)
215
-##     for (type in types) {
216
-##         if (type == "subs") {
217
-##             translate <- FALSE
218
-##         } else {
219
-##             translate <- TRUE
220
-##         }
221
-##         subs <- get.subs_(object@phylo, seqs, translate, ...)
222
-##         if (type == "subs") {
223
-##             object@subs <- subs
224
-##         } else {
225
-##             object@AA_subs <- subs
226
-##         }
227
-##     }
228
-##     return(object)
229
-## }
<
... ...
@@ -1,352 +1,111 @@
1
-##' convert polytomy to binary tree
2
-##'
3
-##' as.binary method for \code{phylo} object
4
-##' @rdname as.binary
5
-##' @return binary tree
6
-##' @method as.binary phylo
7
-##' @importFrom ape is.binary.tree
1
+##' @importFrom ape ladderize
2
+##' @importFrom treeio as.phylo
3
+##' @importFrom treeio Nnode
4
+##' @importFrom tibble data_frame
5
+##' @importFrom dplyr full_join
6
+##' @importFrom dplyr mutate_
7
+##' @importFrom tidytree as_data_frame
8
+##' @method fortify phylo
8 9
 ##' @export
9
-##' @author Guangchuang Yu \url{http://ygc.name}
10
-##' @examples
11
-##' require(ape)
12
-##' tr <- read.tree(text="((A, B, C), D);")
13
-##' is.binary.tree(tr)
14
-##' tr2 <- as.binary(tr)
15
-##' is.binary.tree(tr2)
16
-as.binary.phylo <- function(tree, ...) {
17
-    if(is.binary.tree(tree)) {
18
-        message("The input tree is already binary...")
19
-        invisible(tree)
10
+fortify.phylo <- function(model, data,
11
+                          layout        = "rectangular",
12
+                          ladderize     = TRUE,
13
+                          right         = FALSE,
14
+                          branch.length = "branch.length",
15
+                          mrsd          = NULL,
16
+                          as.Date       = FALSE,
17
+                          yscale        = "none",
18
+                          ...) {
19
+
20
+    x <- as.phylo(model) ## reorder.phylo(get.tree(model), "postorder")
21
+    if (ladderize == TRUE) {
22
+        x <- ladderize(x, right=right)
20 23
     }
21 24
 
22
-    polyNode <- tree$edge[,1] %>% table %>% '>'(2) %>%
23
-        which %>% names %>% as.numeric
24
-
25
-    N <- getNodeNum(tree)
26
-    ii <- 0
27
-    for (pn in polyNode) {
28
-        idx <- which(tree$edge[,1] == pn)
29
-        while(length(idx) >2) {
30
-            ii <- ii + 1
31
-            newNode <- N+ii
32
-            tree$edge[idx[-1],1] <- newNode
33
-            newEdge <- matrix(c(tree$edge[idx[1],1], newNode), ncol=2)
34
-            tree$edge <- rbind(tree$edge, newEdge)
35
-            idx <- idx[-1]
25
+    if (! is.null(x$edge.length)) {
26
+        if (anyNA(x$edge.length)) {
27
+            warning("'edge.length' contains NA values...\n## setting 'edge.length' to NULL automatically when plotting the tree...")
28
+            x$edge.length <- NULL
36 29
         }
37 30
     }
38 31
 
39
-    tree$Nnode <- tree$Nnode+ii
40
-    tree$edge.length <- c(tree$edge.length, rep(0, ii))
41
-    return(tree)
42
-}
43
-
44
-
45
-##' remove singleton
46
-##'
47
-##'
48
-##' @title rm.singleton.newick
49
-##' @param nwk newick file
50
-##' @param outfile output newick file
51
-##' @return tree text
52
-##' @importFrom magrittr %<>%
53
-##' @importFrom magrittr add
54
-##' @importFrom ape write.tree
55
-##' @importFrom ape read.tree
56
-##' @author Guangchuang Yu \url{http://ygc.name}
57
-rm.singleton.newick <- function(nwk, outfile = NULL) {
58
-    tree <- readLines(nwk)
59
-
60
-    ## remove singleton of tips
61
-    nodePattern <- "\\w+:[\\.0-9Ee\\+\\-]+"
62
-    singletonPattern.with.nodename <- paste0(".*(\\(", nodePattern, "\\)\\w+:[\\.0-9Ee\\+\\-]+).*")
63
-    singletonPattern.wo.nodename <- paste0(".*(\\(", nodePattern, "\\):[\\.0-9Ee\\+\\-]+).*")
64
-
65
-    while(length(grep("\\([^,]+\\)", tree)) > 0) {
66
-        singleton <- gsub(singletonPattern.with.nodename, "\\1", tree)
67
-        if (singleton == tree) {
68
-            singleton <- gsub(singletonPattern.wo.nodename, "\\1", tree)
69
-        }
70
-        if (singleton == tree) {
71
-            stop("can't parse singleton node...")
72
-        }
32
+    if (is.null(x$edge.length) || branch.length == "none") {
33
+        xpos <- getXcoord_no_length(x)
34
+    } else {
35
+        xpos <- getXcoord(x)
36
+    }
73 37
 
74
-        tip <- gsub("\\((\\w+).*", "\\1", singleton)
38
+    ypos <- getYcoord(x)
39
+    N <- Nnode(x, internal.only=FALSE)
40
+    xypos <- data_frame(node=1:N, x=xpos, y=ypos)
75 41
 
76
-        len1 <- gsub(".*[^\\.0-9Ee\\+\\-]+([\\.0-9Ee\\+\\-]+)", "\\1", singleton)
77
-        len2 <- gsub(".*:([\\.0-9Ee\\+\\-]+)\\).*", "\\1", singleton)
78
-        len <- as.numeric(len1) + as.numeric(len2)
42
+    df <- as_data_frame(model) %>%
43
+        mutate_(isTip = ~(! node %in% parent))
79 44
 
80
-        tree <- gsub(singleton, paste0(tip, ":", len), tree, fixed = TRUE)
81
-    }
45
+    res <- full_join(df, xypos, by = "node")
82 46
 
83
-    tree <- read.tree(text=tree)
47
+    ## add branch mid position
48
+    res <- calculate_branch_mid(res)
84 49
 
85
-    ### remove singleton of internal nodes
86
-    p.singleton <- which(table(tree$edge[,1]) == 1)
87
-    if (length(p.singleton) > 0) {
88
-        p.singleton %<>% names %>% as.numeric
89
-        edge <- tree$edge
90
-        idx <- which(edge[,1] == p.singleton)
91
-        sidx <- which(edge[,2] == p.singleton)
92
-        edge[sidx,2] <- edge[idx, 2]
93
-        edge <- edge[-idx,]
94
-        tree$edge <- edge
95
-        tree$edge.length[sidx] %<>% add(., tree$edge.length[idx])
96
-        tree$edge.length <- tree$edge.length[-idx]
97
-        tree$Nnode <- tree$Nnode - 1
98
-        if (!is.null(tree$node.label)) {
99
-            tree$node.label <- tree$node.label[-(p.singleton - Ntip(tree))]
100
-        }
50
+    if (!is.null(mrsd)) {
51
+        res <- scaleX_by_time_from_mrsd(res, mrsd, as.Date)
101 52
     }
102 53
 
103
-    if (!is.null(outfile)) {
104
-        write.tree(tree, file=outfile)
54
+    if (layout == "slanted") {
55
+        res <- add_angle_slanted(res)
56
+    } else {
57
+        ## angle for all layout, if 'rectangular', user use coord_polar, can still use angle
58
+        res <- calculate_angle(res)
105 59
     }
106
-    invisible(tree)
60
+    res <- scaleY(as.phylo(model), res, yscale, layout, ...)
61
+    class(res) <- c("tbl_tree", class(res))
62
+    return(res)
107 63
 }
108 64
 
109
-## ##' @method fortify beast
110
-## ##' @export
111
-## fortify.beast <- function(model, data,
112
-##                           layout        = "rectangular",
113
-##                           yscale        = "none",
114
-##                           ladderize     = TRUE,
115
-##                           right         = FALSE,
116
-##                           branch.length = "branch.length",
117
-##                           ndigits       = NULL,
118
-##                           mrsd = NULL, ...) {
119
-
120
-##     model <- set_branch_length(model, branch.length)
121
-##     phylo <- model@phylo
122
-##     df    <- fortify(phylo,
123
-##                      layout = layout,
124
-##                      branch.length = branch.length,
125
-##                      ladderize = ladderize,
126
-##                      right = right,
127
-##                      mrsd = mrsd, ...)
128
-
129
-##     stats <- model@stats
130
-
131
-##     scn <- colnames(stats)
132
-##     scn <- scn[scn != 'node']
133
-
134
-##     for (cn in scn) {
135
-##         if (cn %in% colnames(df)) {
136
-##             colnames(stats)[colnames(stats) == cn] <- paste0(cn, "_")
137
-##             msg <- paste("feature", cn, "was renamed to", paste0(cn, "_"), "due to name conflict...")
138
-##             warning(msg)
139
-##         }
140
-##     }
141
-
142
-##     idx <- which(colnames(stats) != "node")
143
-##     for (ii in idx) {
144
-##         if (is.character_beast(stats, ii)) {
145
-##             len <- sapply(stats[,ii], length)
146
-##             if (any(len > 1)) {
147
-##                 stats[,ii] %<>% sapply(., function(x) {
148
-##                     y <- unlist(x) %>% as.character %>%
149
-##                         gsub("\"", "", .) %>% gsub("'", "", .)
150
-##                     if (length(y) == 1) {
151
-##                         return(y)
152
-##                     } else {
153
-##                         return(paste0('{', paste0(y, collapse = ','), '}'))
154
-##                     }
155
-##                 })
156
-##             } else {
157
-##                 stats[,ii] %<>% unlist %>% as.character %>%
158
-##                     gsub("\"", "", .) %>% gsub("'", "", .)
159
-##             }
160
-##             next
161
-##         }
162
-
163
-##         len <- sapply(stats[,ii], length)
164
-##         if ( all(len == 1) ) {
165
-##             stats[, ii] %<>% unlist %>% as.character %>% as.numeric
166
-##             if (!is.null(ndigits)) {
167
-##                 stats[, ii] %<>% round(., ndigits)
168
-##             }
169
-##         } else if (all(len <= 2)) {
170
-##             stats[, ii] %<>% sapply(., function(x) {
171
-##                 y <- unlist(x) %>% as.character %>% as.numeric
172
-##                 if (!is.null(ndigits)) {
173
-##                     y %<>% round(., ndigits)
174
-##                 }
175
-##                 if (length(y) == 1) {
176
-##                     return(y)
177
-##                 } else {
178
-##                     return(paste0('[', paste0(y, collapse = ','), ']'))
179
-##                 }
180
-##             })
181
-##         } else {
182
-##             stats[,ii] %<>% sapply(., function(x) {
183
-##                 y <- unlist(x) %>% as.character %>% as.numeric
184
-##                 if (!is.null(ndigits)) {
185
-##                     y %<>% round(., ndigits)
186
-##                 }
187
-##                 if (length(y) == 1) {
188
-##                     return(y)
189
-##                 } else {
190
-##                     return(paste0('{', paste0(y, collapse = ','), '}'))
191
-##                 }
192
-##             })
193
-##         }
194
-##     }
195
-
196
-
197
-##     cn <- colnames(stats)
198
-##     lo <- cn[grep("_lower", cn)]
199
-##     hi <- gsub("lower$", "upper", lo)
200
-##     rid <- gsub("_lower$", "", lo)
201
-
202
-##     for (i in seq_along(rid)) {
203
-##         stats[, rid[i]] <- paste0("[", stats[, lo[i]], ",", stats[, hi[i]], "]")
204
-##         stats[is.na(stats[, lo[i]]), rid[i]] <- NA
205
-##     }
206
-
207
-##     idx   <- match(df$node, stats$node)
208
-##     stats <- stats[idx,]
209
-##     cn_stats <- colnames(stats)
210
-##     stats <- stats[, cn_stats != "node"]
211
-
212
-##     df <- cbind(df, stats)
213
-##     if (is(stats, "data.frame") == FALSE) {
214
-##         colnames(df)[colnames(df) == "stats"] <- cn_stats[cn_stats != "node"]
215
-##     }
216
-
217
-##     df <- scaleY(phylo, df, yscale, layout, ...)
218
-
219
-##     append_extraInfo(df, model)
220
-## }
221
-
222 65
 
223
-## ##' @method fortify codeml
224
-## ##' @export
225
-## fortify.codeml <- function(model, data,
226
-##                            layout        = "rectangular",
227
-##                            yscale        = "none",
228
-##                            ladderize     = TRUE,
229
-##                            right         = FALSE,
230
-##                            branch.length = "mlc.branch.length",
231
-##                            ndigits       = NULL,
232
-##                            mrsd          = NULL,
233
-##                            ...) {
234
-
235
-##     dNdS <- model@mlc@dNdS
236
-##     if (branch.length == "branch.length") {
237
-##         message("branch.length setting to mlc.branch.length by default...")
238
-##         branch.length <- "mlc.branch.length"
239
-##     }
240
-##     length <- match.arg(branch.length,
241
-##                         c("none",
242
-##                           "mlc.branch.length",
243
-##                           "rst.branch.length",
244
-##                           colnames(dNdS)[-c(1,2)])
245
-##                         )
246
-
247
-##     if (length == "rst.branch.length") {
248
-##         phylo <- get.tree(model@rst)
249
-##     } else {
250
-##         if (length == "mlc.branch.length") {
251
-##             length <- "branch.length"
252
-##         }
253
-##         mlc <- set_branch_length(model@mlc, length)
254
-##         phylo <- get.tree(mlc)
255
-##     }
256
-
257
-##     df <- fortify(phylo, data, layout, ladderize, right,
258
-##                   branch.length=length, mrsd=mrsd, ...)
259
-
260
-##     res <- merge_phylo_anno.codeml_mlc(df, dNdS, ndigits)
261
-##     df <- merge_phylo_anno.paml_rst(res, model@rst)
262
-##     df <- scaleY(phylo, df, yscale, layout, ...)
263
-
264
-##     append_extraInfo(df, model)
265
-## }
266
-
267
-
268
-## ##' @method fortify codeml_mlc
269
-## ##' @export
270
-## fortify.codeml_mlc <- function(model, data,
271
-##                                layout        = "rectangular",
272
-##                                yscale        = "none",
273
-##                                ladderize     = TRUE,
274
-##                                right         = FALSE,
275
-##                                branch.length = "branch.length",
276
-##                                ndigits       = NULL,
277
-##                                mrsd          = NULL,
278
-##                                ...) {
279
-
280
-##     model <- set_branch_length(model, branch.length)
281
-##     phylo <- get.tree(model)
282
-##     df <- fortify(phylo, data, layout, ladderize, right,
283
-##                   branch.length=branch.length, mrsd=mrsd, ...)
284
-
285
-##     dNdS <- model@dNdS
286
-
287
-##     df <- merge_phylo_anno.codeml_mlc(df, dNdS, ndigits)
288
-##     df <- scaleY(phylo, df, yscale, layout, ...)
289
-
290
-##     append_extraInfo(df, model)
291
-## }
292
-
293
-## merge_phylo_anno.codeml_mlc <- function(df, dNdS, ndigits = NULL) {
294
-##     if (!is.null(ndigits)) {
295
-##         idx <- which(! colnames(dNdS) %in% c("node", "parent"))
296
-##         for (ii in idx) {
297
-##             if (is.numeric(dNdS[, ii])) {
298
-##                 dNdS[, ii] <- round(dNdS[,ii], ndigits)
299
-##             }
300
-##         }
301
-##     }
302
-
303
-##     res <- merge(df, dNdS,
304
-##                  by.x  = c("node", "parent"),
305
-##                  by.y  = c("node", "parent"),
306
-##                  all.x = TRUE)
307
-
308
-##     res[match(df$node, res$node),]
309
-## }
310
-
311
-
312
-## ##' @method fortify paml_rst
313
-## ##' @export
314
-## fortify.paml_rst <- function(model, data,
315
-##                              layout    = "rectangular",
316
-##                              yscale    = "none",
317
-##                              ladderize = TRUE,
318
-##                              right     = FALSE,
319
-##                              mrsd      = NULL,
320
-##                              ...) {
321
-##     df <- fortify.phylo(model@phylo, data, layout, ladderize, right, mrsd=mrsd, ...)
322
-##     df <- merge_phylo_anno.paml_rst(df, model)
323
-##     df <- scaleY(model@phylo, df, yscale, layout, ...)
324
-
325
-##     append_extraInfo(df, model)
326
-## }
327
-
328
-## merge_phylo_anno.paml_rst <- function(df, model) {
329
-##     types <- get.fields(model)
330
-##     types <- types[grepl('subs', types)]
331
-##     for (type in types) {
332
-##         anno <- get.subs(model, type=type)
333
-##         colnames(anno)[2] <- type
334
-##         df <- df %add2% anno
335
-##     }
336
-##     return(df)
337
-## }
338
-
339
-
340
-## ##' @method fortify phangorn
341
-## ##' @export
342
-## fortify.phangorn <- fortify.paml_rst
343
-
344
-
345
-## ##' @method fortify hyphy
346
-## ##' @export
347
-## fortify.hyphy <- fortify.paml_rst
66
+##' @method fortify multiPhylo
67
+##' @export
68
+fortify.multiPhylo <-  function(model, data,
69
+                                layout    = "rectangular",
70
+                                ladderize = TRUE,
71
+                                right     = FALSE,
72
+                                mrsd      = NULL, ...) {
348 73
 
74
+    df.list <- lapply(model, function(x) fortify(x, layout=layout, ladderize=ladderize, right=right, mrsd=mrsd, ...))
75
+    if (is.null(names(model))) {
76
+        names(df.list) <- paste0("Tree ", "#", seq_along(model))
77
+    } else {
78
+        names(df.list) <- names(model)
79
+    }
80
+    df <- do.call("rbind", df.list)
81
+    df$.id <- rep(names(df.list), times=sapply(df.list, nrow))
82
+    df$.id <- factor(df$.id, levels=names(df.list))
83
+    return(df)
84
+}
349 85
 
86
+##' @importFrom ggplot2 fortify
87
+##' @method fortify treedata
88
+##' @export
89
+fortify.treedata <- function(model, data,
90
+                             layout        = "rectangular",
91
+                             yscale        = "none",
92
+                             ladderize     = TRUE,
93
+                             right         = FALSE,
94
+                             branch.length = "branch.length",
95
+                             mrsd          = NULL,
96
+                             as.Date       = FALSE, ...) {
97
+
98
+    model <- set_branch_length(model, branch.length)
99
+
100
+    fortify.phylo(model, data,
101
+                  layout        = layout,
102
+                  yscale        = yscale,
103
+                  ladderize     = ladderize,
104
+                  right         = right,
105
+                  branch.length = branch.length,
106
+                  mrsd          = mrsd,
107
+                  as.Date       = as.Date, ...)
108
+}
350 109
 
351 110
 
352 111
 ##' @method fortify phylo4
... ...
@@ -366,6 +125,7 @@ fortify.phylo4 <- function(model, data,
366 125
 }
367 126
 
368 127
 ##' @method fortify phylo4d
128
+##' @importFrom treeio as.treedata
369 129
 ##' @export
370 130
 fortify.phylo4d <- function(model, data,
371 131
                             layout        = "rectangular",
... ...
@@ -375,185 +135,10 @@ fortify.phylo4d <- function(model, data,
375 135
                             branch.length = "branch.length",
376 136
                             mrsd          = NULL,
377 137
                             ...) {
378
-    ## model <- set_branch_length(model, branch.length)
379
-    ## phylo <- as.phylo.phylo4(model)
380
-    ## res <- fortify(phylo, data, layout, branch.length=branch.length,
381
-    ##                ladderize, right, mrsd, ...)
382
-    ## tdata <- model@data[match(res$node, rownames(model@data)), , drop=FALSE]
383
-    ## df <- cbind(res, tdata)
384
-    ## scaleY(as.phylo.phylo4(model), df, yscale, layout, ...)
385 138
     fortify(as.treedata(model), data, layout, yscale, ladderize, right, branch.length, mrsd, ...)
386 139
 }
387 140
 
388 141
 
389
-
390
-## ##' fortify a phylo to data.frame
391
-## ##'
392
-## ##'
393
-## ##' @rdname fortify
394
-## ##' @title fortify
395
-## ##' @param model phylo object
396
-## ##' @param data not use here
397
-## ##' @param layout layout
398
-## ##' @param ladderize ladderize, logical
399
-## ##' @param right logical
400
-## ##' @param mrsd most recent sampling date
401
-## ##' @param as.Date logical whether using Date class in time tree
402
-## ##' @param ... additional parameter
403
-## ##' @return data.frame
404
-## ##' @importFrom ape ladderize
405
-## ##' @importFrom ape reorder.phylo
406
-## ##' @importFrom ggplot2 fortify
407
-## ##' @method fortify phylo
408
-## ##' @export
409
-## ##' @author Yu Guangchuang
410
-## fortify.phylo <- function(model, data,
411
-##                           layout    = "rectangular",
412
-##                           ladderize = TRUE,
413
-##                           right     = FALSE,
414
-##                           mrsd      = NULL,
415
-##                           as.Date   = FALSE, ...) {
416
-##     ## tree <- reorder.phylo(model, 'postorder')
417
-##     tree <- model
418
-
419
-##     if (ladderize == TRUE) {
420
-##         tree <- ladderize(tree, right=right)
421
-##     }
422
-
423
-##     if (! is.null(tree$edge.length)) {
424
-##         if (anyNA(tree$edge.length)) {
425
-##             warning("'edge.length' contains NA values...\n## setting 'edge.length' to NULL automatically when plotting the tree...")
426
-##             tree$edge.length <- NULL
427
-##         }
428
-##     }
429
-
430
-##     df <- as.data.frame(tree, layout=layout, ...)
431
-##     idx <- is.na(df$parent)
432
-##     df$parent[idx] <- df$node[idx]
433
-##     rownames(df) <- df$node
434
-##     cn <- colnames(df)
435
-##     colnames(df)[grep("length", cn)] <- "branch.length"
436
-##     if(layout == "slanted") {
437
-##         df <- add_angle_slanted(df)
438
-##     }
439
-##     aa <- names(attributes(tree))
440
-##     group <- aa[ ! aa %in% c("names", "class", "order", "reroot", "node_map")]
441
-##     if (length(group) > 0) {
442
-##         for (group_ in group) {
443
-##             ## groupOTU & groupClade
444
-##             group_info <- attr(tree, group_)
445
-##             if (length(group_info) == nrow(df)) {
446
-##                 df[, group_] <- group_info
447
-##             }
448
-##         }
449
-##     }
450
-
451
-##     if (!is.null(mrsd)) {
452
-##         df <- scaleX_by_time_from_mrsd(df, mrsd, as.Date)
453
-##     }
454
-##     return(df)
455
-## }
456
-
457
-##' convert phylo to data.frame
458
-##'
459
-##'
460
-##' @title as.data.frame
461
-##' @param x phylo object
462
-##' @param row.names omitted here
463
-##' @param optional omitted here
464
-##' @param layout layout
465
-##' @param ... additional parameter
466
-##' @return data.frame
467
-##' @method as.data.frame phylo
468
-##' @export
469
-##' @author Yu Guangchuang
470
-as.data.frame.phylo <- function(x, row.names, optional,
471
-                                layout="rectangular", ...) {
472
-    if (layout %in% c("equal_angle", "daylight")) {
473
-        return(layout.unrooted(x, layout.method = layout, ...))
474
-    }