1. ggtree
  2. Commit 14ff9149b23d4d4dd68cca144c0c35464491bbef
Browse code

clean up code

guangchuang yu authored on 14/12/2017 08:47:21
Showing 70 changed files
.gitignore
History View file @ 14ff914
... ... 
@@ -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
DESCRIPTION
History View file @ 14ff914
... ... 
@@ -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,
NAMESPACE
History View file @ 14ff914
... ... 
@@ -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)
NEWS
History View file @ 14ff914
... ... 
@@ -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
R/AllGenerics.R
History View file @ 14ff914
... ... 
@@ -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
R/Date.R
History View file @ 14ff914
... ... 
@@ -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)
R/NJ.R
History View file @ 14ff914
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 
-}
R/codeml.R
History View file @ 14ff914
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 
-
R/codeml_mlc.R
History View file @ 14ff914
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 
-
R/defunct.R
History View file @ 14ff914
... ... 
@@ -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 
+
R/fortify-utilities.R
History View file @ 14ff914
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 
+}
R/fortify.R
History View file @ 14ff914
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 
-}
R/geom_balance.R
History View file @ 14ff914
... ... 
@@ -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 
 }
R/geom_treescale.R
History View file @ 14ff914
... ... 
@@ -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 
-
R/ggtree-package.R
History View file @ 14ff914
... ... 
@@ -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
R/ggtree.R
History View file @ 14ff914
... ... 
@@ -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
R/hyphy.R
History View file @ 14ff914
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