R/phangorn.R
817c093d
 ## ##' tree annotation of sequence substitution by comparing to parent node
 ## ##'
 ## ##'
 ## ##' @title treeAnno.pml
 ## ##' @param pmlTree tree in pml object, output of phangorn::optim.pml
 ## ##' @param type one of 'ml' and 'bayes' for inferring ancestral sequences
 ## ##' @return phangorn object
 ## ##' @importFrom ape read.tree
 ## ##' @importFrom ape reorder.phylo
 ## ##' @export
 ## ##' @author Yu Guangchuang
 ## phyPML <- function(pmlTree, type = "ml") {
 ##     sequences <- pmlToSeqString(pmlTree, type, includeAncestor=TRUE)
 ##     tr <- pmlTree$tree
 ##     tr <- reorder.phylo(tr)
 
 ##     if (is.null(tr$node.label)) {
 ##         n <- length(tr$tip.label)
 ##         nl <- (n+1):(2*n-2)
 ##         tr$node.label <- as.character(nl)
 ##     } else {
 ##         names(sequences) <- c(tr$tip.label, tr$node.label)
 ##     }
 
 ##     seq_type <- get_seqtype(sequences)
 ##     res <- new("phangorn",
 ##                phylo = tr,
 ##                fields = "subs",
 ##                seq_type = seq_type,
 ##                ancseq = sequences)
 
 
 ##     res@tip_seq <- sequences[names(sequences) %in% tr$tip.label]
 
 ##     res@subs <- get.subs_(res@phylo, sequences, translate=FALSE)
 ##     if (seq_type == "NT") {
 ##         res@AA_subs <- get.subs_(res@phylo, sequences, translate=TRUE)
 ##         res@fields %<>% c("AA_subs")
 ##     }
 
 ##     return(res)
 ## }
 
 
 
 
 ## ##' @rdname get.subs-methods
 ## ##' @exportMethod get.subs
 ## setMethod("get.subs", signature(object = "phangorn"),
 ##           function(object, type, ...) {
 ##               if (type == "AA_subs")
 ##                   return(object@AA_subs)
 ##               return(object@subs)
 ##           }
 ##           )
 
 
 ## ##' @rdname groupClade-methods
 ## ##' @exportMethod groupClade
 ## setMethod("groupClade", signature(object="phangorn"),
 ##           function(object, node, group_name="group") {
 ##               groupClade_(object, node, group_name)
 ##           })
 
 ## ##' @rdname scale_color-methods
 ## ##' @exportMethod scale_color
 ## setMethod("scale_color", signature(object="phangorn"),
 ##           function(object, by, ...) {
 ##               scale_color_(object, by, ...)
 ##           })
 
 
 ## ##' @rdname gzoom-methods
 ## ##' @exportMethod gzoom
 ## setMethod("gzoom", signature(object="phangorn"),
 ##           function(object, focus, subtree=FALSE, widths=c(.3, .7)) {
 ##               gzoom.phylo(get.tree(object), focus, subtree, widths)
 ##           })
 
 
 ## ##' @rdname get.tree-methods
 ## ##' @exportMethod get.tree
 ## setMethod("get.tree", signature(object="phangorn"),
 ##           function(object,...) {
 ##               object@phylo
 ##           }
 ##           )
 
 
 ## ##' @rdname get.fields-methods
 ## ##' @exportMethod get.fields
 ## setMethod("get.fields", signature(object="phangorn"),
 ##           function(object, ...) {
 ##               get.fields.tree(object)
 ##           }
 ##           )
 
 
 ## ##' convert pml object to XStringSet object
 ## ##'
 ## ##'
 ## ##' @title pmlToSeq
 ## ##' @param pml pml object
 ## ##' @param includeAncestor logical
 ## ##' @param type one of "marginal", "ml", "bayes"
 ## ##' @return XStringSet
 ## ## @importFrom Biostrings DNAStringSet
 ## ##' @export
 ## ##' @author ygc
 ## pmlToSeq <- function(pml, type="ml", includeAncestor=TRUE) {
 ##     DNAStringSet <- get_fun_from_pkg("Biostrings", "DNAStringSet")
 ##     pmlToSeqString(pml, type, includeAncestor) %>%
 ##         DNAStringSet
 ## }
 
 ## ## @importFrom phangorn ancestral.pml
 ## pmlToSeqString <- function(pml, type, includeAncestor=TRUE) {
 ##     if (includeAncestor == FALSE) {
 ##         phyDat <- pml$data
 ##     } else {
 ##         ancestral.pml <- get_fun_from_pkg("phangorn", "ancestral.pml")
 ##         phyDat <- ancestral.pml(pml, type)
 ##     }
 
 ##     phyDat <- matrix2vector.phyDat(phyDat)
 ##     ## defined by phangorn
 ##     labels <- c("a", "c", "g", "t", "u", "m", "r", "w", "s",
 ##                 "y", "k", "v", "h", "d", "b", "n", "?", "-")
 ##     labels <- toupper(labels)
 
 ##     index <- attr(phyDat, "index")
 
 ##     result <- do.call(rbind, phyDat)
 ##     result <- result[, index, drop=FALSE]
 
 ##     res <- apply(result, 2, function(i) labels[i])
 ##     res <- apply(res, 1, paste, collapse="")
 ##     names(res) <- rownames(result)
 ##     return(res)
 ## }
 
 
 
 ## matrix2vector.phyDat <- function(x) {
 ##     index <- attr(x, "index")
 ##     res <- lapply(x, matrix2vector.phyDat.item)
 ##     names(res) <- names(x)
 ##     attr(res, "index") <- index
 ##     class(res) <- "phyDat"
 ##     return(res)
 ## }
 
 ## matrix2vector.phyDat.item <- function(y) {
 ##     ii <- apply(y, 1, function(xx) {
 ##         ## return index of a c g and t, if it has highest probability
 ##         ## otherwise return index of -
 ##         jj <- which(xx == max(xx))
 ##         if ( length(jj) > 1) {
 ##             if (length(jj) < 4) {
 ##                 warning("ambiguous found...\n")
 ##             } else {
 ##                 ## cat("insertion found...\n")
 ##             }
 ##             ## 18 is the gap(-) index of base character defined in phangorn
 ##             ## c("a", "c", "g", "t", "u", "m", "r", "w", "s",
 ## 	    ##   "y", "k", "v", "h", "d", "b", "n", "?", "-")
 ##             18
 ##         } else {
 ##             jj
 ##         }
 ##     })
 ##     unlist(ii)
 ## }
3e4b5998