1 ## all.equal.phylo.R (2006-09-12)
3 ## Global Comparison of two Phylogenies
5 ## Copyright 2006 Benoît Durand
6 ## modified by EP for the new coding of "phylo" (2006-10-04)
8 ## This file is part of the R-package `ape'.
9 ## See the file ../COPYING for licensing issues.
11 ### Recherche de la correspondance entre deux arbres
12 ### Parcours en profondeur et en parallèle des deux arbres (current et target)
13 ### current, target: les deux arbres à comparer
14 ### use.edge.length: faut-il comparer les longueurs de branches ?
15 ### use.tip.label: faut-il comparer les étiquettes de feuilles ou seulement la
16 ### topologie des deux arbres ?
17 ### index.return: si TRUE, retourner la matrice de correspondance entre noeuds
18 ### et feuilles, une matrice à deux colonnes (current et target) avec pour
19 ### chaque ligne des paires d'identifiants de noeuds/feuilles, tels qu'ils
20 ### apparaissent dans l'attribut 'edge' des objets phylo
21 ### tolerance, scale: paramètres de comparaison des longueurs de branches
22 ### (voir 'all.equal')
23 all.equal.phylo <- function(target, current,
24 use.edge.length = TRUE,
27 tolerance = .Machine$double.eps ^ 0.5,
30 same.node <- function(i, j) {
31 # Comparaison de un noeud et une feuille
32 if (xor(i > Ntip1, j > Ntip2)) return(NULL)
33 # Comparaison de deux feuilles
35 if (!use.tip.label) return(c(i, j))
36 if (current$tip.label[i] == target$tip.label[j])
40 # Comparaison de deux noeuds
41 i.children <- which(current$edge[, 1] == i)
42 j.children <- which(target$edge[, 1] == j)
43 if (length(i.children) != length(j.children)) return(NULL)
44 correspondance <- NULL
45 for (i.child in i.children) {
47 for (j.child in j.children) {
48 if (!use.edge.length ||
49 isTRUE(all.equal(current$edge.length[i.child],
50 target$edge.length[j.child],
51 tolerance = tolerance,
53 corresp <- same.node(current$edge[i.child, 2],
54 target$edge[j.child, 2])
55 if (!is.null(corresp)) break
57 if (is.null(corresp)) return(NULL)
58 correspondance <- c(correspondance, i, j, corresp)
59 j.children <- j.children[j.children != j.child]
61 return(correspondance)
64 Ntip1 <- length(target$tip.label)
65 Ntip2 <- length(current$tip.label)
68 if (root1 != root2) return(FALSE)
69 result <- same.node(root1, root2)
70 if (!isTRUE(index.return)) return(!is.null(result))
71 if (is.null(result)) return(result)
72 result <- t(matrix(result, nrow = 2))
73 colnames(result) = c('current', 'target')