## ##' 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)
## }
