R/bind.tree.R

   1 ## bind.tree.R (2007-12-21)
   2
   3 ##    Bind Trees
   4
   5 ## Copyright 2003-2007 Emmanuel Paradis
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 bind.tree <- function(x, y, where = "root", position = 0)
  11 {
  12     nb.tip <- length(x$tip.label)
  13     nb.node <- x$Nnode
  14     ROOT <- nb.tip + 1
  15     if (where == 0 || where == "root")
  16       where <- ROOT
  17     if (position < 0) position <- 0
  18     if (where > nb.tip + nb.node) stop("node number out of range for tree 'x'")
  19     nb.edge <- dim(x$edge)[1]
  20     yHasNoRootEdge <- is.null(y$root.edge)
  21     xHasNoRootEdge <- is.null(x$root.edge)
  22
  23     ## check whether both trees have branch lengths:
  24     wbl <- TRUE
  25     noblx <- is.null(x$edge.length)
  26     nobly <- is.null(y$edge.length)
  27     if (noblx && nobly) wbl <- FALSE
  28     if (xor(noblx, nobly)) {
  29         if (nobly) x$edge.length <- NULL
  30         else y$edge.length <- NULL
  31         wbl <- FALSE
  32         warning("one tree has no branch lengths, they will be ignored")
  33     }
  34
  35     ## To avoid problems with tips or nodes with indentical
  36     ## labels we substitute the one where `y' is grafted:
  37     if (where <= nb.tip) {
  38         Tip.Label.where <- x$tip.label[where]
  39         x$tip.label[where] <- "TheTipWhereToGraftY"
  40     }
  41     if (where > ROOT) {
  42         xHasNoNodeLabel <- TRUE
  43         if (is.null(x$node.label)) {
  44             x$node.label <- paste("NODE", 1:nb.node, sep = "")
  45             x$node.label[where - nb.tip] <- "TheNodeWhereToGraftY"
  46         } else {
  47             Node.Label.where <- x$node.label[where - nb.tip]
  48             x$node.label[where - nb.tip] <- "TheNodeWhereToGraftY"
  49             xHasNoNodeLabel <- FALSE
  50         }
  51     }
  52
  53     ## if we bind `y' under a node or tip of `y', we first
  54     ## adjust the edge lengths if needed
  55     if (position && wbl) {
  56         if (where == ROOT) {
  57             if (xHasNoRootEdge) stop("tree 'x' has no root edge")
  58             if (x$root.edge < position)
  59               stop("argument 'position' is larger than the root edge.")
  60             x$root.edge <- x$root.edge - position
  61         } else {
  62             i <- which(x$edge[, 2] == where)
  63             if (x$edge.length[i] < position)
  64               stop("argument 'position' is larger than the specified edge.")
  65             x$edge.length[i] <- x$edge.length[i] - position
  66         }
  67         if (yHasNoRootEdge ) y$root.edge <- position
  68         else y$root.edge <- y$root.edge + position
  69     }
  70
  71     X <- write.tree(x)
  72     Y <- write.tree(y)
  73     Y <- substr(Y, 1, nchar(Y) - 1)
  74
  75     if (where <= nb.tip) {
  76         if (position)
  77           X <- gsub("TheTipWhereToGraftY",
  78                     paste("(", "TheTipWhereToGraftY", ",", Y, ")",
  79                           sep = ""), X)
  80         else
  81           X <- gsub("TheTipWhereToGraftY", Y, X)
  82     }
  83     if (where == ROOT) {
  84         rmvx <- if (xHasNoRootEdge) "\\);$" else ";$"
  85         X <- gsub(rmvx, "", X)
  86         Y <- gsub("^\\(", "", Y)
  87         if (!xHasNoRootEdge) X <- paste("(", X, sep = "")
  88         X <- paste(X, ",", Y, ";", sep = "")
  89     }
  90     if (where > ROOT) {
  91         if (position) {
  92             ## find where is the node in `X':
  93             ## below 19 is: nchar("TheNodeWhereToGraftY") - 1
  94             for (i in 1:nchar(X)) {
  95                 if ("TheNodeWhereToGraftY" == substr(X, i, i + 19))
  96                   break
  97                 i <- i + 1
  98             }
  99             ## now go back to find the left matching parentheses
 100             n.paren <- 1
 101             i <- i - 2
 102             while (n.paren > 0) {
 103                 if (substr(X, i, i) == ")") n.paren <- n.paren + 1
 104                 if (substr(X, i, i) == "(") n.paren <- n.paren - 1
 105                 i <- i - 1
 106             }
 107             ## insert the left parenthesis:
 108             ## here 21 is: nchar("TheNodeWhereToGraftY") + 1
 109             X <- paste(substr(X, 1, i - 1), "(",
 110                        substr(X, i, 21), sep = "")
 111             ## and insert `y':
 112             X <- gsub("TheNodeWhereToGraftY",
 113                       paste("TheNodeWhereToGraftY", ",", Y,
 114                             sep = ""), X)
 115         } else {
 116             xx <- paste(")", "TheNodeWhereToGraftY", sep = "")
 117             X <- gsub(xx, paste(",", Y, xx, sep = ""), X)
 118         }
 119     }
 120     phy <- read.tree(text = X)
 121     ## restore the labels:
 122     if (where <= nb.tip)
 123       phy$tip.label[which(phy$tip.label == "TheTipWhereToGraftY")] <-
 124         Tip.Label.where
 125     if (where > ROOT) {
 126         if (xHasNoNodeLabel) phy$node.label <- NULL
 127         else
 128           phy$node.label[which(phy$node.label == "TheNodeWhereToGraftY")] <-
 129             Node.Label.where
 130     }
 131     phy
 132 }