1 ## bind.tree.R (2011-03-02)
5 ## Copyright 2003-2011 Emmanuel Paradis
7 ## This file is part of the R-package `ape'.
8 ## See the file ../COPYING for licensing issues.
10 `+.phylo` <- function(x, y)
12 p <- if (is.null(x$root.edge)) 0 else x$root.edge
13 bind.tree(x, y, position = p)
16 bind.tree <- function(x, y, where = "root", position = 0, interactive = FALSE)
18 nx <- length(x$tip.label)
21 ny <- length(y$tip.label)
25 lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
26 if (lastPP$type != "phylogram" || lastPP$direction != "rightwards")
27 stop("you must plot tree 'x' as a 'rightward phylogram'")
28 cat("Click where you want to graft tree 'y'...\n")
30 d <- abs(xy$y - lastPP$yy)
31 d[lastPP$xx - xy$x < 0] <- Inf
33 position <- lastPP$xx[where] - xy$x
34 if (position < 0) position <- 0
35 cat("The following parameters are used:\n")
36 cat(" where =", where, " position =", position, "\n")
38 if (where == 0 || where == "root") where <- ROOTx
39 if (position < 0) position <- 0
41 stop("argument 'where' out of range for tree 'x'")
44 ## check whether both trees have branch lengths:
45 switch(is.null(x$edge.length) + is.null(y$edge.length) + 1L,
47 x$edge.length <- y$edge.length <- NULL
49 warning("one tree has no branch lengths, they have been ignored")
53 yHasNoRootEdge <- is.null(y$root.edge)
54 xHasNoRootEdge <- is.null(x$root.edge)
56 ## find the row of 'where' before renumbering
57 if (where == ROOTx) case <- 1 else {
58 i <- which(x$edge[, 2] == where)
59 case <- if (where <= nx) 2 else 3
61 ## case = 1 -> y is bound on the root of x
62 ## case = 2 -> y is bound on a tip of x
63 ## case = 3 -> y is bound on a node of x
65 ## check that 'position' is correct
68 stop("'position' is non-null but trees have no branch lengths")
71 stop("tree 'x' has no root edge")
72 if (position > x$root.edge)
73 stop("'position' is larger than x's root edge")
75 if (x$edge.length[i] < position)
76 stop("'position' is larger than the branch length")
80 ## the special case of substituting two tips:
81 if (case == 2 && ny == 1 && !position) {
82 x$tip.label[x$edge[i, 2]] <- y$tip.label
84 x$edge.length[i] <- x$edge.length[i] + y$edge.length
91 ### because in all situations internal nodes need to be
92 ### renumbered, they are changed to negatives first, and
93 ### nodes eventually added will be numbered sequentially
96 x$edge[nodes] <- -(x$edge[nodes] - nx) # -1, ..., -mx
98 y$edge[nodes] <- -(y$edge[nodes] - ny + mx) # -(mx+1), ..., -(mx+my)
99 ROOT <- -1L # may change later
100 next.node <- -(mx + my) - 1L
102 ## renumber now the tips in y:
103 new.nx <- if (where <= nx && !position) nx - 1L else nx
104 y$edge[!nodes] <- y$edge[!nodes] + new.nx
106 ## if 'y' as a root edge, use it:
107 if (!yHasNoRootEdge) {
108 y$edge <- rbind(c(0, y$edge[1]), y$edge)
109 ## ^ will be filled later
110 next.node <- next.node - 1L
111 if (wbl) y$edge.length <- c(y$root.edge, y$edge.length)
114 switch(case, { # case = 1
116 x$root.edge <- x$root.edge - position
117 x$edge <- rbind(c(next.node, x$edge[1]), x$edge)
119 if (wbl) x$edge.length <- c(position, x$edge.length)
121 if (yHasNoRootEdge) {
122 j <- which(y$edge[, 1] == y$edge[1])
124 } else y$edge[1] <- ROOT
125 x$edge <- rbind(x$edge, y$edge)
127 x$edge.length <- c(x$edge.length, y$edge.length)
130 x$edge[i, 2] <- next.node
131 x$edge <- rbind(x$edge[1:i, ], c(next.node, where), x$edge[-(1:i), ])
133 x$edge.length[i] <- x$edge.length[i] - position
134 x$edge.length <- c(x$edge.length[1:i], position, x$edge.length[-(1:i)])
137 if (yHasNoRootEdge) {
138 j <- which(y$edge[, 1] == y$edge[1])
139 y$edge[j, 1] <- x$edge[i, 1]
140 } else y$edge[1] <- x$edge[i, 1]
142 if (yHasNoRootEdge) x$edge[i, 2] <- y$edge[1]
144 ## the root edge of y is fused with the terminal edge of x
145 if (wbl) y$edge.length[1] <- y$edge.length[1] + x$edge.length[i]
146 y$edge[1] <- x$edge[i, 1]
147 ## delete i-th edge in x:
148 x$edge <- x$edge[-i, ]
150 if (wbl) x$edge.length <- x$edge.length[-i]
152 x$tip.label <- x$tip.label[-where]
153 ## renumber the tips that need to:
154 ii <- which(x$edge[, 2] > where & x$edge[, 2] <= nx)
155 x$edge[ii, 2] <- x$edge[ii, 2] - 1L
157 x$edge <- rbind(x$edge[1:i, ], y$edge, x$edge[-(1:i), ])
159 x$edge.length <- c(x$edge.length[1:i], y$edge.length, x$edge.length[-(1:i)])
162 if (yHasNoRootEdge) {
163 j <- which(y$edge[, 1] == y$edge[1])
164 y$edge[j, 1] <- next.node
165 } else y$edge[1] <- next.node
166 x$edge <- rbind(x$edge[1:i, ], c(next.node, x$edge[i, 2]), x$edge[-(1:i), ])
167 x$edge[i, 2] <- next.node
169 x$edge.length[i] <- x$edge.length[i] - position
170 x$edge.length <- c(x$edge.length[1:i], position, x$edge.length[-(1:i)])
174 if (yHasNoRootEdge) {
175 j <- which(y$edge[, 1] == y$edge[1])
176 y$edge[j, 1] <- x$edge[i, 2]
177 } else y$edge[1] <- x$edge[i, 2]
179 x$edge <- rbind(x$edge[1:i, ], y$edge, x$edge[-(1:i), ])
181 x$edge.length <- c(x$edge.length[1:i], y$edge.length, x$edge.length[-(1:i)])
184 x$tip.label <- c(x$tip.label, y$tip.label)
186 if (is.null(x$node.label)) {
187 if (!is.null(y$node.label))
188 x$node.label <- c(rep(NA, mx), y$node.label)
191 if (is.null(y$node.label)) c(x$node.label, rep(NA, my))
192 else c(x$node.label, y$node.label)
195 n <- length(x$tip.label)
196 x$Nnode <- dim(x$edge)[1] + 1L - n
198 ## update the node labels before renumbering (this adds NA for
199 ## the added nodes, and drops the label for those deleted)
200 if (!is.null(x$node.label))
201 x$node.label <- x$node.label[sort(-unique(x$edge[, 1]))]
204 newNb <- integer(x$Nnode)
205 newNb[-ROOT] <- n + 1L
206 sndcol <- x$edge[, 2] < 0
207 ## executed from right to left, so newNb is modified before x$edge:
208 x$edge[sndcol, 2] <- newNb[-x$edge[sndcol, 2]] <- n + 2:x$Nnode
209 x$edge[, 1] <- newNb[-x$edge[, 1]]
211 if (!is.null(x$node.label))
212 x$node.label <- x$node.label[order(newNb[newNb > 0])]