R/method-reroot.R

In GuangchuangYu/tidytree: A Tidy Tool for Phylogenetic Tree Data Manipulation

old_new_node_mapping <- function(oldtree, newtree){
    treelab1 <- oldtree %>% 
                as_tibble() %>%
                dplyr::select(c("node", "label"))
    treelab2 <- newtree %>% 
                as_tibble() %>%
                dplyr::select(c("node", "label"))
    node_map <- dplyr::inner_join(treelab1, treelab2, by="label") %>%
                dplyr::select(c("node.x", "node.y")) %>%
                dplyr::rename(c(old="node.x", new="node.y"))
    return(node_map)
}

# ##' re-root a tree
# ##'
# ##'
# ##' @title root
# ##' @rdname root-method
# ##' @param phy tree object
# ##' @param outgroup a vector of mode numeric or character specifying the new outgroup
# ##' @param node node to reroot
# ##' @param edgelabel a logical value specifying whether to treat node labels as 
# ##' edge labels and thus eventually switching them so that they are associated 
# ##' with the correct edges.
# ##' @param ... additional parameters passed to ape::root.phylo
# ##' @return rerooted tree
# ##' @importFrom ape root
# ##' @method root phylo
# ##' @export
# ##' @author Guangchuang Yu
# 
# root.phylo <- function(phy, outgroup, node = NULL, edgelabel = TRUE, ...){
#     tree <- ape::root.phylo(phy, outgroup = outgroup, node = node,
#                             edgelabel = edgelabel, ...)
# 
#     attr(tree, "reroot") <- TRUE
#     node_map <- reroot_node_mapping(phy, tree)
#     attr(tree, "node_map") <- node_map
#     return(tree)
# }


##' re-root a tree
##'
##' @title root
##' @rdname root-method
##' @param phy tree object
##' @param outgroup a vector of mode numeric or character specifying the new outgroup
##' @param node node to reroot
##' @param edgelabel a logical value specifying whether to treat node labels as
##' edge labels and thus eventually switching them so that they are associated
##' with the correct edges.
##' @param ... additional parameters passed to ape::root.phylo
##' @return rerooted treedata
##' @method root treedata
##' @export

root.treedata <- function(phy, outgroup, node = NULL, edgelabel = TRUE, ...){
    if (!missing(outgroup) && is.character(outgroup)){
        outgroup <- match(outgroup, phy@phylo$tip.label)
    }
    if (!edgelabel){
    ## warning message
        message("The use of this method may cause some node data to become incorrect (e.g. bootstrap values) if 'edgelabel' is FALSE.")
    }
    #object <- phy
    # generate node old label and new label map table.
    res <- build_new_labels(tree=phy)
    tree <- res$tree
    node2oldnewlab <- res$node2old_new_lab
    # reroot tree
    re_tree <- root(tree, outgroup = outgroup, node = node,
                 edgelabel = edgelabel, ...)
    
    node_map <- old_new_node_mapping(tree, re_tree)
    n.tips <- Ntip(re_tree)
    
    # replace new label with old label
    phy@phylo <- build_new_tree(tree=re_tree, node2old_new_lab=node2oldnewlab)

    # update data or extraInfo function
    update_data <- function(data, node_map) {
        cn <- colnames(data)
        cn <- cn[cn != "node"]
        data <- dplyr::inner_join(data, node_map, by=c("node"="old")) %>%
                dplyr::select(c("new", cn)) %>% 
                dplyr::rename(node=.data$new)

        # clear root data
        root <- data$node == (n.tips + 1)
        data[root,] <- NA
        data[root,'node'] <- n.tips + 1
        return(data)
    }
    if (nrow(phy@data) > 0) {
        phy@data <- update_data(phy@data, node_map)
    }    
    if (nrow(phy@extraInfo) > 0){
        phy@extraInfo <- update_data(phy@extraInfo, node_map)
    }

    return(phy)
}


## reroot_node_mapping <- function(tree, tree2) {
##     root <- rootnode(tree)
## 
## 
##     node_map <- data.frame(from=1:getNodeNum(tree), to=NA, visited=FALSE)
##     node_map[1:Ntip(tree), 2] <- match(tree$tip.label, tree2$tip.label)
##     node_map[1:Ntip(tree), 3] <- TRUE
## 
##     node_map[root, 2] <- root
##     node_map[root, 3] <- TRUE
## 
##     node <- rev(tree$edge[,2])
##     for (k in node) {
##         ##ip <- getParent(tree, k)
##         ip <- parent(tree, k)
##         if (node_map[ip, "visited"])
##             next
## 
##         ## cc <- getChild(tree, ip)
##         cc <- child(tree, ip)
##         node2 <- node_map[cc,2]
##         if (anyNA(node2)) {
##             node <- c(node, k)
##             next
##         }
## 
##         ## to <- unique(sapply(node2, getParent, tr=tree2))
##         to <- unique(sapply(node2, parent, .data=tree2))
##         to <- to[! to %in% node_map[,2]]
##         node_map[ip, 2] <- to
##         node_map[ip, 3] <- TRUE
##     }
##     node_map <- node_map[, -3]
##     return(node_map)
## }
## 
## 
## ##' re-root a tree
## ##'
## ##' 
## ##' @title root
## ##' @rdname root-method
## ##' @param phy tree object
## ##' @param outgroup a vector of mode numeric or character specifying the new outgroup
## ##' @param node node to reroot
## ##' @param resolve.root a logical specifying whether to resolve the new root as a bifurcating node
## ##' @param ... additional parameters passed to ape::root.phylo
## ##' @return rerooted tree
## ##' @importFrom ape root
## ##' @method root phylo
## ##' @export
## ##' @author Guangchuang Yu
## root.phylo <- function(phy, outgroup, node = NULL, resolve.root = TRUE, ...) {
##     ## pos <- 0.5* object$edge.length[which(object$edge[,2] == node)]
##     
##     ## @importFrom phytools reroot
##     ## phytools <- "phytools"
##     ## require(phytools, character.only = TRUE, quietly = TRUE)
##     
##     ## phytools_reroot <- eval(parse(text="phytools::reroot"))
##     
##     ## tree <- phytools_reroot(object, node, pos)
## 
##     tree <- ape::root.phylo(phy, outgroup = outgroup,
##                             node = node, resolve.root = resolve.root, ...)
## 
##     #if (Nnode(tree) != Nnode(phy)) {
##     #    return(tree)
##     #}
## 
##     attr(tree, "reroot") <- TRUE
##     node_map <- reroot_node_mapping(phy, tree)
##     attr(tree, "node_map") <- node_map
##     return(tree)
## }
## 
## 
## ##' @rdname root-method
## ##' @method root treedata
## ##' @export
## root.treedata <- function(phy, outgroup, node = NULL, resolve.root = TRUE, ...) {
##     ## warning message
##     message("The use of this method may cause some node data to become incorrect (e.g. bootstrap values).")
## 
##     object <- phy
##     newobject <- object
## 
##     ## ensure nodes/tips have a label to properly map @anc_seq/@tip_seq
##     tree <- object@phylo
##     if (is.null(tree$tip.label)) {
##         tree$tip.label <- as.character(1:Ntip(tree))
##     }
##     if (is.null(tree$node.label)) {
##         #tree$node.label <- as.character((1:tree$Nnode) + Ntip(tree))
##         tree$node.label <- paste0("node",1:Nnode(tree))
##     }
##     
##     ## reroot tree
##     tree <- root(tree, outgroup = outgroup, node = node,
##                  resolve.root = resolve.root, ...)
##     newobject@phylo <- tree
## 
##     ## update node numbers in data
##     n.tips <- Ntip(tree)
##     node_map<- attr(tree, "node_map")
##     if (is.null(node_map)) {
##         message("fail to assign associated data to rooted tree, only return tree structure (a phylo object)")
##         if (!resolve.root) {
##             message("maybe you can try again with `resolve.root = TRUE`")
##         }
##         return(tree)
##     }
## 
##     update_data <- function(data, node_map) {
##         newdata <- data
##         
##         indx <- match(node_map$from, data$node)
##         indx <- indx[!is.na(indx)]
##         
##         indy <- match(data$node, node_map$from)
##         indy <- indy[!is.na(indy)]
##         
##         newdata[indx, "node"] <- node_map[indy, "to"]
##         
##         # newdata[match(node_map$from, data$node), 'node'] <- node_map$to
## 
##         # clear root data
##         root <- newdata$node == (n.tips + 1)
##         newdata[root,] <- NA
##         newdata[root,'node'] <- n.tips + 1
##         
##         return(newdata)
##     }
##     
##     if (nrow(newobject@data) > 0) {
##         newobject@data <- update_data(object@data, node_map)
##     }
##     
##     if (nrow(object@extraInfo) > 0) {
##         newobject@extraInfo <- update_data(object@extraInfo, node_map)
##     }
##     
##     return(newobject)
## }

build_new_labels <- function(tree){
    node2label_old <- tree %>% as_tibble() %>% dplyr::select(c("node", "label")) 
    if (inherits(tree, "treedata")){
        tree <- tree@phylo
    }
    tree$tip.label <- paste0("t", seq_len(Ntip(tree)))
    tree$node.label <- paste0("n", seq_len(Nnode(tree)))
    node2label_new <- tree %>% as_tibble() %>% dplyr::select(c("node", "label")) 
    old_and_new <- node2label_old %>% 
                   dplyr::inner_join(node2label_new, by="node") %>%
                   dplyr::rename(old="label.x", new="label.y") 
    return (list(tree=tree, node2old_new_lab=old_and_new))
}

build_new_tree <- function(tree, node2old_new_lab){
    # replace new label with old label
    treeda <- tree %>% as_tibble()
    treeda1 <- treeda %>%
               dplyr::filter(.data$label %in% node2old_new_lab$new)
    treeda2 <- treeda %>%
               dplyr::filter(!(.data$label %in% node2old_new_lab$new))
    # original label
    treeda1$label <- node2old_new_lab[match(treeda1$label, node2old_new_lab$new), "old"] %>%
                     unlist(use.names=FALSE)
    treeda <- rbind(treeda1, treeda2)
    tree <- treeda[order(treeda$node),] %>% as.phylo() 
    return (tree)
}