1 ## bind.tree.R (2007-12-21)
5 ## Copyright 2003-2007 Emmanuel Paradis
7 ## This file is part of the R-package `ape'.
8 ## See the file ../COPYING for licensing issues.
10 bind.tree <- function(x, y, where = "root", position = 0)
12 nb.tip <- length(x$tip.label)
15 if (where == 0 || 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)
23 ## check whether both trees have branch lengths:
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
32 warning("one tree has no branch lengths, they will be ignored")
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"
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"
47 Node.Label.where <- x$node.label[where - nb.tip]
48 x$node.label[where - nb.tip] <- "TheNodeWhereToGraftY"
49 xHasNoNodeLabel <- FALSE
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) {
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
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
67 if (yHasNoRootEdge ) y$root.edge <- position
68 else y$root.edge <- y$root.edge + position
73 Y <- substr(Y, 1, nchar(Y) - 1)
75 if (where <= nb.tip) {
77 X <- gsub("TheTipWhereToGraftY",
78 paste("(", "TheTipWhereToGraftY", ",", Y, ")",
81 X <- gsub("TheTipWhereToGraftY", Y, X)
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 = "")
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))
99 ## now go back to find the left matching parentheses
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
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 = "")
112 X <- gsub("TheNodeWhereToGraftY",
113 paste("TheNodeWhereToGraftY", ",", Y,
116 xx <- paste(")", "TheNodeWhereToGraftY", sep = "")
117 X <- gsub(xx, paste(",", Y, xx, sep = ""), X)
120 phy <- read.tree(text = X)
121 ## restore the labels:
123 phy$tip.label[which(phy$tip.label == "TheTipWhereToGraftY")] <-
126 if (xHasNoNodeLabel) phy$node.label <- NULL
128 phy$node.label[which(phy$node.label == "TheNodeWhereToGraftY")] <-