deleted file mode 100644

@@ -1,281 +0,0 @@

-

-## ##' read beast output

-## ##'

-## ##'

-## ##' @title read.beast

-## ##' @param file beast file

-## ##' @return \code{beast} object

-## ##' @importFrom ape read.nexus

-## ##' @export

-## ##' @author Guangchuang Yu \url{http://ygc.name}

-## ##' @examples

-## ##' file <- system.file("extdata/BEAST", "beast_mcc.tree", package="ggtree")

-## ##' read.beast(file)

-## read.beast <- function(file) {

-##     translation <- read.trans_beast(file)

-##     treetext <- read.treetext_beast(file)

-##     stats <- read.stats_beast(file)

-##     phylo <- read.nexus(file)

-

-##     if (length(treetext) == 1) {

-##         obj <- BEAST(file, treetext, translation, stats, phylo)

-##     } else {

-##         obj <- lapply(seq_along(treetext), function(i) {

-##             BEAST(file, treetext[i], translation, stats[[i]], phylo[[i]])

-##         })

-##         class(obj) <- "beastList"

-##     }

-##     return(obj)

-## }

-

-

-## BEAST <- function(file, treetext, translation, stats, phylo) {

-##     stats$node %<>% gsub("\"*'*", "", .)

-

-##     fields <- sub("_lower|_upper", "", names(stats)) %>% unique

-##     fields %<>% `[`(.!="node")

-

-##     phylo <- remove_quote_in_tree_label(phylo)

-

-##     obj <- new("beast",

-##                fields      = fields,

-##                treetext    = treetext,

-##                phylo       = phylo,

-##                translation = translation,

-##                stats       = stats,

-##                file        = filename(file)

-##                )

-##     return(obj)

-## }

-

-## remove_quote_in_tree_label <- function(phylo) {

-##     if (!is.null(phylo$node.label)) {

-##         phylo$node.label %<>% gsub("\"*'*", "", .)

-##     }

-##     if ( !is.null(phylo$tip.label)) {

-##         phylo$tip.label %<>% gsub("\"*'*", "", .)

-##     }

-##     return(phylo)

-## }

-

-

-## ##' @rdname get.fields-methods

-## ##' @exportMethod get.fields

-## setMethod("get.fields", signature(object="beast"),

-##           function(object, ...) {

-##               get.fields.tree(object)

-##           }

-##           )

-

-

-## read.treetext_beast <- function(file) {

-##     beast <- readLines(file)

-

-##     ii <- grep("[Bb]egin trees;", beast)

-##     jj <- grep("[Ee]nd;", beast)

-##     jj <- jj[jj > max(ii)][1]

-##     jj <- c(ii[-1], jj)

-

-##     trees <- sapply(seq_along(ii), function(i) {

-##         tree <- beast[(ii[i]+1):(jj[i]-1)]

-##         tree <- tree[grep("\\s*[Tt]ree", tree)]

-##         ## if (length(tree) > 1) {

-##         ##     tree <- paste0(tree, collapse='')

-##         ## }

-##         sub("[^(]*", "", tree)

-##     })

-

-##     return(trees)

-## }

-

-## read.trans_beast <- function(file) {

-##     beast <- readLines(file)

-##     i <- grep("TRANSLATE", beast, ignore.case = TRUE)

-##     if (length(i) == 0) {

-##         return(matrix())

-##     }

-##     end <- grep(";", beast)

-##     j <- end[end %>% `>`(i) %>% which %>% `[`(1)]

-##     trans <- beast[(i+1):j]

-##     trans %<>% gsub("\\t+", "", .)

-##     trans %<>% gsub(",|;", "", .)

-##     trans %<>% `[`(nzchar(trans))

-##     ## remove quote if strings were quoted

-##     trans %<>% gsub("'|\"", "",.)

-##     trans %<>% sapply(., strsplit, split="\\s+")

-##     trans %<>% do.call(rbind, .)

-##     ## trans is a matrix

-##     return(trans)

-## }

-

-

-## read.stats_beast <- function(file) {

-##     beast <- readLines(file)

-##     trees <- read.treetext_beast(file)

-##     if (length(trees) == 1) {

-##         return(read.stats_beast_internal(beast, trees))

-##     }

-##     lapply(trees, read.stats_beast_internal, beast=beast)

-## }

-

-## read.stats_beast_internal <- function(beast, tree) {

-##     tree2 <- gsub("\\[[^\\[]*\\]", "", tree)

-##     phylo <- read.tree(text = tree2)

-

-##     tree2 <- add_pseudo_nodelabel(phylo, tree2)

-

-##     ## node name corresponding to stats

-##     nn <- strsplit(tree2, split=",") %>% unlist %>%

-##         strsplit(., split="\\)") %>% unlist %>%

-##         gsub("\\(*", "", .) %>%

-##         gsub("[:;].*", "", .)

-

-##     phylo <- read.tree(text = tree2)

-##     root <- getRoot(phylo)

-##     nnode <- phylo$Nnode

-

-##     ## phylo2 <- read.nexus(file)

-##     ## treeinfo <- fortify.phylo(phylo)

-##     ## treeinfo2 <- fortify.phylo(phylo2)

-##     ## treeinfo$label2 <- NA

-##     ## treeinfo$label2[treeinfo$isTip] <- treeinfo2$node[as.numeric(treeinfo$label[treeinfo$isTip])]

-##     ## treeinfo$visited <- FALSE

-##     ## root <- getRoot(phylo2)

-##     ## treeinfo[root, "visited"] <- TRUE

-##     ## currentNode <- 1:Ntip(phylo2)

-##     ## while(any(treeinfo$visited == FALSE)) {

-##     ##     pNode <- c()

-##     ##     for (kk in currentNode) {

-##     ##         i <- which(treeinfo$label2 == kk)

-##     ##         treeinfo[i, "visited"] <- TRUE

-##     ##         j <- which(treeinfo2$node == kk)

-##     ##         ip <- treeinfo$parent[i]

-##     ##         if (ip != root) {

-##     ##             ii <- which(treeinfo$node == ip)

-##     ##             if (treeinfo$visited[ii] == FALSE) {

-##     ##                 jp <- treeinfo2$parent[j]

-##     ##                 jj <- which(treeinfo2$node == jp)

-##     ##                 treeinfo[ii, "label2"] <- treeinfo2[jj, "node"]

-##     ##                 pNode <- c(pNode, jp)

-##     ##             }

-##     ##             treeinfo[ii, "visited"] <- TRUE

-##     ##         }

-##     ##     }

-##     ##     currentNode <- unique(pNode)

-##     ## }

-##     ## treeinfo[root, "label2"] <- root

-##     ## ## convert nn to node that encoded in phylo2

-##     ## node <- treeinfo$label2[match(nn, treeinfo$label)]

-

-

-##     ####################################################

-##     ##                                                ##

-##     ##  after doing it in the hard way                ##

-##     ##  I finally figure out the following easy way   ##

-##     ##                                                ##

-##     ####################################################

-##     treeinfo <- fortify.phylo(phylo)

-

-##     if (any(grepl("TRANSLATE", beast, ignore.case = TRUE))) {

-##         label2 <- c(treeinfo[treeinfo$isTip, "label"],

-##                     root:(root+nnode-1))

-##         node <- label2[match(nn, treeinfo$label)]

-##     } else {

-##         node <- as.character(treeinfo$node[match(nn, treeinfo$label)])

-##     }

-

-##     ## stats <- unlist(strsplit(tree, "\\["))[-1]

-##     ## stats <- sub(":.+$", "", stats

-##     stats <- strsplit(tree, ":") %>% unlist

-##     names(stats) <- node

-##     stats <- stats[grep("\\[", stats)]

-##     stats <- sub("[^\\[]+\\[", "", stats)

-

-##     stats <- sub("^&", "", stats)

-##     stats <- sub("];*$", "", stats)

-

-##     stats2 <- lapply(stats, function(x) {

-##         y <- unlist(strsplit(x, ","))

-##         sidx <- grep("=\\{", y)

-##         eidx <- grep("\\}$", y)

-

-##         flag <- FALSE

-##         if (length(sidx) > 0) {

-##             flag <- TRUE

-##             SETS <- sapply(seq_along(sidx), function(k) {

-##                 p <- y[sidx[k]:eidx[k]]

-##                 gsub(".*=\\{", "", p) %>% gsub("\\}$", "", .) %>% list

-##             })

-##             names(SETS) <- gsub("=.*", "", y[sidx])

-

-##             kk <- sapply(seq_along(sidx), function(k) sidx[k]:eidx[k]) %>% unlist

-##             y <- y[-kk]

-##         }

-

-

-##         name <- gsub("=.*", "", y)

-##         val <- gsub(".*=", "", y) %>% gsub("^\\{", "", .) %>%

-##             gsub("\\}$", "", .)

-

-

-##         if (flag) {

-##             nn <- c(name, names(SETS))

-##         } else {

-##             nn <- name

-##         }

-

-##         res <- character(length(nn))

-##         names(res) <- nn

-

-##         for (i in seq_along(name)) {

-##             res[i] <- val[i]

-##         }

-##         if (flag) {

-##             j <- i

-##             for (i in seq_along(SETS)) {

-##                 res[i+j] <- SETS[i]

-##             }

-##         }

-

-##         return(res)

-##     })

-

-##     nn <- lapply(stats2, names) %>% unlist %>%

-##         unique %>% sort

-

-##     ## stats3 is a matrix

-##     stats3 <- t(sapply(stats2, function(x) {

-##         for (ii in nn[!nn %in% names(x)]) {

-##             x[ii] <- NA

-##         }

-##         x[nn]

-##     }))

-

-##     stats3 <- as.data.frame(stats3)

-##     if (nrow(stats3) == 1) {

-##         ## only has one evidence

-##         ## transpose

-##         stats3 <- data.frame(X=unlist(stats3[1,]))

-##         colnames(stats3) <- nn

-##     }

-##     colnames(stats3) <- gsub("(\\d+)%", "0.\\1", colnames(stats3))

-

-##     ## stats3$node <- node

-##     stats3$node <- names(stats)

-##     return(stats3)

-## }

-

-## add_pseudo_nodelabel <- function(phylo, treetext) {

-##     if(is.null(phylo$node.label)) {

-##         nnode <- phylo$Nnode

-##         nlab <- paste("X", 1:nnode, sep="")

-##         for (i in 1:nnode) {

-##             treetext <- sub("\\)([:;])", paste0("\\)", nlab[i], "\\1"), treetext)

-##         }

-##     }

-

-##    return(treetext)

-## }

-

-

-

@@ -1,281 +1,281 @@

-##' read beast output

-##'

-##'

-##' @title read.beast

-##' @param file beast file

-##' @return \code{beast} object

-##' @importFrom ape read.nexus

-##' @export

-##' @author Guangchuang Yu \url{http://ygc.name}

-##' @examples

-##' file <- system.file("extdata/BEAST", "beast_mcc.tree", package="ggtree")

-##' read.beast(file)

-read.beast <- function(file) {

-    translation <- read.trans_beast(file)

-    treetext <- read.treetext_beast(file)

-    stats <- read.stats_beast(file)

-    phylo <- read.nexus(file)

-

-    if (length(treetext) == 1) {

-        obj <- BEAST(file, treetext, translation, stats, phylo)

-    } else {

-        obj <- lapply(seq_along(treetext), function(i) {

-            BEAST(file, treetext[i], translation, stats[[i]], phylo[[i]])

-        })

-        class(obj) <- "beastList"

-    }

-    return(obj)

-}

-

-

-BEAST <- function(file, treetext, translation, stats, phylo) {

-    stats$node %<>% gsub("\"*'*", "", .)

-

-    fields <- sub("_lower|_upper", "", names(stats)) %>% unique

-    fields %<>% `[`(.!="node")

-

-    phylo <- remove_quote_in_tree_label(phylo)

-

-    obj <- new("beast",

-               fields      = fields,

-               treetext    = treetext,

-               phylo       = phylo,

-               translation = translation,

-               stats       = stats,

-               file        = filename(file)

-               )

-    return(obj)

-}

-

-remove_quote_in_tree_label <- function(phylo) {

-    if (!is.null(phylo$node.label)) {

-        phylo$node.label %<>% gsub("\"*'*", "", .)

-    }

-    if ( !is.null(phylo$tip.label)) {

-        phylo$tip.label %<>% gsub("\"*'*", "", .)

-    }

-    return(phylo)

-}

-

-

-##' @rdname get.fields-methods

-##' @exportMethod get.fields

-setMethod("get.fields", signature(object="beast"),

-          function(object, ...) {

-              get.fields.tree(object)

-          }

-          )

-

-

-read.treetext_beast <- function(file) {

-    beast <- readLines(file)

-

-    ii <- grep("[Bb]egin trees;", beast)

-    jj <- grep("[Ee]nd;", beast)

-    jj <- jj[jj > max(ii)][1]

-    jj <- c(ii[-1], jj)

-

-    trees <- sapply(seq_along(ii), function(i) {

-        tree <- beast[(ii[i]+1):(jj[i]-1)]

-        tree <- tree[grep("\\s*[Tt]ree", tree)]

-        ## if (length(tree) > 1) {

-        ##     tree <- paste0(tree, collapse='')

-        ## }

-        sub("[^(]*", "", tree)

-    })

-

-    return(trees)

-}

-

-read.trans_beast <- function(file) {

-    beast <- readLines(file)

-    i <- grep("TRANSLATE", beast, ignore.case = TRUE)

-    if (length(i) == 0) {

-        return(matrix())

-    }

-    end <- grep(";", beast)

-    j <- end[end %>% `>`(i) %>% which %>% `[`(1)]

-    trans <- beast[(i+1):j]

-    trans %<>% gsub("\\t+", "", .)

-    trans %<>% gsub(",|;", "", .)

-    trans %<>% `[`(nzchar(trans))

-    ## remove quote if strings were quoted

-    trans %<>% gsub("'|\"", "",.)

-    trans %<>% sapply(., strsplit, split="\\s+")

-    trans %<>% do.call(rbind, .)

-    ## trans is a matrix

-    return(trans)

-}

-

-

-read.stats_beast <- function(file) {

-    beast <- readLines(file)

-    trees <- read.treetext_beast(file)

-    if (length(trees) == 1) {

-        return(read.stats_beast_internal(beast, trees))

-    }

-    lapply(trees, read.stats_beast_internal, beast=beast)

-}

-

-read.stats_beast_internal <- function(beast, tree) {

-    tree2 <- gsub("\\[[^\\[]*\\]", "", tree)

-    phylo <- read.tree(text = tree2)

-

-    tree2 <- add_pseudo_nodelabel(phylo, tree2)

-

-    ## node name corresponding to stats

-    nn <- strsplit(tree2, split=",") %>% unlist %>%

-        strsplit(., split="\\)") %>% unlist %>%

-        gsub("\\(*", "", .) %>%

-        gsub("[:;].*", "", .)

-

-    phylo <- read.tree(text = tree2)

-    root <- getRoot(phylo)

-    nnode <- phylo$Nnode

-

-    ## phylo2 <- read.nexus(file)

-    ## treeinfo <- fortify.phylo(phylo)

-    ## treeinfo2 <- fortify.phylo(phylo2)

-    ## treeinfo$label2 <- NA

-    ## treeinfo$label2[treeinfo$isTip] <- treeinfo2$node[as.numeric(treeinfo$label[treeinfo$isTip])]

-    ## treeinfo$visited <- FALSE

-    ## root <- getRoot(phylo2)

-    ## treeinfo[root, "visited"] <- TRUE

-    ## currentNode <- 1:Ntip(phylo2)

-    ## while(any(treeinfo$visited == FALSE)) {

-    ##     pNode <- c()

-    ##     for (kk in currentNode) {

-    ##         i <- which(treeinfo$label2 == kk)

-    ##         treeinfo[i, "visited"] <- TRUE

-    ##         j <- which(treeinfo2$node == kk)

-    ##         ip <- treeinfo$parent[i]

-    ##         if (ip != root) {

-    ##             ii <- which(treeinfo$node == ip)

-    ##             if (treeinfo$visited[ii] == FALSE) {

-    ##                 jp <- treeinfo2$parent[j]

-    ##                 jj <- which(treeinfo2$node == jp)

-    ##                 treeinfo[ii, "label2"] <- treeinfo2[jj, "node"]

-    ##                 pNode <- c(pNode, jp)

-    ##             }

-    ##             treeinfo[ii, "visited"] <- TRUE

-    ##         }

-    ##     }

-    ##     currentNode <- unique(pNode)

-    ## }

-    ## treeinfo[root, "label2"] <- root

-    ## ## convert nn to node that encoded in phylo2

-    ## node <- treeinfo$label2[match(nn, treeinfo$label)]

-

-

-    ####################################################

-    ##                                                ##

-    ##  after doing it in the hard way                ##

-    ##  I finally figure out the following easy way   ##

-    ##                                                ##

-    ####################################################

-    treeinfo <- fortify.phylo(phylo)

-

-    if (any(grepl("TRANSLATE", beast, ignore.case = TRUE))) {

-        label2 <- c(treeinfo[treeinfo$isTip, "label"],

-                    root:(root+nnode-1))

-        node <- label2[match(nn, treeinfo$label)]

-    } else {

-        node <- as.character(treeinfo$node[match(nn, treeinfo$label)])

-    }

-

-    ## stats <- unlist(strsplit(tree, "\\["))[-1]

-    ## stats <- sub(":.+$", "", stats

-    stats <- strsplit(tree, ":") %>% unlist

-    names(stats) <- node

-    stats <- stats[grep("\\[", stats)]

-    stats <- sub("[^\\[]+\\[", "", stats)

-

-    stats <- sub("^&", "", stats)

-    stats <- sub("];*$", "", stats)

-

-    stats2 <- lapply(stats, function(x) {

-        y <- unlist(strsplit(x, ","))

-        sidx <- grep("=\\{", y)

-        eidx <- grep("\\}$", y)

-

-        flag <- FALSE

-        if (length(sidx) > 0) {

-            flag <- TRUE

-            SETS <- sapply(seq_along(sidx), function(k) {

-                p <- y[sidx[k]:eidx[k]]

-                gsub(".*=\\{", "", p) %>% gsub("\\}$", "", .) %>% list

-            })

-            names(SETS) <- gsub("=.*", "", y[sidx])

-

-            kk <- sapply(seq_along(sidx), function(k) sidx[k]:eidx[k]) %>% unlist

-            y <- y[-kk]

-        }

-

-

-        name <- gsub("=.*", "", y)

-        val <- gsub(".*=", "", y) %>% gsub("^\\{", "", .) %>%

-            gsub("\\}$", "", .)

-

-

-        if (flag) {

-            nn <- c(name, names(SETS))

-        } else {

-            nn <- name

-        }

-

-        res <- character(length(nn))

-        names(res) <- nn

-

-        for (i in seq_along(name)) {

-            res[i] <- val[i]

-        }

-        if (flag) {

-            j <- i

-            for (i in seq_along(SETS)) {

-                res[i+j] <- SETS[i]

-            }

-        }

-

-        return(res)

-    })

-

-    nn <- lapply(stats2, names) %>% unlist %>%

-        unique %>% sort

-

-    ## stats3 is a matrix

-    stats3 <- t(sapply(stats2, function(x) {

-        for (ii in nn[!nn %in% names(x)]) {

-            x[ii] <- NA

-        }

-        x[nn]

-    }))

-

-    stats3 <- as.data.frame(stats3)

-    if (nrow(stats3) == 1) {

-        ## only has one evidence

-        ## transpose

-        stats3 <- data.frame(X=unlist(stats3[1,]))

-        colnames(stats3) <- nn

-    }

-    colnames(stats3) <- gsub("(\\d+)%", "0.\\1", colnames(stats3))

-

-    ## stats3$node <- node

-    stats3$node <- names(stats)

-    return(stats3)

-}

-

-add_pseudo_nodelabel <- function(phylo, treetext) {

-    if(is.null(phylo$node.label)) {

-        nnode <- phylo$Nnode

-        nlab <- paste("X", 1:nnode, sep="")

-        for (i in 1:nnode) {

-            treetext <- sub("\\)([:;])", paste0("\\)", nlab[i], "\\1"), treetext)

-        }

-    }

-

-   return(treetext)

-}

+## ##' read beast output

+## ##'

+## ##'

+## ##' @title read.beast

+## ##' @param file beast file

+## ##' @return \code{beast} object

+## ##' @importFrom ape read.nexus

+## ##' @export

+## ##' @author Guangchuang Yu \url{http://ygc.name}

+## ##' @examples

+## ##' file <- system.file("extdata/BEAST", "beast_mcc.tree", package="ggtree")

+## ##' read.beast(file)

+## read.beast <- function(file) {

+##     translation <- read.trans_beast(file)

+##     treetext <- read.treetext_beast(file)

+##     stats <- read.stats_beast(file)

+##     phylo <- read.nexus(file)

+

+##     if (length(treetext) == 1) {

+##         obj <- BEAST(file, treetext, translation, stats, phylo)

+##     } else {

+##         obj <- lapply(seq_along(treetext), function(i) {

+##             BEAST(file, treetext[i], translation, stats[[i]], phylo[[i]])

+##         })

+##         class(obj) <- "beastList"

+##     }

+##     return(obj)

+## }

+

+

+## BEAST <- function(file, treetext, translation, stats, phylo) {

+##     stats$node %<>% gsub("\"*'*", "", .)

+

+##     fields <- sub("_lower|_upper", "", names(stats)) %>% unique

+##     fields %<>% `[`(.!="node")

+

+##     phylo <- remove_quote_in_tree_label(phylo)

+

+##     obj <- new("beast",

+##                fields      = fields,

+##                treetext    = treetext,

+##                phylo       = phylo,

+##                translation = translation,

+##                stats       = stats,

+##                file        = filename(file)

+##                )

+##     return(obj)

+## }

+

+## remove_quote_in_tree_label <- function(phylo) {

+##     if (!is.null(phylo$node.label)) {

+##         phylo$node.label %<>% gsub("\"*'*", "", .)

+##     }

+##     if ( !is.null(phylo$tip.label)) {

+##         phylo$tip.label %<>% gsub("\"*'*", "", .)

+##     }

+##     return(phylo)

+## }

+

+

+## ##' @rdname get.fields-methods

+## ##' @exportMethod get.fields

+## setMethod("get.fields", signature(object="beast"),

+##           function(object, ...) {

+##               get.fields.tree(object)

+##           }

+##           )

+

+

+## read.treetext_beast <- function(file) {

+##     beast <- readLines(file)

+

+##     ii <- grep("[Bb]egin trees;", beast)

+##     jj <- grep("[Ee]nd;", beast)

+##     jj <- jj[jj > max(ii)][1]

+##     jj <- c(ii[-1], jj)

+

+##     trees <- sapply(seq_along(ii), function(i) {

+##         tree <- beast[(ii[i]+1):(jj[i]-1)]

+##         tree <- tree[grep("\\s*[Tt]ree", tree)]

+##         ## if (length(tree) > 1) {

+##         ##     tree <- paste0(tree, collapse='')

+##         ## }

+##         sub("[^(]*", "", tree)

+##     })

+

+##     return(trees)

+## }

+

+## read.trans_beast <- function(file) {

+##     beast <- readLines(file)

+##     i <- grep("TRANSLATE", beast, ignore.case = TRUE)

+##     if (length(i) == 0) {

+##         return(matrix())

+##     }

+##     end <- grep(";", beast)

+##     j <- end[end %>% `>`(i) %>% which %>% `[`(1)]

+##     trans <- beast[(i+1):j]

+##     trans %<>% gsub("\\t+", "", .)

+##     trans %<>% gsub(",|;", "", .)

+##     trans %<>% `[`(nzchar(trans))

+##     ## remove quote if strings were quoted

+##     trans %<>% gsub("'|\"", "",.)

+##     trans %<>% sapply(., strsplit, split="\\s+")

+##     trans %<>% do.call(rbind, .)

+##     ## trans is a matrix

+##     return(trans)

+## }

+

+

+## read.stats_beast <- function(file) {

+##     beast <- readLines(file)

+##     trees <- read.treetext_beast(file)

+##     if (length(trees) == 1) {

+##         return(read.stats_beast_internal(beast, trees))

+##     }

+##     lapply(trees, read.stats_beast_internal, beast=beast)

+## }

+

+## read.stats_beast_internal <- function(beast, tree) {

+##     tree2 <- gsub("\\[[^\\[]*\\]", "", tree)

+##     phylo <- read.tree(text = tree2)

+

+##     tree2 <- add_pseudo_nodelabel(phylo, tree2)

+

+##     ## node name corresponding to stats

+##     nn <- strsplit(tree2, split=",") %>% unlist %>%

+##         strsplit(., split="\\)") %>% unlist %>%

+##         gsub("\\(*", "", .) %>%

+##         gsub("[:;].*", "", .)

+

+##     phylo <- read.tree(text = tree2)

+##     root <- getRoot(phylo)

+##     nnode <- phylo$Nnode

+

+##     ## phylo2 <- read.nexus(file)

+##     ## treeinfo <- fortify.phylo(phylo)

+##     ## treeinfo2 <- fortify.phylo(phylo2)

+##     ## treeinfo$label2 <- NA

+##     ## treeinfo$label2[treeinfo$isTip] <- treeinfo2$node[as.numeric(treeinfo$label[treeinfo$isTip])]

+##     ## treeinfo$visited <- FALSE

+##     ## root <- getRoot(phylo2)

+##     ## treeinfo[root, "visited"] <- TRUE

+##     ## currentNode <- 1:Ntip(phylo2)

+##     ## while(any(treeinfo$visited == FALSE)) {

+##     ##     pNode <- c()

+##     ##     for (kk in currentNode) {

+##     ##         i <- which(treeinfo$label2 == kk)

+##     ##         treeinfo[i, "visited"] <- TRUE

+##     ##         j <- which(treeinfo2$node == kk)

+##     ##         ip <- treeinfo$parent[i]

+##     ##         if (ip != root) {

+##     ##             ii <- which(treeinfo$node == ip)

+##     ##             if (treeinfo$visited[ii] == FALSE) {

+##     ##                 jp <- treeinfo2$parent[j]

+##     ##                 jj <- which(treeinfo2$node == jp)

+##     ##                 treeinfo[ii, "label2"] <- treeinfo2[jj, "node"]

+##     ##                 pNode <- c(pNode, jp)

+##     ##             }

+##     ##             treeinfo[ii, "visited"] <- TRUE

+##     ##         }

+##     ##     }

+##     ##     currentNode <- unique(pNode)

+##     ## }

+##     ## treeinfo[root, "label2"] <- root

+##     ## ## convert nn to node that encoded in phylo2

+##     ## node <- treeinfo$label2[match(nn, treeinfo$label)]

+

+

+##     ####################################################

+##     ##                                                ##

+##     ##  after doing it in the hard way                ##

+##     ##  I finally figure out the following easy way   ##

+##     ##                                                ##

+##     ####################################################

+##     treeinfo <- fortify.phylo(phylo)

+

+##     if (any(grepl("TRANSLATE", beast, ignore.case = TRUE))) {

+##         label2 <- c(treeinfo[treeinfo$isTip, "label"],

+##                     root:(root+nnode-1))

+##         node <- label2[match(nn, treeinfo$label)]

+##     } else {

+##         node <- as.character(treeinfo$node[match(nn, treeinfo$label)])

+##     }

+

+##     ## stats <- unlist(strsplit(tree, "\\["))[-1]

+##     ## stats <- sub(":.+$", "", stats

+##     stats <- strsplit(tree, ":") %>% unlist

+##     names(stats) <- node

+##     stats <- stats[grep("\\[", stats)]

+##     stats <- sub("[^\\[]+\\[", "", stats)

+

+##     stats <- sub("^&", "", stats)

+##     stats <- sub("];*$", "", stats)

+

+##     stats2 <- lapply(stats, function(x) {

+##         y <- unlist(strsplit(x, ","))

+##         sidx <- grep("=\\{", y)

+##         eidx <- grep("\\}$", y)

+

+##         flag <- FALSE

+##         if (length(sidx) > 0) {

+##             flag <- TRUE

+##             SETS <- sapply(seq_along(sidx), function(k) {

+##                 p <- y[sidx[k]:eidx[k]]

+##                 gsub(".*=\\{", "", p) %>% gsub("\\}$", "", .) %>% list

+##             })

+##             names(SETS) <- gsub("=.*", "", y[sidx])

+

+##             kk <- sapply(seq_along(sidx), function(k) sidx[k]:eidx[k]) %>% unlist

+##             y <- y[-kk]

+##         }

+

+

+##         name <- gsub("=.*", "", y)

+##         val <- gsub(".*=", "", y) %>% gsub("^\\{", "", .) %>%

+##             gsub("\\}$", "", .)

+

+

+##         if (flag) {

+##             nn <- c(name, names(SETS))

+##         } else {

+##             nn <- name

+##         }

+

+##         res <- character(length(nn))

+##         names(res) <- nn

+

+##         for (i in seq_along(name)) {

+##             res[i] <- val[i]

+##         }

+##         if (flag) {

+##             j <- i

+##             for (i in seq_along(SETS)) {

+##                 res[i+j] <- SETS[i]

+##             }

+##         }

+

+##         return(res)

+##     })

+

+##     nn <- lapply(stats2, names) %>% unlist %>%

+##         unique %>% sort

+

+##     ## stats3 is a matrix

+##     stats3 <- t(sapply(stats2, function(x) {

+##         for (ii in nn[!nn %in% names(x)]) {

+##             x[ii] <- NA

+##         }

+##         x[nn]

+##     }))

+

+##     stats3 <- as.data.frame(stats3)

+##     if (nrow(stats3) == 1) {

+##         ## only has one evidence

+##         ## transpose

+##         stats3 <- data.frame(X=unlist(stats3[1,]))

+##         colnames(stats3) <- nn

+##     }

+##     colnames(stats3) <- gsub("(\\d+)%", "0.\\1", colnames(stats3))

+

+##     ## stats3$node <- node

+##     stats3$node <- names(stats)

+##     return(stats3)

+## }

+

+## add_pseudo_nodelabel <- function(phylo, treetext) {

+##     if(is.null(phylo$node.label)) {

+##         nnode <- phylo$Nnode

+##         nlab <- paste("X", 1:nnode, sep="")

+##         for (i in 1:nnode) {

+##             treetext <- sub("\\)([:;])", paste0("\\)", nlab[i], "\\1"), treetext)

+##         }

+##     }

+

+##    return(treetext)

+## }

@@ -1,7 +1,7 @@

 ##' read beast output

 ##'

-##' 

+##'

 ##' @title read.beast

 ##' @param file beast file

 ##' @return \code{beast} object

@@ -16,7 +16,7 @@ read.beast <- function(file) {

     treetext <- read.treetext_beast(file)

     stats <- read.stats_beast(file)

     phylo <- read.nexus(file)

-    

+

     if (length(treetext) == 1) {

         obj <- BEAST(file, treetext, translation, stats, phylo)

     } else {

@@ -31,12 +31,12 @@ read.beast <- function(file) {

 BEAST <- function(file, treetext, translation, stats, phylo) {

     stats$node %<>% gsub("\"*'*", "", .)

-    

+

     fields <- sub("_lower|_upper", "", names(stats)) %>% unique

     fields %<>% `[`(.!="node")

-        

+

     phylo <- remove_quote_in_tree_label(phylo)

-        

+

     obj <- new("beast",

                fields      = fields,

                treetext    = treetext,

@@ -53,7 +53,7 @@ remove_quote_in_tree_label <- function(phylo) {

         phylo$node.label %<>% gsub("\"*'*", "", .)

     }

     if ( !is.null(phylo$tip.label)) {