1. ggtree
  2. Commit 3e4b5998d230155893ffd1d7257e8880731aadaa
Browse code

lots of new layers

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

g.yu authored on 22/12/2015 04:13:13
Showing 36 changed files
R/MRCA.R
History View file @ 3e4b5998
1 1 
new file mode 100644
... ... 
@@ -0,0 +1,65 @@
1 
+##' Find Most Recent Common Ancestor among a vector of tips
2 
+##'
3 
+##'
4 
+##' @title MRCA
5 
+##' @param obj supported tree object or ggplot object
6 
+##' @param tip a vector of mode numeric or character specifying the tips
7 
+##' @return MRCA of two or more tips
8 
+##' @importFrom ape getMRCA
9 
+##' @export
10 
+##' @author Guangchuang Yu
11 
+MRCA <- function(obj, tip) {
12 
+    if (is(obj,"gg")) {
13 
+        return(getMRCA.df(obj$data, tip))
14 
+    }
15 
+
16 
+    if(class(obj) %in% supported_tree_object()) {
17 
+        obj <- get.tree(obj)
18 
+    }
19 
+    if (class(obj) == "phylo") {
20 
+        return(getMRCA(obj, tip))
21 
+    }
22 
+    stop("obj is not supported...")
23 
+}
24 
+
25 
+
26 
+getMRCA.df <- function(data, tip) {
27 
+    if (length(tip) <= 1)
28 
+        return(NULL)
29 
+
30 
+    anc <- getMRCA.df_internal(data, tip[1], tip[2])
31 
+    if (length(tip) == 2) {
32 
+        return(anc)
33 
+    }
34 
+    for (i in 3:length(tip)) {
35 
+        anc <- getMRCA.df_internal(data, tip[i], anc)
36 
+    }
37 
+    return(anc)
38 
+}
39 
+
40 
+
41 
+getMRCA.df_internal <- function(data, tip1, tip2) {
42 
+    node1 <- which(tip1 == data$label | tip1 == data[, "node"])
43 
+    node2 <- which(tip2 == data$label | tip2 == data[, "node"])
44 
+
45 
+    anc1 <- get.ancestor.df(data, node1)
46 
+    anc2 <- get.ancestor.df(data, node2)
47 
+
48 
+    intersect(c(node1, anc1), c(node2, anc2))[1]
49 
+}
50 
+
51 
+
52 
+get.ancestor.df <- function(df, node) {
53 
+    pp <- getParent.df(df, node)
54 
+    pp <- pp[pp != 0]
55 
+    if (length(pp) == 0) {
56 
+        stop("input node is root...")
57 
+    }
58 
+    i <- 1
59 
+    while(i <= length(pp)) {
60 
+        pp <- c(pp, getParent.df(df, pp[i]))
61 
+        pp <- pp[pp!=0]
62 
+        i <- i+1
63 
+    }
64 
+    return(pp)
65 
+}
R/NHX.R
History View file @ 3e4b5998
0 66 
new file mode 100644
... ... 
@@ -0,0 +1,106 @@
1 
+##' read nhx tree file
2 
+##'
3 
+##'
4 
+##' @title read.nhx
5 
+##' @param file nhx file
6 
+##' @return nhx object
7 
+##' @export
8 
+##' @author Guangchuang Yu \url{http://ygc.name}
9 
+read.nhx <- function(file) {
10 
+    treetext <- suppressWarnings(readLines(file))
11 
+    treetext <- treetext[treetext != ""]
12 
+    treetext <- treetext[treetext != " "]
13 
+
14 
+    if (length(treetext) > 1) {
15 
+        treetext <- paste0(treetext, collapse = '')
16 
+    }
17 
+    treetext %<>% gsub(" ", "",. )
18 
+
19 
+    phylo <- read.tree(file)
20 
+    nnode <- phylo$Nnode + Ntip(phylo)
21 
+    nlab <- paste("X", 1:nnode, sep="")
22 
+    tree2 <- treetext
23 
+
24 
+    for (i in 1:nnode) {
25 
+        tree2 <- sub("(\\w+)?(:?\\d*\\.?\\d*[Ee]?[\\+\\-]?\\d*)?\\[&&NHX.*?\\]", paste0("\\", nlab[i], "\\2"), tree2)
26 
+    }
27 
+
28 
+    phylo2 <- read.tree(text = tree2)
29 
+    treeinfo <- fortify(phylo2)
30 
+    node <- as.character(treeinfo$node[match(nlab, treeinfo$label)])
31 
+
32 
+    nhx.matches <- gregexpr("(\\w+)?(:?\\d*\\.?\\d*[Ee]?[\\+\\-]?\\d*)?\\[&&NHX.*?\\]", treetext)
33 
+    matches <- nhx.matches[[1]]
34 
+    match.pos <- as.numeric(matches)
35 
+    match.len <- attr(matches, 'match.length')
36 
+
37 
+    nhx_str <- substring(treetext, match.pos, match.pos+match.len-1)
38 
+
39 
+    ## nhx_features <- gsub("^(\\w+)?:?\\d*\\.?\\d*[Ee]?[\\+\\-]?\\d*", "", nhx_str) %>%
40 
+    nhx_features <- gsub("^[^\\[]*", "", nhx_str) %>%
41 
+        gsub("\\[&&NHX:", "", .) %>%
42 
+            gsub("\\]", "", .)
43 
+
44 
+    nhx_stats <- get_nhx_feature(nhx_features)
45 
+    fields <- names(nhx_stats)
46 
+    for (i in ncol(nhx_stats)) {
47 
+        if(any(grepl("\\D+", nhx_stats[,i])) == FALSE) {
48 
+            ## should be numerical varialbe
49 
+            nhx_stats[,i] <- as.numeric(nhx_stats[,i])
50 
+        }
51 
+    }
52 
+    nhx_stats$node <- node
53 
+
54 
+    new("nhx",
55 
+        file = file,
56 
+        fields = fields,
57 
+        phylo = phylo,
58 
+        nhx_tags = nhx_stats
59 
+        )
60 
+}
61 
+
62 
+
63 
+get_nhx_feature <- function(nhx_features) {
64 
+    nameSET <- strsplit(nhx_features, split=":") %>% unlist %>%
65 
+        gsub("=.*", "", .) %>% unique
66 
+    lapply(nhx_features, get_nhx_feature_internal, nameSET=nameSET) %>%
67 
+        do.call(rbind, .) %>% as.data.frame(., stringsAsFactors = FALSE)
68 
+}
69 
+
70 
+get_nhx_feature_internal <- function(feature, nameSET) {
71 
+    x <- strsplit(feature, ":") %>% unlist
72 
+    name <- gsub("=.*", "", x)
73 
+    val <- gsub(".*=", "", x)
74 
+
75 
+    names(val) <- name
76 
+    y <- character(length(nameSET))
77 
+    for (i in seq_along(nameSET)) {
78 
+        if (nameSET[i] %in% name) {
79 
+            y[i] <- val[nameSET[i]]
80 
+        } else {
81 
+            y[i] <- NA
82 
+        }
83 
+    }
84 
+    names(y) <- nameSET
85 
+    return(y)
86 
+}
87 
+
88 
+
89 
+##' @rdname get.tree-methods
90 
+##' @exportMethod get.tree
91 
+setMethod("get.tree", signature(object = "nhx"),
92 
+          function(object) {
93 
+              object@phylo
94 
+          }
95 
+          )
96 
+
97 
+
98 
+
99 
+
100 
+##' @rdname get.fields-methods
101 
+##' @exportMethod get.fields
102 
+setMethod("get.fields", signature(object="nhx"),
103 
+          function(object, ...) {
104 
+              get.fields.tree(object)
105 
+          }
106 
+          )
R/geom_cladelabel.R
History View file @ 3e4b5998
0 107 
new file mode 100644
... ... 
@@ -0,0 +1,151 @@
1 
+##' annotate a clade with bar and text label
2 
+##'
3 
+##'
4 
+##' @title geom_cladelabel
5 
+##' @param node selected node
6 
+##' @param label clade label
7 
+##' @param offset offset of bar and text from the clade
8 
+##' @param offset.text offset of text from bar
9 
+##' @param align logical
10 
+##' @param barsize size of bar
11 
+##' @param fontsize size of text
12 
+##' @param angle angle of text
13 
+##' @param geom one of 'text' or 'label'
14 
+##' @param fill fill label background, only work with geom='label'
15 
+##' @param ... additional parameter
16 
+##' @return ggplot layers
17 
+##' @export
18 
+##' @author Guangchuang Yu
19 
+geom_cladelabel <- function(node, label, offset=0, offset.text=0,
20 
+                            align=FALSE, barsize=0.5, fontsize=3.88,
21 
+                            angle=0, geom="text", hjust = 0, fill=NA, ...) {
22 
+    mapping <- NULL
23 
+    data <- NULL
24 
+    position <- "identity"
25 
+    show.legend <- NA
26 
+    na.rm <- FALSE
27 
+    inherit.aes <- FALSE
28 
+
29 
+    if (geom == "text") {
30 
+        ## no fill parameter
31 
+        layer_text = stat_cladeText(node=node, label=label, offset=offset+offset.text,
32 
+                                    align=align, size=fontsize, angle=angle,
33 
+                                    mapping=mapping, data=data, geom=geom, hjust=hjust,
34 
+                                    position=position, show.legend = show.legend,
35 
+                                    inherit.aes = inherit.aes, na.rm=na.rm, ...)
36 
+
37 
+    } else {
38 
+        layer_text = stat_cladeText(node=node, label=label, offset=offset+offset.text,
39 
+                                    align=align, size=fontsize, angle=angle, fill=fill,
40 
+                                    mapping=mapping, data=data, geom=geom, hjust=hjust,
41 
+                                    position=position, show.legend = show.legend,
42 
+                                    inherit.aes = inherit.aes, na.rm=na.rm, ...)
43 
+    }
44 
+
45 
+    list(
46 
+        stat_cladeBar(node=node, offset=offset, align=align,
47 
+                      size=barsize,
48 
+                      mapping=mapping, data=data,
49 
+                      position=position, show.legend = show.legend,
50 
+                      inherit.aes = inherit.aes, na.rm=na.rm, ...),
51 
+
52 
+        layer_text
53 
+    )
54 
+}
55 
+
56 
+
57 
+stat_cladeText <- function(mapping=NULL, data=NULL,
58 
+                           geom="text", position="identity",
59 
+                           node, label, offset, align, ...,
60 
+                           show.legend=NA, inherit.aes=FALSE, na.rm=FALSE) {
61 
+    default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent)
62 
+    if (is.null(mapping)) {
63 
+        mapping <- default_aes
64 
+    } else {
65 
+        mapping <- modifyList(mapping, default_aes)
66 
+    }
67 
+
68 
+    layer(stat=StatCladeText,
69 
+          data=data,
70 
+          mapping=mapping,
71 
+          geom=geom,
72 
+          position=position,
73 
+          show.legend = show.legend,
74 
+          inherit.aes = inherit.aes,
75 
+          params=list(node=node,
76 
+                      label=label,
77 
+                      offset=offset,
78 
+                      align=align,
79 
+                      na.rm=na.rm,
80 
+                      ...)
81 
+          )
82 
+
83 
+}
84 
+
85 
+stat_cladeBar <- function(mapping=NULL, data=NULL,
86 
+                          geom="segment", position="identity",
87 
+                          node, offset, align,  ...,
88 
+                          show.legend=NA, inherit.aes=FALSE, na.rm=FALSE) {
89 
+    default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent)
90 
+    if (is.null(mapping)) {
91 
+        mapping <- default_aes
92 
+    } else {
93 
+        mapping <- modifyList(mapping, default_aes)
94 
+    }
95 
+
96 
+    layer(stat=StatCladeBar,
97 
+          data=data,
98 
+          mapping=mapping,
99 
+          geom=geom,
100 
+          position=position,
101 
+          show.legend = show.legend,
102 
+          inherit.aes = inherit.aes,
103 
+          params=list(node=node,
104 
+                      offset=offset,
105 
+                      align=align,
106 
+                      na.rm=na.rm,
107 
+                      ...)
108 
+          )
109 
+
110 
+}
111 
+
112 
+StatCladeText <- ggproto("StatCladeText", Stat,
113 
+                         compute_group = function(self, data, scales, params, node, label, offset, align) {
114 
+                             df <- get_cladelabel_position(data, node, offset, align, adjustRatio = 1.03)
115 
+                             df$y <- mean(c(df$y, df$yend))
116 
+                             df$label <- label
117 
+                             return(df)
118 
+                         },
119 
+                         required_aes = c("x", "y", "label")
120 
+                         )
121 
+
122 
+
123 
+
124 
+StatCladeBar <- ggproto("StatCladBar", Stat,
125 
+                        compute_group = function(self, data, scales, params, node, offset, align) {
126 
+                            get_cladelabel_position(data, node, offset, align, adjustRatio=1.02)
127 
+                        },
128 
+                        required_aes = c("x", "y", "xend", "yend")
129 
+                        )
130 
+
131 
+
132 
+get_cladelabel_position <- function(data, node, offset, align, adjustRatio) {
133 
+    df <- get_cladelabel_position_(data, node)
134 
+    if (align) {
135 
+        mx <- max(data$x)
136 
+    } else {
137 
+        mx <- df$x
138 
+    }
139 
+    mx <- mx * adjustRatio + offset
140 
+    data.frame(x=mx, xend=mx, y=df$y, yend=df$yend)
141 
+}
142 
+
143 
+
144 
+get_cladelabel_position_ <- function(data, node) {
145 
+    sp <- get.offspring.df(data, node)
146 
+    sp.df <- data[c(sp, node),]
147 
+    y <- sp.df$y
148 
+    mx <- max(sp.df$x)
149 
+    data.frame(x=mx, y=min(y), yend=max(y))
150 
+}
151 
+
R/geom_hilight.R
History View file @ 3e4b5998
0 152 
new file mode 100644
... ... 
@@ -0,0 +1,109 @@
1 
+##' layer of hilight clade with rectangle
2 
+##'
3 
+##'
4 
+##' @title geom_hilight
5 
+##' @param node selected node to hilight
6 
+##' @param fill color fill
7 
+##' @param alpha alpha (transparency)
8 
+##' @return ggplot2
9 
+##' @export
10 
+##' @importFrom ggplot2 aes_
11 
+##' @importFrom ggplot2 GeomRect
12 
+##' @author Guangchuang Yu
13 
+geom_hilight <- function(node, fill="steelblue", alpha=.5) {
14 
+
15 
+
16 
+    data=NULL
17 
+    stat="hilight"
18 
+    position="identity"
19 
+    show.legend=NA
20 
+    na.rm=FALSE
21 
+    inherit.aes=FALSE
22 
+
23 
+    default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent, branch.length=~branch.length)
24 
+    mapping <- default_aes
25 
+
26 
+
27 
+    layer(
28 
+        stat=StatHilight,
29 
+        data = data,
30 
+        mapping = mapping,
31 
+        geom = GeomRect,
32 
+        position = position,
33 
+        show.legend=show.legend,
34 
+        inherit.aes = inherit.aes,
35 
+        params = list(node=node,
36 
+            fill=fill, alpha=alpha,
37 
+            na.rm = na.rm)
38 
+    )
39 
+
40 
+}
41 
+
42 
+##' stat_hilight
43 
+##' @rdname geom_hilight
44 
+##' @param geom geometric object
45 
+##' @importFrom ggplot2 layer
46 
+##' @export
47 
+stat_hilight <- function(mapping=NULL, data=NULL, geom="rect",
48 
+                         position="identity",  node,
49 
+                         show.legend=NA, inherit.aes=FALSE,
50 
+                        fill, alpha,
51 
+                         ...) {
52 
+    default_aes <- aes_(x=~x, y=~y, node=~node, parent=~parent, branch.length=~branch.length)
53 
+    if (is.null(mapping)) {
54 
+        mapping <- default_aes
55 
+    } else {
56 
+        mapping <- modifyList(mapping, default_aes)
57 
+    }
58 
+
59 
+    layer(
60 
+        stat=StatHilight,
61 
+        data = data,
62 
+        mapping = mapping,
63 
+        geom = geom,
64 
+        position = position,
65 
+        show.legend=show.legend,
66 
+        inherit.aes = inherit.aes,
67 
+        params = list(node=node,
68 
+            fill=fill, alpha=alpha,
69 
+            ...)
70 
+        )
71 
+}
72 
+
73 
+##' StatHilight
74 
+##' @rdname ggtree-ggproto
75 
+##' @format NULL
76 
+##' @usage NULL
77 
+##' @importFrom ggplot2 Stat
78 
+##' @export
79 
+StatHilight <- ggproto("StatHilight", Stat,
80 
+                       compute_group = function(self, data, scales, params, node) {
81 
+                           get_clade_position_(data, node)
82 
+                       },
83 
+                       required_aes = c("x", "y", "branch.length")
84 
+                       )
85 
+
86 
+
87 
+##' get position of clade (xmin, xmax, ymin, ymax)
88 
+##'
89 
+##'
90 
+##' @title get_clade_position
91 
+##' @param treeview tree view
92 
+##' @param node selected node
93 
+##' @return data.frame
94 
+##' @export
95 
+##' @author Guangchuang Yu
96 
+get_clade_position <- function(treeview, node) {
97 
+    get_clade_position_(treeview$data, node)
98 
+}
99 
+
100 
+get_clade_position_ <- function(data, node) {
101 
+    sp <- get.offspring.df(data, node)
102 
+    sp.df <- data[c(sp, node),]
103 
+    x <- sp.df$x
104 
+    y <- sp.df$y
105 
+    data.frame(xmin=min(x)-data[node, "branch.length"]/2,
106 
+               xmax=max(x),
107 
+               ymin=min(y)-0.5,
108 
+               ymax=max(y)+0.5)
109 
+}
R/geom_treescale.R
History View file @ 3e4b5998
0 110 
new file mode 100644
... ... 
@@ -0,0 +1,179 @@
1 
+##' add tree scale
2 
+##'
3 
+##'
4 
+##' @title geom_treescale
5 
+##' @param x x position
6 
+##' @param y y position
7 
+##' @param width width of scale
8 
+##' @param offset offset of text to line
9 
+##' @param color color
10 
+##' @param linesize size of line
11 
+##' @param fontsize size of text
12 
+##' @return ggplot layers
13 
+##' @export
14 
+##' @author Guangchuang Yu
15 
+geom_treescale <- function(x=NULL, y=NULL, width=NULL, offset=NULL, color="black",
16 
+                           linesize=0.5, fontsize=3.88) {
17 
+
18 
+    data=NULL
19 
+    position="identity"
20 
+    show.legend=NA
21 
+    na.rm=FALSE
22 
+    inherit.aes=FALSE
23 
+
24 
+    default_aes <- aes_(x=~x, y=~y)
25 
+    mapping <- default_aes
26 
+
27 
+    list(
28 
+        stat_treeScaleLine(xx=x, yy=y, width=width, color=color, offset=offset, size=linesize,
29 
+                           mapping=mapping, data=data,
30 
+                           position=position, show.legend = show.legend,
31 
+                           inherit.aes = inherit.aes, na.rm=na.rm),
32 
+        stat_treeScaleText(xx=x, yy=y, width=width, color=color, offset=offset, size=fontsize,
33 
+                           mapping=mapping, data=data,
34 
+                           position=position, show.legend = show.legend,
35 
+                           inherit.aes = inherit.aes, na.rm=na.rm)
36 
+    )
37 
+}
38 
+
39 
+
40 
+
41 
+stat_treeScaleLine <- function(mapping=NULL, data=NULL,
42 
+                           geom="segment", position="identity",
43 
+                           xx, yy, width, offset, color, ...,
44 
+                           show.legend=NA, inherit.aes=FALSE, na.rm=FALSE){
45 
+
46 
+    default_aes <- aes_(x=~x, y=~y)
47 
+    if (is.null(mapping)) {
48 
+        mapping <- default_aes
49 
+    } else {
50 
+        mapping <- modifyList(mapping, default_aes)
51 
+    }
52 
+    layer(
53 
+        stat=StatTreeScaleLine,
54 
+        data=data,
55 
+        mapping=mapping,
56 
+        geom = geom,
57 
+        position=position,
58 
+        show.legend=show.legend,
59 
+        inherit.aes=inherit.aes,
60 
+        params=list(xx=xx,
61 
+                    yy=yy,
62 
+                    width=width,
63 
+                    offset=offset,
64 
+                    color=color,
65 
+                    na.rm=na.rm,
66 
+                    ...)
67 
+    )
68 
+}
69 
+
70 
+stat_treeScaleText <- function(mapping=NULL, data=NULL,
71 
+                               geom="text", position="identity",
72 
+                               xx, yy, width, offset, color, ...,
73 
+                               show.legend=NA, inherit.aes=TRUE, na.rm=FALSE) {
74 
+
75 
+    default_aes <- aes_(x=~x, y=~y)
76 
+    if (is.null(mapping)) {
77 
+        mapping <- default_aes
78 
+    } else {
79 
+        mapping <- modifyList(mapping, default_aes)
80 
+    }
81 
+    layer(
82 
+        stat=StatTreeScaleText,
83 
+        data=data,
84 
+        mapping=mapping,
85 
+        geom=GeomText,
86 
+        position=position,
87 
+        show.legend = show.legend,
88 
+        inherit.aes = inherit.aes,
89 
+        params = list(xx=xx,
90 
+                      yy=yy,
91 
+                      width=width,
92 
+                      offset=offset,
93 
+                      color=color,
94 
+                      na.rm=na.rm,
95 
+                      ...)
96 
+    )
97 
+}
98 
+
99 
+
100 
+StatTreeScaleLine <- ggproto("StatTreeScaleLine", Stat,
101 
+                             compute_group = function(self, data, scales, params, xx, yy, width, offset) {
102 
+                                 get_treescale_position(data, xx, yy, width, offset)[[1]]
103 
+                             },
104 
+                             required_aes = c("x", "y", "xend", "yend")
105 
+                             )
106 
+
107 
+
108 
+StatTreeScaleText <- ggproto("StatTreeScaleText", Stat,
109 
+                             compute_group = function(self, data, scales, params, xx, yy, width, offset) {
110 
+                                 get_treescale_position(data, xx, yy, width, offset)[[2]]
111 
+                             },
112 
+                             required_aes = c("x", "y", "label")
113 
+                             )
114 
+
115 
+
116 
+
117 
+get_treescale_position <- function(data, xx, yy, width, offset=NULL) {
118 
+    x <- xx
119 
+    y <- yy
120 
+    dx <- data$x %>% range %>% diff
121 
+
122 
+    if (is.null(x)) {
123 
+        x <- dx/2
124 
+    }
125 
+
126 
+    if (is.null(y)) {
127 
+        y <- 0
128 
+    }
129 
+
130 
+    if (is.null(width) || is.na(width)) {
131 
+        d <- dx/10
132 
+        n <- 0
133 
+        while (d < 1) {
134 
+            d <- d*10
135 
+            n <- n + 1
136 
+        }
137 
+        d <- floor(d)/(10^n)
138 
+    } else {
139 
+        d <- width
140 
+    }
141 
+
142 
+    if (is.null(offset)) {
143 
+        offset <- 0.4
144 
+    }
145 
+
146 
+    list(LinePosition=data.frame(x=x, xend=x+d, y=y, yend=y),
147 
+         TextPosition=data.frame(x=x+d/2, y=y+offset, label=d))
148 
+}
149 
+
150 
+##' add evolution distance legend
151 
+##'
152 
+##'
153 
+## ##' @title add_legend
154 
+## ##' @param p tree view
155 
+## ##' @param width width of legend
156 
+## ##' @param x x position
157 
+## ##' @param y y position
158 
+## ##' @param offset offset of text and line
159 
+## ##' @param font.size font size
160 
+## ##' @param ... additional parameter
161 
+## ##' @return tree view
162 
+## ##' @importFrom grid linesGrob
163 
+## ##' @importFrom grid textGrob
164 
+## ##' @importFrom grid gpar
165 
+## ##' @importFrom ggplot2 ylim
166 
+## ##' @export
167 
+## ##' @author Guangchuang Yu
168 
+## add_legend <- function(p, width=NULL, x=NULL, y=NULL, offset=NULL, font.size=4, ...) {
169 
+##     dd <- get_treescale_position(p$data, x, y, width, offset)
170 
+##     x <- dd[[1]]$x
171 
+##     y <- dd[[1]]$y
172 
+##     d <- dd[[1]]$xend -x
173 
+##     p <- p + annotation_custom(linesGrob(), xmin=x, xmax=x+d, ymin=y, ymax=y) +
174 
+##         annotation_custom(textGrob(label=d, gp = gpar(fontsize = font.size)),
175 
+##                           xmin=x+d/2, xmax=x+d/2, ymin=y+offset, ymax=y+offset)
176 
+##     return(p)
177 
+## }
178 
+
179 
+
R/method-fortify.R
History View file @ 3e4b5998
0 180 
new file mode 100644
... ... 
@@ -0,0 +1,644 @@
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
8 
+##' @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 
+        cat("The input tree is already binary...\n")
19 
+        invisible(tree)
20 
+    }
21 
+
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]
36 
+        }
37 
+    }
38 
+
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 
+##' @author Guangchuang Yu \url{http://ygc.name}
56 
+rm.singleton.newick <- function(nwk, outfile = NULL) {
57 
+    tree <- readLines(nwk)
58 
+
59 
+    ## remove singleton of tips
60 
+    nodePattern <- "\\w+:[\\.0-9Ee\\+\\-]+"
61 
+    singletonPattern.with.nodename <- paste0(".*(\\(", nodePattern, "\\)\\w+:[\\.0-9Ee\\+\\-]+).*")
62 
+    singletonPattern.wo.nodename <- paste0(".*(\\(", nodePattern, "\\)[\\.0-9Ee\\+\\-]+).*")
63 
+
64 
+    while(length(grep("\\([^,]+\\)", tree)) > 0) {
65 
+        singleton <- gsub(singletonPattern.with.nodename, "\\1", tree)
66 
+        if (singleton == tree) {
67 
+            singleton <- gsub(singletonPattern.wo.nodename, "\\1", tree)
68 
+        }
69 
+        if (singleton == tree) {
70 
+            stop("can't parse singleton node...")
71 
+        }
72 
+
73 
+        tip <- gsub("\\((\\w+).*", "\\1", singleton)
74 
+
75 
+        len1 <- gsub(".*[^\\.0-9Ee\\+\\-]+([\\.0-9Ee\\+\\-]+)", "\\1", singleton)
76 
+        len2 <- gsub(".*:([\\.0-9Ee\\+\\-]+)\\).*", "\\1", singleton)
77 
+        len <- as.numeric(len1) + as.numeric(len2)
78 
+
79 
+        tree <- gsub(singleton, paste0(tip, ":", len), tree, fixed = TRUE)
80 
+    }
81 
+
82 
+    tree <- read.tree(text=tree)
83 
+
84 
+    ### remove singleton of internal nodes
85 
+    p.singleton <- which(table(tree$edge[,1]) == 1)
86 
+    if (length(p.singleton) > 0) {
87 
+        p.singleton %<>% names %>% as.numeric
88 
+        edge <- tree$edge
89 
+        idx <- which(edge[,1] == p.singleton)
90 
+        singleton <- edge[idx, 2]
91 
+        sidx <- which(edge[,1] == singleton)
92 
+        edge[sidx,1] <- p.singleton
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 
+    }
98 
+
99 
+    if (!is.null(outfile)) {
100 
+        write.tree(tree, file=outfile)
101 
+    }
102 
+    invisible(tree)
103 
+}
104 
+
105 
+##' @method fortify beast
106 
+##' @export
107 
+fortify.beast <- function(model, data,
108 
+                          layout    = "rectangular",
109 
+                          yscale    = "none",
110 
+                          ladderize = TRUE,
111 
+                          right     =FALSE,
112 
+                          ndigits   = NULL,
113 
+                          mrsd = NULL, ...) {
114 
+
115 
+    phylo <- get.tree(model)
116 
+    df    <- fortify(phylo, layout=layout,
117 
+                     ladderize=ladderize, right=right, mrsd = mrsd, ...)
118 
+
119 
+    stats <- model@stats
120 
+
121 
+    scn <- colnames(stats)
122 
+    scn <- scn[scn != 'node']
123 
+
124 
+    for (cn in scn) {
125 
+        if (cn %in% colnames(df)) {
126 
+            colnames(stats)[colnames(stats) == cn] <- paste0(cn, "_")
127 
+            msg <- paste("feature", cn, "was renamed to", paste0(cn, "_"), "due to name conflict...")
128 
+            warning(msg)
129 
+        }
130 
+    }
131 
+
132 
+    idx <- which(colnames(stats) != "node")
133 
+    for (ii in idx) {
134 
+        if (is.character_beast(stats, ii)) {
135 
+            len <- sapply(stats[,ii], length)
136 
+            if (any(len > 1)) {
137 
+                stats[,ii] %<>% sapply(., function(x) {
138 
+                    y <- unlist(x) %>% as.character %>%
139 
+                        gsub("\"", "", .) %>% gsub("'", "", .)
140 
+                    if (length(y) == 1) {
141 
+                        return(y)
142 
+                    } else {
143 
+                        return(paste0('{', paste0(y, collapse = ','), '}'))
144 
+                    }
145 
+                })
146 
+            } else {
147 
+                stats[,ii] %<>% unlist %>% as.character %>%
148 
+                    gsub("\"", "", .) %>% gsub("'", "", .)
149 
+            }
150 
+            next
151 
+        }
152 
+
153 
+        len <- sapply(stats[,ii], length)
154 
+        if ( all(len == 1) ) {
155 
+            stats[, ii] %<>% unlist %>% as.character %>% as.numeric
156 
+            if (!is.null(ndigits)) {
157 
+                stats[, ii] %<>% round(., ndigits)
158 
+            }
159 
+        } else if (all(len <= 2)) {
160 
+            stats[, ii] %<>% sapply(., function(x) {
161 
+                y <- unlist(x) %>% as.character %>% as.numeric
162 
+                if (!is.null(ndigits)) {
163 
+                    y %<>% round(., ndigits)
164 
+                }
165 
+                if (length(y) == 1) {
166 
+                    return(y)
167 
+                } else {
168 
+                    return(paste0('[', paste0(y, collapse = ','), ']'))
169 
+                }
170 
+            })
171 
+        } else {
172 
+            stats[,ii] %<>% sapply(., function(x) {
173 
+                y <- unlist(x) %>% as.character %>% as.numeric
174 
+                if (!is.null(ndigits)) {
175 
+                    y %<>% round(., ndigits)
176 
+                }
177 
+                if (length(y) == 1) {
178 
+                    return(y)
179 
+                } else {
180 
+                    return(paste0('{', paste0(y, collapse = ','), '}'))
181 
+                }
182 
+            })
183 
+        }
184 
+    }
185 
+
186 
+
187 
+    cn <- colnames(stats)
188 
+    lo <- cn[grep("_lower", cn)]
189 
+    hi <- gsub("lower$", "upper", lo)
190 
+    rid <- gsub("_lower$", "", lo)
191 
+
192 
+    for (i in seq_along(rid)) {
193 
+        stats[, rid[i]] <- paste0("[", stats[, lo[i]], ",", stats[, hi[i]], "]")
194 
+        stats[is.na(stats[, lo[i]]), rid[i]] <- NA
195 
+    }
196 
+
197 
+    idx   <- match(df$node, stats$node)
198 
+    stats <- stats[idx,]
199 
+    cn_stats <- colnames(stats)
200 
+    stats <- stats[, cn_stats != "node"]
201 
+
202 
+    df <- cbind(df, stats)
203 
+    if (is(stats, "data.frame") == FALSE) {
204 
+        colnames(df)[colnames(df) == "stats"] <- cn_stats[cn_stats != "node"]
205 
+    }
206 
+
207 
+    df <- scaleY(phylo, df, yscale, layout, ...)
208 
+
209 
+    append_extraInfo(df, model)
210 
+}
211 
+
212 
+scaleX_by_time_from_mrsd <- function(df, mrsd) {
213 
+    mrsd %<>% as.Date
214 
+    date <- Date2decimal(mrsd)
215 
+
216 
+    df$x <- df$x + date - max(df$x)
217 
+    df$branch <- (df[df$parent, "x"] + df[, "x"])/2
218 
+
219 
+    df$x <- decimal2Date(df$x)
220 
+    df$branch <- decimal2Date(df$branch)
221 
+    return(df)
222 
+
223 
+}
224 
+
225 
+
226 
+scaleX_by_time <- function(df) {
227 
+    time <- with(df, gsub(".*[_/]{1}(\\d+\\.*\\d+)$", "\\1", label[isTip])) %>% as.numeric
228 
+    latest <- which.max(time)
229 
+
230 
+    scaleX_by_time_from_mrsd(df, decimal2Date(time[latest]))
231 
+}
232 
+
233 
+##' @method fortify codeml
234 
+##' @export
235 
+fortify.codeml <- function(model, data,
236 
+                           layout        = "rectangular",
237 
+                           yscale        = "none",
238 
+                           ladderize     = TRUE,
239 
+                           right         = FALSE,
240 
+                           branch.length = "mlc.branch.length",
241 
+                           ndigits       = NULL,
242 
+                           mrsd          = NULL,
243 
+                           ...) {
244 
+
245 
+    dNdS <- model@mlc@dNdS
246 
+    if (branch.length == "branch.length") {
247 
+        message("branch.length setting to mlc.branch.length by default...")
248 
+        branch.length <- "mlc.branch.length"
249 
+    }
250 
+    length <- match.arg(branch.length,
251 
+                        c("none",
252 
+                          "mlc.branch.length",
253 
+                          "rst.branch.length",
254 
+                          colnames(dNdS)[-c(1,2)])
255 
+                        )
256 
+
257 
+    if (length == "rst.branch.length") {
258 
+        phylo <- get.tree(model@rst)
259 
+    } else {
260 
+        if (length == "mlc.branch.length") {
261 
+            length = "branch.length"
262 
+        }
263 
+        phylo <- fortify.codeml_mlc_(model@mlc, data, layout,
264 
+                                     ladderize, right,
265 
+                                     branch.length = length, ...)
266 
+    }
267 
+
268 
+    df <- fortify(phylo, data, layout, ladderize, right,
269 
+                  branch.length=length, mrsd=mrsd, ...)
270 
+
271 
+    res <- merge_phylo_anno.codeml_mlc(df, dNdS, ndigits)
272 
+    df <- merge_phylo_anno.paml_rst(res, model@rst)
273 
+    df <- scaleY(phylo, df, yscale, layout, ...)
274 
+
275 
+    append_extraInfo(df, model)
276 
+}
277 
+
278 
+
279 
+##' @method fortify codeml_mlc
280 
+##' @export
281 
+fortify.codeml_mlc <- function(model, data,
282 
+                               layout        = "rectangular",
283 
+                               yscale        = "none",
284 
+                               ladderize     = TRUE,
285 
+                               right         = FALSE,
286 
+                               branch.length = "branch.length",
287 
+                               ndigits       = NULL,
288 
+                               mrsd          = NULL,
289 
+                               ...) {
290 
+
291 
+    phylo <- fortify.codeml_mlc_(model, data, layout,
292 
+                                 ladderize, right,
293 
+                                 branch.length, mrsd=mrsd, ...)
294 
+    df <- fortify(phylo, data, layout, ladderize, right, branch.length=branch.length, ...)
295 
+
296 
+    dNdS <- model@dNdS
297 
+
298 
+    df <- merge_phylo_anno.codeml_mlc(df, dNdS, ndigits)
299 
+    df <- scaleY(phylo, df, yscale, layout, ...)
300 
+
301 
+    append_extraInfo(df, model)
302 
+}
303 
+
304 
+merge_phylo_anno.codeml_mlc <- function(df, dNdS, ndigits = NULL) {
305 
+    if (!is.null(ndigits)) {
306 
+        idx <- which(! colnames(dNdS) %in% c("node", "parent"))
307 
+        for (ii in idx) {
308 
+            if (is.numeric(dNdS[, ii])) {
309 
+                dNdS[, ii] <- round(dNdS[,ii], ndigits)
310 
+            }
311 
+        }
312 
+    }
313 
+
314 
+    res <- merge(df, dNdS,
315 
+                 by.x  = c("node", "parent"),
316 
+                 by.y  = c("node", "parent"),
317 
+                 all.x = TRUE)
318 
+
319 
+    res[match(df$node, res$node),]
320 
+}
321 
+
322 
+fortify.codeml_mlc_ <- function(model, data,
323 
+                                layout        = "rectangular",
324 
+                                ladderize     = TRUE,
325 
+                                right         = FALSE,
326 
+                                branch.length = "branch.length",
327 
+                                ...) {
328 
+    dNdS <- model@dNdS
329 
+    length <- match.arg(branch.length, c("none", "branch.length",
330 
+                                         colnames(dNdS)[-c(1,2)]))
331 
+    phylo <- get.tree(model)
332 
+
333 
+    if (! length %in%  c("branch.length", "none")) {
334 
+        edge <- as.data.frame(phylo$edge)
335 
+        colnames(edge) <- c("parent", "node")
336 
+
337 
+        dd <- merge(edge, dNdS,
338 
+                    by.x  = c("node", "parent"),
339 
+                    by.y  = c("node", "parent"),
340 
+                    all.x = TRUE)
341 
+        dd <- dd[match(edge$node, dd$node),]
342 
+        phylo$edge.length <- dd[, length]
343 
+    }
344 
+
345 
+    return(phylo)
346 
+}
347 
+
348 
+
349 
+##' @method fortify paml_rst
350 
+##' @export
351 
+fortify.paml_rst <- function(model, data, layout = "rectangular", yscale="none",
352 
+                             ladderize=TRUE, right=FALSE, mrsd=NULL, ...) {
353 
+    df <- fortify.phylo(model@phylo, data, layout, ladderize, right, mrsd=mrsd, ...)
354 
+    df <- merge_phylo_anno.paml_rst(df, model)
355 
+    df <- scaleY(model@phylo, df, yscale, layout, ...)
356 
+
357 
+    append_extraInfo(df, model)
358 
+}
359 
+
360 
+merge_phylo_anno.paml_rst <- function(df, model) {
361 
+    for (type in get.fields(model)) {
362 
+        anno <- get.subs(model, type=type)
363 
+        colnames(anno)[2] <- type
364 
+        df <- df %add2% anno
365 
+    }
366 
+    return(df)
367 
+}
368 
+
369 
+
370 
+##' @method fortify phangorn
371 
+##' @export
372 
+fortify.phangorn <- fortify.paml_rst
373 
+
374 
+
375 
+##' @method fortify hyphy
376 
+##' @export
377 
+fortify.hyphy <- fortify.paml_rst
378 
+
379 
+
380 
+##' @method fortify jplace
381 
+##' @importFrom ape read.tree
382 
+##' @export
383 
+fortify.jplace <- function(model, data,
384 
+                           layout="rectangular", yscale="none",
385 
+                           ladderize=TRUE, right=FALSE, mrsd=NULL, ...) {
386 
+    df <- get.treeinfo(model, layout, ladderize, right, mrsd=mrsd, ...)
387 
+    place <- get.placements(model, by="best")
388 
+
389 
+    df <- df %add2% place
390 
+
391 
+    df <- scaleY(model@phylo, df, yscale, layout, ...)
392 
+
393 
+    append_extraInfo(df, model)
394 
+}
395 
+
396 
+scaleY <- function(phylo, df, yscale, layout, ...) {
397 
+    if (yscale == "none") {
398 
+        return(df)
399 
+    }
400 
+    if (! yscale %in% colnames(df)) {
401 
+        warning("yscale is not available...\n")
402 
+        return(df)
403 
+    }
404 
+    if (is.numeric(df[, yscale])) {
405 
+        y <- getYcoord_scale_numeric(phylo, df, yscale, ...)
406 
+        ## if (order.y) {
407 
+        ##     y <- getYcoord_scale2(phylo, df, yscale)
408 
+        ## } else {
409 
+        ##     y <- getYcoord_scale(phylo, df, yscale)
410 
+        ## }
411 
+    } else {
412 
+        y <- getYcoord_scale_category(phylo, df, yscale, ...)
413 
+    }
414 
+
415 
+    df[, "y"] <- y
416 
+
417 
+    return(df)
418 
+}
419 
+
420 
+
421 
+##' @method fortify phylo4
422 
+##' @export
423 
+fortify.phylo4 <- function(model, data, layout="rectangular", yscale="none",
424 
+                           ladderize=TRUE, right=FALSE, mrsd=NULL, ...) {
425 
+    phylo <- as.phylo.phylo4(model)
426 
+    df <- fortify.phylo(phylo, data,
427 
+                        layout, ladderize, right, mrsd=mrsd, ...)
428 
+    scaleY(phylo, df, yscale, layout, ...)
429 
+}
430 
+
431 
+as.phylo.phylo4 <- function(phylo4) {
432 
+    edge <- phylo4@edge
433 
+    edge <- edge[edge[,1] != 0, ]
434 
+    edge.length <- phylo4@edge.length
435 
+    edge.length <- edge.length[!is.na(edge.length)]
436 
+    tip.id <- sort(setdiff(edge[,2], edge[,1]))
437 
+    tip.label <- phylo4@label[tip.id]
438 
+    phylo <- list(edge = edge,
439 
+                  edge.length = edge.length,
440 
+                  tip.label = tip.label)
441 
+
442 
+    node.id <- sort(unique(edge[,1]))
443 
+    node.id <- node.id[node.id != 0]
444 
+    node.label <- phylo4@label[node.id]
445 
+    if (!all(is.na(node.label))) {
446 
+        phylo$node.label <- node.label
447 
+    }
448 
+    phylo$Nnode <- length(node.id)
449 
+    class(phylo) <- "phylo"
450 
+    return(phylo)
451 
+}
452 
+
453 
+##' fortify a phylo to data.frame
454 
+##'
455 
+##'
456 
+##' @rdname fortify
457 
+##' @title fortify
458 
+##' @param model phylo object
459 
+##' @param data not use here
460 
+##' @param layout layout
461 
+##' @param ladderize ladderize, logical
462 
+##' @param right logical
463 
+##' @param mrsd most recent sampling date
464 
+##' @param as.Date logical whether using Date class in time tree
465 
+##' @param ... additional parameter
466 
+##' @return data.frame
467 
+##' @importFrom ape ladderize
468 
+##' @importFrom ggplot2 fortify
469 
+##' @method fortify phylo
470 
+##' @export
471 
+##' @author Yu Guangchuang
472 
+fortify.phylo <- function(model, data, layout="rectangular",
473 
+                          ladderize=TRUE, right=FALSE, mrsd=NULL, as.Date=FALSE, ...) {
474 
+    if (ladderize == TRUE) {
475 
+        tree <- ladderize(model, right=right)
476 
+    } else {
477 
+        tree <- model
478 
+    }
479 
+
480 
+    df <- as.data.frame(tree, layout=layout, ...)
481 
+    idx <- is.na(df$parent)
482 
+    df$parent[idx] <- df$node[idx]
483 
+    rownames(df) <- df$node
484 
+    cn <- colnames(df)
485 
+    colnames(df)[grep("length", cn)] <- "branch.length"
486 
+    if(layout == "slanted") {
487 
+        df <- add_angle_slanted(df)
488 
+    }
489 
+    aa <- names(attributes(tree))
490 
+    group <- aa[ ! aa %in% c("names", "class", "order", "reroot", "node_map")]
491 
+    if (length(group) > 0) {
492 
+        for (group_ in group) {
493 
+            ## groupOTU & groupClade
494 
+            group_info <- attr(tree, group_)
495 
+            if (length(group_info) == nrow(df)) {
496 
+                df[, group_] <- group_info
497 
+            }
498 
+        }
499 
+    }
500 
+
501 
+    if (!is.null(mrsd)) {
502 
+        df <- scaleX_by_time_from_mrsd(df, mrsd)
503 
+        if (!as.Date) {
504 
+            df$x <- Date2decimal(df$x)
505 
+            df$branch <- Date2decimal(df$branch)
506 
+        }
507 
+    }
508 
+    return(df)
509 
+}
510 
+
511 
+##' convert phylo to data.frame
512 
+##'
513 
+##'
514 
+##' @title as.data.frame
515 
+##' @param x phylo object
516 
+##' @param row.names omitted here
517 
+##' @param optional omitted here
518 
+##' @param layout layout
519 
+##' @param ... additional parameter
520 
+##' @return data.frame
521 
+##' @method as.data.frame phylo
522 
+##' @export
523 
+##' @author Yu Guangchuang
524 
+as.data.frame.phylo <- function(x, row.names, optional,
525 
+                                layout="rectangular", ...) {
526 
+    if (layout == "unrooted") {
527 
+        return(layout.unrooted(x))
528 
+    }
529 
+    as.data.frame.phylo_(x, layout, ...)
530 
+}
531 
+
532 
+as.data.frame.phylo_ <- function(x, layout="rectangular",
533 
+                                 branch.length="branch.length", ...) {
534 
+    tip.label <- x[["tip.label"]]
535 
+    Ntip <- length(tip.label)
536 
+    N <- getNodeNum(x)
537 
+
538 
+    edge <- as.data.frame(x[["edge"]])
539 
+    colnames(edge) <- c("parent", "node")
540 
+    if (! is.null(x$edge.length)) {
541 
+        edge$length <- x$edge.length
542 
+        if (branch.length == "none") {
543 
+            xpos <- getXcoord_no_length(x)
544 
+            ypos <- getYcoord(x)
545 
+        } else {
546 
+            xpos <- getXcoord(x)
547 
+            ypos <- getYcoord(x)
548 
+        }
549 
+        ## } else  if (layout != "cladogram") {
550 
+        ##     xpos <- getXcoord(x)
551 
+        ##     ypos <- getYcoord(x)
552 
+        ## } else {
553 
+        ##     ## layout == "cladogram" && branch.length != "none"
554 
+        ##     xy <- getXYcoord_cladogram(x)
555 
+        ##     xpos <- xy$x
556 
+        ##     ypos <- xy$y
557 
+        ## }
558 
+    } else {
559 
+        xpos <- getXcoord_no_length(x)
560 
+        ypos <- getYcoord(x)
561 
+    }
562 
+
563 
+    xypos <- data.frame(node=1:N, x=xpos, y=ypos)
564 
+
565 
+    res <- merge(edge, xypos, by.x="node", by.y="node", all.y=TRUE)
566 
+    label <- rep(NA, N)
567 
+    label[1:Ntip] <- tip.label
568 
+    if ( !is.null(x$node.label) ) {
569 
+        label[(Ntip+1):N] <- x$node.label
570 
+    }
571 
+    res$label <- label
572 
+    isTip <- rep(FALSE, N)
573 
+    isTip[1:Ntip] <- TRUE
574 
+    res$isTip <- isTip
575 
+
576 
+    ## add branch mid position
577 
+    res <- calculate_branch_mid(res)
578 
+
579 
+    ## angle for all layout, if 'rectangular', user use coord_polar, can still use angle
580 
+    ## if (layout == "circular") {
581 
+    idx <- match(1:N, order(res$y))
582 
+    angle <- -360/(1+N) * (1:N+1)
583 
+    angle <- angle[idx]
584 
+    res$angle <- angle + 90
585 
+    ## }
586 
+
587 
+    return(res)
588 
+}
589 
+
590 
+##' @method fortify nhx
591 
+##' @export
592 
+fortify.nhx <- function(model, data, layout= "rectangular",
593 
+                        ladderize=TRUE, right=FALSE, mrsd=NULL, ...) {
594 
+    df <- fortify(get.tree(model), layout=layout, ladderize=ladderize, right=right, mrsd=mrsd, ...)
595 
+    df <- merge(df, model@nhx_tags, by.x="node", by.y="node", all.x=TRUE)
596 
+    append_extraInfo(df, model)
597 
+}
598 
+
599 
+
600 
+##' @method fortify raxml
601 
+##' @export
602 
+fortify.raxml <- function(model, data, layout= "rectangular",
603 
+                          ladderize=TRUE, right=FALSE, mrsd=NULL, ...) {
604 
+    df <- fortify(get.tree(model), layout=layout, ladderize=ladderize, right=right, mrsd=mrsd, ...)
605 
+    df <- merge(df, model@bootstrap, by.x="node", by.y="node", all.x=TRUE)
606 
+    append_extraInfo(df, model)
607 
+}
608 
+
609 
+##' @method fortify apeBootstrap
610 
+##' @export
611 
+fortify.apeBootstrap <- fortify.raxml
612 
+
613 
+
614 
+##' @method fortify multiPhylo
615 
+##' @export
616 
+fortify.multiPhylo <-  function(model, data, layout="rectangular",
617 
+                                ladderize=TRUE, right=FALSE, mrsd=NULL, ...) {
618 
+
619 
+    df.list <- lapply(model, function(x) fortify(x, layout=layout, ladderize=ladderize, right=right, mrsd=mrsd, ...))
620 
+    if (is.null(names(model))) {
621 
+        names(df.list) <- paste0("Tree ", "#", seq_along(model))
622 
+    } else {
623 
+        names(df.list) <- names(model)
624 
+    }
625 
+    df <- do.call("rbind", df.list)
626 
+    df$.id <- rep(names(df.list), times=sapply(df.list, nrow))
627 
+    df$.id <- factor(df$.id, levels=names(df.list))
628 
+
629 
+    nNode <- sapply(df.list, nrow)
630 
+    nNode2 <- cumsum(nNode) - nNode[1]
631 
+    df$parent <- df$parent + rep(nNode2, times=nNode)
632 
+    return(df)
633 
+}
634 
+
635 
+##' @method fortify r8s
636 
+##' @export
637 
+fortify.r8s <- function(model, data, layout="rectangular",
638 
+                        ladderize=TRUE, right=FALSE,
639 
+                        branch.length = "TREE", mrsd=NULL, ...) {
640 
+    trees <- get.tree(model)
641 
+    branch.length %<>% match.arg(names(trees))
642 
+    phylo <- trees[[branch.length]]
643 
+    fortify(phylo, layout=layout, ladderize = ladderize, right=right, mrsd=mrsd, ...)
644 
+}
R/method-groupClade.R
History View file @ 3e4b5998
0 645 
new file mode 100644
... ... 
@@ -0,0 +1,11 @@
1 
+##' group selected clade
2 
+##'
3 
+##'
4 
+##' @rdname groupClade-methods
5 
+##' @exportMethod groupClade
6 
+setMethod("groupClade", signature(object="nhx"),
7 
+          function(object, node, group_name="group") {
8 
+              groupClade_(object, node, group_name)
9 
+          })
10 
+
11 
+
R/method-groupOTU.R
History View file @ 3e4b5998
0 12 
new file mode 100644
... ... 
@@ -0,0 +1,85 @@
1 
+##' group tree based on selected OTU, will traceback to MRCA
2 
+##'
3 
+##'
4 
+##' @rdname groupOTU-methods
5 
+##' @exportMethod groupOTU
6 
+setMethod("groupOTU", signature(object="phylo"),
7 
+          function(object, focus, group_name="group") {
8 
+              groupOTU.phylo(object, focus, group_name)
9 
+          })
10 
+
11 
+##' @rdname groupOTU-methods
12 
+##' @exportMethod groupOTU
13 
+setMethod("groupOTU", signature(object="apeBootstrap"),
14 
+          function(object, focus, group_name="group") {
15 
+              groupOTU_(object, focus, group_name)
16 
+          }
17 
+          )
18 
+
19 
+##' @rdname groupOTU-methods
20 
+##' @exportMethod groupOTU
21 
+setMethod("groupOTU", signature(object="beast"),
22 
+          function(object, focus, group_name="group") {
23 
+              groupOTU_(object, focus, group_name)
24 
+          }
25 
+          )
26 
+
27 
+##' @rdname groupOTU-methods
28 
+##' @exportMethod groupOTU
29 
+setMethod("groupOTU", signature(object="codeml"),
30 
+          function(object, focus, group_name="group") {
31 
+              groupOTU_(object, focus, group_name)
32 
+          }
33 
+          )
34 
+
35 
+
36 
+##' @rdname groupOTU-methods
37 
+##' @exportMethod groupOTU
38 
+setMethod("groupOTU", signature(object="codeml_mlc"),
39 
+          function(object, focus, group_name="group") {
40 
+              groupOTU_(object, focus, group_name)
41 
+          }
42 
+          )
43 
+
44 
+##' @rdname groupOTU-methods
45 
+##' @exportMethod groupOTU
46 
+setMethod("groupOTU", signature(object="nhx"),
47 
+          function(object, focus, group_name="group") {
48 
+              groupOTU_(object, focus, group_name)
49 
+          }
50 
+          )
51 
+
52 
+
53 
+##' @rdname groupOTU-methods
54 
+##' @exportMethod groupOTU
55 
+setMethod("groupOTU", signature(object="paml_rst"),
56 
+          function(object, focus, group_name="group") {
57 
+              groupOTU_(object, focus, group_name)
58 
+          }
59 
+          )
60 
+
61 
+
62 
+
63 
+
64 
+##' @rdname groupOTU-methods
65 
+##' @exportMethod groupOTU
66 
+setMethod("groupOTU", signature(object="phangorn"),
67 
+          function(object, focus, group_name="group") {
68 
+              groupOTU_(object, focus, group_name)
69 
+          }
70 
+          )
71 
+
72 
+
73 
+##' @rdname groupOTU-methods
74 
+##' @exportMethod groupOTU
75 
+##' @param tree which tree selected
76 
+setMethod("groupOTU", signature(object="r8s"),
77 
+          function(object, focus, group_name="group", tree="TREE") {
78 
+              groupOTU_(get.tree(object)[[tree]], focus, group_name)
79 
+          }
80 
+          )
81 
+
82 
+
83 
+
84 
+
85 
+
R/method-gzoom.R
History View file @ 3e4b5998
0 86 
new file mode 100644
... ... 
@@ -0,0 +1,33 @@
1 
+##' zoom selected subtree
2 
+##'
3 
+##'
4 
+##' @rdname gzoom-methods
5 
+##' @exportMethod gzoom
6 
+setMethod("gzoom", signature(object="beast"),
7 
+          function(object, focus, subtree=FALSE, widths=c(.3, .7)) {
8 
+              gzoom.phylo(get.tree(object), focus, subtree, widths)
9 
+          })
10 
+
11 
+
12 
+##' @rdname gzoom-methods
13 
+##' @exportMethod gzoom
14 
+setMethod("gzoom", signature(object="nhx"),
15 
+          function(object, focus, subtree=FALSE, widths=c(.3, .7)) {
16 
+              gzoom.phylo(get.tree(object), focus, subtree, widths)
17 
+          })
18 
+
19 
+
20 
+##' @rdname gzoom-methods
21 
+##' @exportMethod gzoom
22 
+setMethod("gzoom", signature(object="paml_rst"),
23 
+          function(object, focus, subtree=FALSE, widths=c(.3, .7)) {
24 
+              gzoom.phylo(get.tree(object), focus, subtree, widths)
25 
+          })
26 
+
27 
+
28 
+##' @rdname gzoom-methods
29 
+##' @exportMethod gzoom