1. ggtree
  2. R
  3. phangorn.R
Browse code

clean up code

guangchuang yu authored on 14/12/2017 08:47:21
Showing 1 changed files
R/phangorn.R
History View file @ 14ff9149
1 1 
deleted file mode 100644
... ... 
@@ -1,174 +0,0 @@
1 
-## ##' tree annotation of sequence substitution by comparing to parent node
2 
-## ##'
3 
-## ##'
4 
-## ##' @title treeAnno.pml
5 
-## ##' @param pmlTree tree in pml object, output of phangorn::optim.pml
6 
-## ##' @param type one of 'ml' and 'bayes' for inferring ancestral sequences
7 
-## ##' @return phangorn object
8 
-## ##' @importFrom ape read.tree
9 
-## ##' @importFrom ape reorder.phylo
10 
-## ##' @export
11 
-## ##' @author Yu Guangchuang
12 
-## phyPML <- function(pmlTree, type = "ml") {
13 
-##     sequences <- pmlToSeqString(pmlTree, type, includeAncestor=TRUE)
14 
-##     tr <- pmlTree$tree
15 
-##     tr <- reorder.phylo(tr)
16 
-
17 
-##     if (is.null(tr$node.label)) {
18 
-##         n <- length(tr$tip.label)
19 
-##         nl <- (n+1):(2*n-2)
20 
-##         tr$node.label <- as.character(nl)
21 
-##     } else {
22 
-##         names(sequences) <- c(tr$tip.label, tr$node.label)
23 
-##     }
24 
-
25 
-##     seq_type <- get_seqtype(sequences)
26 
-##     res <- new("phangorn",
27 
-##                phylo = tr,
28 
-##                fields = "subs",
29 
-##                seq_type = seq_type,
30 
-##                ancseq = sequences)
31 
-
32 
-
33 
-##     res@tip_seq <- sequences[names(sequences) %in% tr$tip.label]
34 
-
35 
-##     res@subs <- get.subs_(res@phylo, sequences, translate=FALSE)
36 
-##     if (seq_type == "NT") {
37 
-##         res@AA_subs <- get.subs_(res@phylo, sequences, translate=TRUE)
38 
-##         res@fields %<>% c("AA_subs")
39 
-##     }
40 
-
41 
-##     return(res)
42 
-## }
43 
-
44 
-
45 
-
46 
-
47 
-## ##' @rdname get.subs-methods
48 
-## ##' @exportMethod get.subs
49 
-## setMethod("get.subs", signature(object = "phangorn"),
50 
-##           function(object, type, ...) {
51 
-##               if (type == "AA_subs")
52 
-##                   return(object@AA_subs)
53 
-##               return(object@subs)
54 
-##           }
55 
-##           )
56 
-
57 
-
58 
-## ##' @rdname groupClade-methods
59 
-## ##' @exportMethod groupClade
60 
-## setMethod("groupClade", signature(object="phangorn"),
61 
-##           function(object, node, group_name="group") {
62 
-##               groupClade_(object, node, group_name)
63 
-##           })
64 
-
65 
-## ##' @rdname scale_color-methods
66 
-## ##' @exportMethod scale_color
67 
-## setMethod("scale_color", signature(object="phangorn"),
68 
-##           function(object, by, ...) {
69 
-##               scale_color_(object, by, ...)
70 
-##           })
71 
-
72 
-
73 
-## ##' @rdname gzoom-methods
74 
-## ##' @exportMethod gzoom
75 
-## setMethod("gzoom", signature(object="phangorn"),
76 
-##           function(object, focus, subtree=FALSE, widths=c(.3, .7)) {
77 
-##               gzoom.phylo(get.tree(object), focus, subtree, widths)
78 
-##           })
79 
-
80 
-
81 
-## ##' @rdname get.tree-methods
82 
-## ##' @exportMethod get.tree
83 
-## setMethod("get.tree", signature(object="phangorn"),
84 
-##           function(object,...) {
85 
-##               object@phylo
86 
-##           }
87 
-##           )
88 
-
89 
-
90 
-## ##' @rdname get.fields-methods
91 
-## ##' @exportMethod get.fields
92 
-## setMethod("get.fields", signature(object="phangorn"),
93 
-##           function(object, ...) {
94 
-##               get.fields.tree(object)
95 
-##           }
96 
-##           )
97 
-
98 
-
99 
-## ##' convert pml object to XStringSet object
100 
-## ##'
101 
-## ##'
102 
-## ##' @title pmlToSeq
103 
-## ##' @param pml pml object
104 
-## ##' @param includeAncestor logical
105 
-## ##' @param type one of "marginal", "ml", "bayes"
106 
-## ##' @return XStringSet
107 
-## ## @importFrom Biostrings DNAStringSet
108 
-## ##' @export
109 
-## ##' @author ygc
110 
-## pmlToSeq <- function(pml, type="ml", includeAncestor=TRUE) {
111 
-##     DNAStringSet <- get_fun_from_pkg("Biostrings", "DNAStringSet")
112 
-##     pmlToSeqString(pml, type, includeAncestor) %>%
113 
-##         DNAStringSet
114 
-## }
115 
-
116 
-## ## @importFrom phangorn ancestral.pml
117 
-## pmlToSeqString <- function(pml, type, includeAncestor=TRUE) {
118 
-##     if (includeAncestor == FALSE) {
119 
-##         phyDat <- pml$data
120 
-##     } else {
121 
-##         ancestral.pml <- get_fun_from_pkg("phangorn", "ancestral.pml")
122 
-##         phyDat <- ancestral.pml(pml, type)
123 
-##     }
124 
-
125 
-##     phyDat <- matrix2vector.phyDat(phyDat)
126 
-##     ## defined by phangorn
127 
-##     labels <- c("a", "c", "g", "t", "u", "m", "r", "w", "s",
128 
-##                 "y", "k", "v", "h", "d", "b", "n", "?", "-")
129 
-##     labels <- toupper(labels)
130 
-
131 
-##     index <- attr(phyDat, "index")
132 
-
133 
-##     result <- do.call(rbind, phyDat)
134 
-##     result <- result[, index, drop=FALSE]
135 
-
136 
-##     res <- apply(result, 2, function(i) labels[i])
137 
-##     res <- apply(res, 1, paste, collapse="")
138 
-##     names(res) <- rownames(result)
139 
-##     return(res)
140 
-## }
141 
-
142 
-
143 
-
144 
-## matrix2vector.phyDat <- function(x) {
145 
-##     index <- attr(x, "index")
146 
-##     res <- lapply(x, matrix2vector.phyDat.item)
147 
-##     names(res) <- names(x)
148 
-##     attr(res, "index") <- index
149 
-##     class(res) <- "phyDat"
150 
-##     return(res)
151 
-## }
152 
-
153 
-## matrix2vector.phyDat.item <- function(y) {
154 
-##     ii <- apply(y, 1, function(xx) {
155 
-##         ## return index of a c g and t, if it has highest probability
156 
-##         ## otherwise return index of -
157 
-##         jj <- which(xx == max(xx))
158 
-##         if ( length(jj) > 1) {
159 
-##             if (length(jj) < 4) {
160 
-##                 warning("ambiguous found...\n")
161 
-##             } else {
162 
-##                 ## cat("insertion found...\n")
163 
-##             }
164 
-##             ## 18 is the gap(-) index of base character defined in phangorn
165 
-##             ## c("a", "c", "g", "t", "u", "m", "r", "w", "s",
166 
-## 	    ##   "y", "k", "v", "h", "d", "b", "n", "?", "-")
167 
-##             18
168 
-##         } else {
169 
-##             jj
170 
-##         }
171 
-##     })
172 
-##     unlist(ii)
173 
-## }
174 
-
Browse code

depends treeio

GuangchuangYu authored on 20/12/2016 16:39:07
Showing 1 changed files
R/phangorn.R
History View file @ 817c093d
... ... 
@@ -1,174 +1,174 @@
1 
-##' tree annotation of sequence substitution by comparing to parent node
2 
-##'
3 
-##'
4 
-##' @title treeAnno.pml
5 
-##' @param pmlTree tree in pml object, output of phangorn::optim.pml
6 
-##' @param type one of 'ml' and 'bayes' for inferring ancestral sequences
7 
-##' @return phangorn object
8 
-##' @importFrom ape read.tree
9 
-##' @importFrom ape reorder.phylo
10 
-##' @export
11 
-##' @author Yu Guangchuang
12 
-phyPML <- function(pmlTree, type = "ml") {
13 
-    sequences <- pmlToSeqString(pmlTree, type, includeAncestor=TRUE)
14 
-    tr <- pmlTree$tree
15 
-    tr <- reorder.phylo(tr)
16 
-
17 
-    if (is.null(tr$node.label)) {
18 
-        n <- length(tr$tip.label)
19 
-        nl <- (n+1):(2*n-2)
20 
-        tr$node.label <- as.character(nl)
21 
-    } else {
22 
-        names(sequences) <- c(tr$tip.label, tr$node.label)
23 
-    }
24 
-
25 
-    seq_type <- get_seqtype(sequences)
26 
-    res <- new("phangorn",
27 
-               phylo = tr,
28 
-               fields = "subs",
29 
-               seq_type = seq_type,
30 
-               ancseq = sequences)
31 
-
32 
-
33 
-    res@tip_seq <- sequences[names(sequences) %in% tr$tip.label]
34 
-
35 
-    res@subs <- get.subs_(res@phylo, sequences, translate=FALSE)
36 
-    if (seq_type == "NT") {
37 
-        res@AA_subs <- get.subs_(res@phylo, sequences, translate=TRUE)
38 
-        res@fields %<>% c("AA_subs")
39 
-    }
40 
-
41 
-    return(res)
42 
-}
43 
-
44 
-
45 
-
46 
-
47 
-##' @rdname get.subs-methods
48 
-##' @exportMethod get.subs
49 
-setMethod("get.subs", signature(object = "phangorn"),
50 
-          function(object, type, ...) {
51 
-              if (type == "AA_subs")
52 
-                  return(object@AA_subs)
53 
-              return(object@subs)
54 
-          }
55 
-          )
56 
-
57 
-
58 
-##' @rdname groupClade-methods
59 
-##' @exportMethod groupClade
60 
-setMethod("groupClade", signature(object="phangorn"),
61 
-          function(object, node, group_name="group") {
62 
-              groupClade_(object, node, group_name)
63 
-          })
64 
-
65 
-##' @rdname scale_color-methods
66 
-##' @exportMethod scale_color
67 
-setMethod("scale_color", signature(object="phangorn"),
68 
-          function(object, by, ...) {
69 
-              scale_color_(object, by, ...)
70 
-          })
71 
-
72 
-
73 
-##' @rdname gzoom-methods
74 
-##' @exportMethod gzoom
75 
-setMethod("gzoom", signature(object="phangorn"),
76 
-          function(object, focus, subtree=FALSE, widths=c(.3, .7)) {
77 
-              gzoom.phylo(get.tree(object), focus, subtree, widths)
78 
-          })
79 
-
80 
-
81 
-##' @rdname get.tree-methods
82 
-##' @exportMethod get.tree
83 
-setMethod("get.tree", signature(object="phangorn"),
84 
-          function(object,...) {
85 
-              object@phylo
86 
-          }
87 
-          )
88 
-
89 
-
90 
-##' @rdname get.fields-methods
91 
-##' @exportMethod get.fields
92 
-setMethod("get.fields", signature(object="phangorn"),
93 
-          function(object, ...) {
94 
-              get.fields.tree(object)
95 
-          }
96 
-          )
97 
-
98 
-
99 
-##' convert pml object to XStringSet object
100 
-##'
101 
-##'
102 
-##' @title pmlToSeq
103 
-##' @param pml pml object
104 
-##' @param includeAncestor logical
105 
-##' @param type one of "marginal", "ml", "bayes"
106 
-##' @return XStringSet
107 
-## @importFrom Biostrings DNAStringSet
108 
-##' @export
109 
-##' @author ygc
110 
-pmlToSeq <- function(pml, type="ml", includeAncestor=TRUE) {
111 
-    DNAStringSet <- get_fun_from_pkg("Biostrings", "DNAStringSet")
112 
-    pmlToSeqString(pml, type, includeAncestor) %>%
113 
-        DNAStringSet
114 
-}
115 
-
116 
-## @importFrom phangorn ancestral.pml
117 
-pmlToSeqString <- function(pml, type, includeAncestor=TRUE) {
118 
-    if (includeAncestor == FALSE) {
119 
-        phyDat <- pml$data
120 
-    } else {
121 
-        ancestral.pml <- get_fun_from_pkg("phangorn", "ancestral.pml")
122 
-        phyDat <- ancestral.pml(pml, type)
123 
-    }
124 
-
125 
-    phyDat <- matrix2vector.phyDat(phyDat)
126 
-    ## defined by phangorn
127 
-    labels <- c("a", "c", "g", "t", "u", "m", "r", "w", "s",
128 
-                "y", "k", "v", "h", "d", "b", "n", "?", "-")
129 
-    labels <- toupper(labels)
130 
-
131 
-    index <- attr(phyDat, "index")
132 
-
133 
-    result <- do.call(rbind, phyDat)
134 
-    result <- result[, index, drop=FALSE]
135 
-
136 
-    res <- apply(result, 2, function(i) labels[i])
137 
-    res <- apply(res, 1, paste, collapse="")
138 
-    names(res) <- rownames(result)
139 
-    return(res)
140 
-}
141 
-
142 
-
143 
-
144 
-matrix2vector.phyDat <- function(x) {
145 
-    index <- attr(x, "index")
146 
-    res <- lapply(x, matrix2vector.phyDat.item)
147 
-    names(res) <- names(x)
148 
-    attr(res, "index") <- index
149 
-    class(res) <- "phyDat"
150 
-    return(res)
151 
-}
152 
-
153 
-matrix2vector.phyDat.item <- function(y) {
154 
-    ii <- apply(y, 1, function(xx) {
155 
-        ## return index of a c g and t, if it has highest probability
156 
-        ## otherwise return index of -
157 
-        jj <- which(xx == max(xx))
158 
-        if ( length(jj) > 1) {
159 
-            if (length(jj) < 4) {
160 
-                warning("ambiguous found...\n")
161 
-            } else {
162 
-                ## cat("insertion found...\n")
163 
-            }
164 
-            ## 18 is the gap(-) index of base character defined in phangorn
165 
-            ## c("a", "c", "g", "t", "u", "m", "r", "w", "s",
166 
-	    ##   "y", "k", "v", "h", "d", "b", "n", "?", "-")
167 
-            18
168 
-        } else {
169 
-            jj
170 
-        }
171 
-    })
172 
-    unlist(ii)
173 
-}
1 
+## ##' tree annotation of sequence substitution by comparing to parent node
2 
+## ##'
3 
+## ##'
4 
+## ##' @title treeAnno.pml
5 
+## ##' @param pmlTree tree in pml object, output of phangorn::optim.pml
6 
+## ##' @param type one of 'ml' and 'bayes' for inferring ancestral sequences
7 
+## ##' @return phangorn object
8 
+## ##' @importFrom ape read.tree
9 
+## ##' @importFrom ape reorder.phylo
10 
+## ##' @export
11 
+## ##' @author Yu Guangchuang
12 
+## phyPML <- function(pmlTree, type = "ml") {
13 
+##     sequences <- pmlToSeqString(pmlTree, type, includeAncestor=TRUE)
14 
+##     tr <- pmlTree$tree
15 
+##     tr <- reorder.phylo(tr)
16 
+
17 
+##     if (is.null(tr$node.label)) {
18 
+##         n <- length(tr$tip.label)
19 
+##         nl <- (n+1):(2*n-2)
20 
+##         tr$node.label <- as.character(nl)
21 
+##     } else {
22 
+##         names(sequences) <- c(tr$tip.label, tr$node.label)
23 
+##     }
24 
+
25 
+##     seq_type <- get_seqtype(sequences)
26 
+##     res <- new("phangorn",
27 
+##                phylo = tr,
28 
+##                fields = "subs",
29 
+##                seq_type = seq_type,
30 
+##                ancseq = sequences)
31 
+
32 
+
33 
+##     res@tip_seq <- sequences[names(sequences) %in% tr$tip.label]
34 
+
35 
+##     res@subs <- get.subs_(res@phylo, sequences, translate=FALSE)
36 
+##     if (seq_type == "NT") {
37 
+##         res@AA_subs <- get.subs_(res@phylo, sequences, translate=TRUE)
38 
+##         res@fields %<>% c("AA_subs")
39 
+##     }
40 
+
41 
+##     return(res)
42 
+## }
43 
+
44 
+
45 
+
46 
+
47 
+## ##' @rdname get.subs-methods
48 
+## ##' @exportMethod get.subs
49 
+## setMethod("get.subs", signature(object = "phangorn"),
50 
+##           function(object, type, ...) {
51 
+##               if (type == "AA_subs")
52 
+##                   return(object@AA_subs)
53 
+##               return(object@subs)
54 
+##           }
55 
+##           )
56 
+
57 
+
58 
+## ##' @rdname groupClade-methods
59 
+## ##' @exportMethod groupClade
60 
+## setMethod("groupClade", signature(object="phangorn"),
61 
+##           function(object, node, group_name="group") {
62 
+##               groupClade_(object, node, group_name)
63 
+##           })
64 
+
65 
+## ##' @rdname scale_color-methods
66 
+## ##' @exportMethod scale_color
67 
+## setMethod("scale_color", signature(object="phangorn"),
68 
+##           function(object, by, ...) {
69 
+##               scale_color_(object, by, ...)
70 
+##           })
71 
+
72 
+
73 
+## ##' @rdname gzoom-methods
74 
+## ##' @exportMethod gzoom
75 
+## setMethod("gzoom", signature(object="phangorn"),
76 
+##           function(object, focus, subtree=FALSE, widths=c(.3, .7)) {
77 
+##               gzoom.phylo(get.tree(object), focus, subtree, widths)
78 
+##           })
79 
+
80 
+
81 
+## ##' @rdname get.tree-methods
82 
+## ##' @exportMethod get.tree
83 
+## setMethod("get.tree", signature(object="phangorn"),
84 
+##           function(object,...) {
85 
+##               object@phylo
86 
+##           }
87 
+##           )
88 
+
89 
+
90 
+## ##' @rdname get.fields-methods
91 
+## ##' @exportMethod get.fields
92 
+## setMethod("get.fields", signature(object="phangorn"),
93 
+##           function(object, ...) {
94 
+##               get.fields.tree(object)
95 
+##           }
96 
+##           )
97 
+
98 
+
99 
+## ##' convert pml object to XStringSet object
100 
+## ##'
101 
+## ##'
102 
+## ##' @title pmlToSeq
103 
+## ##' @param pml pml object
104 
+## ##' @param includeAncestor logical
105 
+## ##' @param type one of "marginal", "ml", "bayes"
106 
+## ##' @return XStringSet
107 
+## ## @importFrom Biostrings DNAStringSet
108 
+## ##' @export
109 
+## ##' @author ygc
110 
+## pmlToSeq <- function(pml, type="ml", includeAncestor=TRUE) {
111 
+##     DNAStringSet <- get_fun_from_pkg("Biostrings", "DNAStringSet")
112 
+##     pmlToSeqString(pml, type, includeAncestor) %>%
113 
+##         DNAStringSet
114 
+## }
115 
+
116 
+## ## @importFrom phangorn ancestral.pml
117 
+## pmlToSeqString <- function(pml, type, includeAncestor=TRUE) {
118 
+##     if (includeAncestor == FALSE) {
119 
+##         phyDat <- pml$data
120 
+##     } else {
121 
+##         ancestral.pml <- get_fun_from_pkg("phangorn", "ancestral.pml")
122 
+##         phyDat <- ancestral.pml(pml, type)
123 
+##     }
124 
+
125 
+##     phyDat <- matrix2vector.phyDat(phyDat)
126 
+##     ## defined by phangorn
127 
+##     labels <- c("a", "c", "g", "t", "u", "m", "r", "w", "s",
128 
+##                 "y", "k", "v", "h", "d", "b", "n", "?", "-")
129 
+##     labels <- toupper(labels)
130 
+
131 
+##     index <- attr(phyDat, "index")
132 
+
133 
+##     result <- do.call(rbind, phyDat)
134 
+##     result <- result[, index, drop=FALSE]
135 
+
136 
+##     res <- apply(result, 2, function(i) labels[i])
137 
+##     res <- apply(res, 1, paste, collapse="")
138 
+##     names(res) <- rownames(result)
139 
+##     return(res)
140 
+## }
141 
+
142 
+
143 
+
144 
+## matrix2vector.phyDat <- function(x) {
145 
+##     index <- attr(x, "index")
146 
+##     res <- lapply(x, matrix2vector.phyDat.item)
147 
+##     names(res) <- names(x)
148 
+##     attr(res, "index") <- index
149 
+##     class(res) <- "phyDat"
150 
+##     return(res)
151 
+## }
152 
+
153 
+## matrix2vector.phyDat.item <- function(y) {
154 
+##     ii <- apply(y, 1, function(xx) {
155 
+##         ## return index of a c g and t, if it has highest probability
156 
+##         ## otherwise return index of -
157 
+##         jj <- which(xx == max(xx))
158 
+##         if ( length(jj) > 1) {
159 
+##             if (length(jj) < 4) {
160 
+##                 warning("ambiguous found...\n")
161 
+##             } else {
162 
+##                 ## cat("insertion found...\n")
163 
+##             }
164 
+##             ## 18 is the gap(-) index of base character defined in phangorn
165 
+##             ## c("a", "c", "g", "t", "u", "m", "r", "w", "s",
166 
+## 	    ##   "y", "k", "v", "h", "d", "b", "n", "?", "-")
167 
+##             18
168 
+##         } else {
169 
+##             jj
170 
+##         }
171 
+##     })
172 
+##     unlist(ii)
173 
+## }
174 174
Browse code

bug fixed

guangchuang yu authored on 14/12/2016 09:07:44
Showing 1 changed files
R/phangorn.R
History View file @ 0710a7b7
... ... 
@@ -1,8 +1,8 @@
1 1 
 ##' tree annotation of sequence substitution by comparing to parent node
2 2 
 ##'
3 
-##'
3 
+##'
4 4 
 ##' @title treeAnno.pml
5 
-##' @param pmlTree tree in pml object, output of phangorn::optim.pml
5 
+##' @param pmlTree tree in pml object, output of phangorn::optim.pml
6 6 
 ##' @param type one of 'ml' and 'bayes' for inferring ancestral sequences
7 7 
 ##' @return phangorn object
8 8 
 ##' @importFrom ape read.tree
... ... 
@@ -13,7 +13,7 @@ phyPML <- function(pmlTree, type = "ml") {
13 13 
     sequences <- pmlToSeqString(pmlTree, type, includeAncestor=TRUE)
14 14 
     tr <- pmlTree$tree
15 15 
     tr <- reorder.phylo(tr)
16 
-
16 
+
17 17 
     if (is.null(tr$node.label)) {
18 18 
         n <- length(tr$tip.label)
19 19 
         nl <- (n+1):(2*n-2)
... ... 
@@ -21,14 +21,14 @@ phyPML <- function(pmlTree, type = "ml") {
21 21 
     } else {
22 22 
         names(sequences) <- c(tr$tip.label, tr$node.label)
23 23 
     }
24 
-
24 
+
25 25 
     seq_type <- get_seqtype(sequences)
26 26 
     res <- new("phangorn",
27 27 
                phylo = tr,
28 28 
                fields = "subs",
29 29 
                seq_type = seq_type,
30 30 
                ancseq = sequences)
31 
-
31 
+
32 32
33 33 
     res@tip_seq <- sequences[names(sequences) %in% tr$tip.label]
34 34
... ... 
@@ -37,28 +37,12 @@ phyPML <- function(pmlTree, type = "ml") {
37 37 
         res@AA_subs <- get.subs_(res@phylo, sequences, translate=TRUE)
38 38 
         res@fields %<>% c("AA_subs")
39 39 
     }
40 
-
40 
+
41 41 
     return(res)
42 42 
 }
43 43
44 44
45 45
46 
-##' @rdname show-methods
47 
-##' @importFrom ape print.phylo
48 
-##' @exportMethod show
49 
-setMethod("show", signature(object = "phangorn"),
50 
-          function(object) {
51 
-              cat("'phangorn' S4 object that stored ancestral sequences inferred by 'phangorn::ancestral.pml'", ".\n\n")
52 
-              cat("...@ tree: ")
53 
-              print.phylo(get.tree(object))
54 
-              fields <- get.fields(object)
55 
-              cat("\nwith the following features available:\n")
56 
-              cat("\t", paste0("'",
57 
-                               paste(fields, collapse="',\t'"),
58 
-                               "'."),
59 
-                  "\n")
60 
-          })
61 
-
62 46
63 47 
 ##' @rdname get.subs-methods
64 48 
 ##' @exportMethod get.subs
... ... 
@@ -114,17 +98,18 @@ setMethod("get.fields", signature(object="phangorn"),
114 98
115 99 
 ##' convert pml object to XStringSet object
116 100 
 ##'
117 
-##'
118 
-##' @title pmlToSeq
101 
+##'
102 
+##' @title pmlToSeq
119 103 
 ##' @param pml pml object
120 
-##' @param includeAncestor logical
104 
+##' @param includeAncestor logical
105 
+##' @param type one of "marginal", "ml", "bayes"
121 106 
 ##' @return XStringSet
122 107 
 ## @importFrom Biostrings DNAStringSet
123 108 
 ##' @export
124 109 
 ##' @author ygc
125 
-pmlToSeq <- function(pml, includeAncestor=TRUE) {
110 
+pmlToSeq <- function(pml, type="ml", includeAncestor=TRUE) {
126 111 
     DNAStringSet <- get_fun_from_pkg("Biostrings", "DNAStringSet")
127 
-    pmlToSeqString(pml, includeAncestor) %>%
112 
+    pmlToSeqString(pml, type, includeAncestor) %>%
128 113 
         DNAStringSet
129 114 
 }
130 115
... ... 
@@ -136,15 +121,15 @@ pmlToSeqString <- function(pml, type, includeAncestor=TRUE) {
136 121 
         ancestral.pml <- get_fun_from_pkg("phangorn", "ancestral.pml")
137 122 
         phyDat <- ancestral.pml(pml, type)
138 123 
     }
139 
-
124 
+
140 125 
     phyDat <- matrix2vector.phyDat(phyDat)
141 126 
     ## defined by phangorn
142 
-    labels <- c("a", "c", "g", "t", "u", "m", "r", "w", "s",
127 
+    labels <- c("a", "c", "g", "t", "u", "m", "r", "w", "s",
143 128 
                 "y", "k", "v", "h", "d", "b", "n", "?", "-")
144 129 
     labels <- toupper(labels)
145 130
146 131 
     index <- attr(phyDat, "index")
147 
-
132 
+
148 133 
     result <- do.call(rbind, phyDat)
149 134 
     result <- result[, index, drop=FALSE]
150 135
... ... 
@@ -177,7 +162,7 @@ matrix2vector.phyDat.item <- function(y) {
177 162 
                 ## cat("insertion found...\n")
178 163 
             }
179 164 
             ## 18 is the gap(-) index of base character defined in phangorn
180 
-            ## c("a", "c", "g", "t", "u", "m", "r", "w", "s",
165 
+            ## c("a", "c", "g", "t", "u", "m", "r", "w", "s",
181 166 
 	    ##   "y", "k", "v", "h", "d", "b", "n", "?", "-")
182 167 
             18
183 168 
         } else {
Browse code

clean dependencies

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

g.yu authored on 21/07/2016 13:16:38
Showing 1 changed files
R/phangorn.R
History View file @ 27786944
... ... 
@@ -119,10 +119,11 @@ setMethod("get.fields", signature(object="phangorn"),
119 119 
 ##' @param pml pml object
120 120 
 ##' @param includeAncestor logical
121 121 
 ##' @return XStringSet
122 
-##' @importFrom Biostrings DNAStringSet
122 
+## @importFrom Biostrings DNAStringSet
123 123 
 ##' @export
124 124 
 ##' @author ygc
125 125 
 pmlToSeq <- function(pml, includeAncestor=TRUE) {
126 
+    DNAStringSet <- get_fun_from_pkg("Biostrings", "DNAStringSet")
126 127 
     pmlToSeqString(pml, includeAncestor) %>%
127 128 
         DNAStringSet
128 129 
 }
... ... 
@@ -132,10 +133,7 @@ pmlToSeqString <- function(pml, type, includeAncestor=TRUE) {
132 133 
     if (includeAncestor == FALSE) {
133 134 
         phyDat <- pml$data
134 135 
     } else {
135 
-        pkg <- "phangorn"
136 
-        require(pkg, character.only = TRUE)
137 
-        ## requireNamespace("phangorn")
138 
-        ancestral.pml <- eval(parse(text="phangorn::ancestral.pml"))
136 
+        ancestral.pml <- get_fun_from_pkg("phangorn", "ancestral.pml")
139 137 
         phyDat <- ancestral.pml(pml, type)
140 138 
     }
141 139
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 1 changed files
R/phangorn.R
History View file @ 3e4b5998
1 1 
new file mode 100644
... ... 
@@ -0,0 +1,191 @@
1 
+##' tree annotation of sequence substitution by comparing to parent node
2 
+##'
3 
+##'
4 
+##' @title treeAnno.pml
5 
+##' @param pmlTree tree in pml object, output of phangorn::optim.pml
6 
+##' @param type one of 'ml' and 'bayes' for inferring ancestral sequences
7 
+##' @return phangorn object
8 
+##' @importFrom ape read.tree
9 
+##' @importFrom ape reorder.phylo
10 
+##' @export
11 
+##' @author Yu Guangchuang
12 
+phyPML <- function(pmlTree, type = "ml") {
13 
+    sequences <- pmlToSeqString(pmlTree, type, includeAncestor=TRUE)
14 
+    tr <- pmlTree$tree
15 
+    tr <- reorder.phylo(tr)
16 
+
17 
+    if (is.null(tr$node.label)) {
18 
+        n <- length(tr$tip.label)
19 
+        nl <- (n+1):(2*n-2)
20 
+        tr$node.label <- as.character(nl)
21 
+    } else {
22 
+        names(sequences) <- c(tr$tip.label, tr$node.label)
23 
+    }
24 
+
25 
+    seq_type <- get_seqtype(sequences)
26 
+    res <- new("phangorn",
27 
+               phylo = tr,
28 
+               fields = "subs",
29 
+               seq_type = seq_type,
30 
+               ancseq = sequences)
31 
+
32 
+
33 
+    res@tip_seq <- sequences[names(sequences) %in% tr$tip.label]
34 
+
35 
+    res@subs <- get.subs_(res@phylo, sequences, translate=FALSE)
36 
+    if (seq_type == "NT") {
37 
+        res@AA_subs <- get.subs_(res@phylo, sequences, translate=TRUE)
38 
+        res@fields %<>% c("AA_subs")
39 
+    }
40 
+
41 
+    return(res)
42 
+}
43 
+
44 
+
45 
+
46 
+##' @rdname show-methods
47 
+##' @importFrom ape print.phylo
48 
+##' @exportMethod show
49 
+setMethod("show", signature(object = "phangorn"),
50 
+          function(object) {
51 
+              cat("'phangorn' S4 object that stored ancestral sequences inferred by 'phangorn::ancestral.pml'", ".\n\n")
52 
+              cat("...@ tree: ")
53 
+              print.phylo(get.tree(object))
54 
+              fields <- get.fields(object)
55 
+              cat("\nwith the following features available:\n")
56 
+              cat("\t", paste0("'",
57 
+                               paste(fields, collapse="',\t'"),
58 
+                               "'."),
59 
+                  "\n")
60 
+          })
61 
+
62 
+
63 
+##' @rdname get.subs-methods
64 
+##' @exportMethod get.subs
65 
+setMethod("get.subs", signature(object = "phangorn"),
66 
+          function(object, type, ...) {
67 
+              if (type == "AA_subs")
68 
+                  return(object@AA_subs)
69 
+              return(object@subs)
70 
+          }
71 
+          )
72 
+
73 
+
74 
+##' @rdname groupClade-methods
75 
+##' @exportMethod groupClade
76 
+setMethod("groupClade", signature(object="phangorn"),
77 
+          function(object, node, group_name="group") {
78 
+              groupClade_(object, node, group_name)
79 
+          })
80 
+
81 
+##' @rdname scale_color-methods
82 
+##' @exportMethod scale_color
83 
+setMethod("scale_color", signature(object="phangorn"),
84 
+          function(object, by, ...) {
85 
+              scale_color_(object, by, ...)
86 
+          })
87 
+
88 
+
89 
+##' @rdname gzoom-methods
90 
+##' @exportMethod gzoom
91 
+setMethod("gzoom", signature(object="phangorn"),
92 
+          function(object, focus, subtree=FALSE, widths=c(.3, .7)) {
93 
+              gzoom.phylo(get.tree(object), focus, subtree, widths)
94 
+          })
95 
+
96 
+
97 
+##' @rdname get.tree-methods
98 
+##' @exportMethod get.tree
99 
+setMethod("get.tree", signature(object="phangorn"),
100 
+          function(object,...) {
101 
+              object@phylo
102 
+          }
103 
+          )
104 
+
105 
+
106 
+##' @rdname get.fields-methods
107 
+##' @exportMethod get.fields
108 
+setMethod("get.fields", signature(object="phangorn"),
109 
+          function(object, ...) {
110 
+              get.fields.tree(object)
111 
+          }
112 
+          )
113 
+
114 
+
115 
+##' convert pml object to XStringSet object
116 
+##'
117 
+##'
118 
+##' @title pmlToSeq
119 
+##' @param pml pml object
120 
+##' @param includeAncestor logical
121 
+##' @return XStringSet
122 
+##' @importFrom Biostrings DNAStringSet
123 
+##' @export
124 
+##' @author ygc
125 
+pmlToSeq <- function(pml, includeAncestor=TRUE) {
126 
+    pmlToSeqString(pml, includeAncestor) %>%
127 
+        DNAStringSet
128 
+}
129 
+
130 
+## @importFrom phangorn ancestral.pml
131 
+pmlToSeqString <- function(pml, type, includeAncestor=TRUE) {
132 
+    if (includeAncestor == FALSE) {
133 
+        phyDat <- pml$data
134 
+    } else {
135 
+        pkg <- "phangorn"
136 
+        require(pkg, character.only = TRUE)
137 
+        ## requireNamespace("phangorn")
138 
+        ancestral.pml <- eval(parse(text="phangorn::ancestral.pml"))
139 
+        phyDat <- ancestral.pml(pml, type)
140 
+    }
141 
+
142 
+    phyDat <- matrix2vector.phyDat(phyDat)
143 
+    ## defined by phangorn
144 
+    labels <- c("a", "c", "g", "t", "u", "m", "r", "w", "s",
145 
+                "y", "k", "v", "h", "d", "b", "n", "?", "-")
146 
+    labels <- toupper(labels)
147 
+
148 
+    index <- attr(phyDat, "index")
149 
+
150 
+    result <- do.call(rbind, phyDat)
151 
+    result <- result[, index, drop=FALSE]
152 
+
153 
+    res <- apply(result, 2, function(i) labels[i])
154 
+    res <- apply(res, 1, paste, collapse="")
155 
+    names(res) <- rownames(result)
156 
+    return(res)
157 
+}
158 
+
159 
+
160 
+
161 
+matrix2vector.phyDat <- function(x) {
162 
+    index <- attr(x, "index")
163 
+    res <- lapply(x, matrix2vector.phyDat.item)
164 
+    names(res) <- names(x)
165 
+    attr(res, "index") <- index
166 
+    class(res) <- "phyDat"
167 
+    return(res)
168 
+}
169 
+
170 
+matrix2vector.phyDat.item <- function(y) {
171 
+    ii <- apply(y, 1, function(xx) {
172 
+        ## return index of a c g and t, if it has highest probability
173 
+        ## otherwise return index of -
174 
+        jj <- which(xx == max(xx))
175 
+        if ( length(jj) > 1) {
176 
+            if (length(jj) < 4) {
177 
+                warning("ambiguous found...\n")
178 
+            } else {
179 
+                ## cat("insertion found...\n")
180 
+            }
181 
+            ## 18 is the gap(-) index of base character defined in phangorn
182 
+            ## c("a", "c", "g", "t", "u", "m", "r", "w", "s",
183 
+	    ##   "y", "k", "v", "h", "d", "b", "n", "?", "-")
184 
+            18
185 
+        } else {
186 
+            jj
187 
+        }
188 
+    })
189 
+    unlist(ii)
190 
+}
191 
+