various fixes in C files

[ape.git] / R / bind.tree.R

diff --git a/R/bind.tree.R b/R/bind.tree.R
index 4202e2ea2b591a1af29a3a5dcc47f0ace1854cee..b43ce900055d4c393e324023ab7ff57801a0afe8 100644 (file)
--- a/R/bind.tree.R
+++ b/R/bind.tree.R
@@ -1,8 +1,8 @@
-## bind.tree.R (2010-03-15)
+## bind.tree.R (2012-02-13)
 
 ##    Bind Trees
 
-## Copyright 2003-2010 Emmanuel Paradis
+## Copyright 2003-2012 Emmanuel Paradis
 
 ## This file is part of the R-package `ape'.
 ## See the file ../COPYING for licensing issues.
@@ -46,7 +46,7 @@ bind.tree <- function(x, y, where = "root", position = 0, interactive = FALSE)
            wbl <- TRUE, {
                x$edge.length <- y$edge.length <- NULL
                wbl <- FALSE
-               warning("one tree has no branch lengths, they will be ignored")
+               warning("one tree has no branch lengths, they have been ignored")
            },
            wbl <- FALSE)
 
@@ -63,9 +63,11 @@ bind.tree <- function(x, y, where = "root", position = 0, interactive = FALSE)
     ## case = 3 -> y is bound on a node of x
 
     ## check that 'position' is correct
-    if (position) {
-        if (!wbl)
-            stop("'position' is non-null but trees have no branch lengths")
+    if (position && wbl) {
+### New in ape 3.0-1: this makes possible binding 'y' below
+### a node of 'x' thus creating a new node in 'x'
+###        if (!wbl)
+###            stop("'position' is non-null but trees have no branch lengths")
         if (case == 1) {
             if (xHasNoRootEdge)
                 stop("tree 'x' has no root edge")
@@ -77,17 +79,25 @@ bind.tree <- function(x, y, where = "root", position = 0, interactive = FALSE)
         }
     }
 
+    ## the special case of substituting two tips:
+    if (case == 2 && ny == 1 && !position) {
+        x$tip.label[x$edge[i, 2]] <- y$tip.label
+        if (wbl)
+            x$edge.length[i] <- x$edge.length[i] + y$edge.length
+        return(x)
+    }
+
     x <- reorder(x)
     y <- reorder(y)
 
-### because in all situations internal nodes need to be renumbered,
-### they are changed to negatives first, and nodes that eventually
-### will be added will be numbered sequentially
+### because in all situations internal nodes need to be
+### renumbered, they are changed to negatives first, and
+### nodes eventually added will be numbered sequentially
 
     nodes <- x$edge > nx
     x$edge[nodes] <- -(x$edge[nodes] - nx) # -1, ..., -mx
     nodes <- y$edge > ny
-    y$edge[nodes] <- -(y$edge[nodes] - ny + mx) #  -(mx+1), ..., -(mx+my)
+    y$edge[nodes] <- -(y$edge[nodes] - ny + mx) # -(mx+1), ..., -(mx+my)
     ROOT <- -1L # may change later
     next.node <- -(mx + my) - 1L
 
@@ -138,8 +148,8 @@ bind.tree <- function(x, y, where = "root", position = 0, interactive = FALSE)
                 y$edge[1] <- x$edge[i, 1]
                 ## delete i-th edge in x:
                 x$edge <- x$edge[-i, ]
-                i <- i - 1L
                 if (wbl) x$edge.length <- x$edge.length[-i]
+                i <- i - 1L
             }
             x$tip.label <- x$tip.label[-where]
             ## renumber the tips that need to:
@@ -190,19 +200,18 @@ bind.tree <- function(x, y, where = "root", position = 0, interactive = FALSE)
     ## update the node labels before renumbering (this adds NA for
     ## the added nodes, and drops the label for those deleted)
     if (!is.null(x$node.label))
-        x$node.label <- x$node.label[-unique(x$edge[, 1])]
+        x$node.label <- x$node.label[sort(-unique(x$edge[, 1]))]
 
     ## renumber nodes:
     newNb <- integer(x$Nnode)
     newNb[-ROOT] <- n + 1L
     sndcol <- x$edge[, 2] < 0
     ## executed from right to left, so newNb is modified before x$edge:
-    x$edge[sndcol, 2] <- newNb[-x$edge[sndcol, 2]] <-
-        (n + 2):(n + x$Nnode)
+    x$edge[sndcol, 2] <- newNb[-x$edge[sndcol, 2]] <- n + 2:x$Nnode
     x$edge[, 1] <- newNb[-x$edge[, 1]]
 
     if (!is.null(x$node.label))
-        x$node.label <- x$node.label[newNb[newNb == 0] - n]
+        x$node.label <- x$node.label[order(newNb[newNb > 0])]
 
     x
 }