R/as.matching.R

   1 ## as.matching.R (2011-02-26)
   2
   3 ##    Conversion Between Phylo and Matching Objects
   4
   5 ## Copyright 2005-2011 Emmanuel Paradis
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 as.matching <- function(x, ...) UseMethod("as.matching")
  11
  12 as.matching.phylo <- function(x, labels = TRUE, ...)
  13 {
  14     nb.tip <- length(x$tip.label)
  15     nb.node <- x$Nnode
  16     if (nb.tip != nb.node + 1)
  17         stop("the tree must be dichotomous AND rooted.")
  18     x <- reorder(x, "pruningwise")
  19     mat <- matrix(x$edge[, 2], ncol = 2, byrow = TRUE)
  20     nodes <- x$edge[seq(by = 2, length.out = nb.node), 1]
  21     ## we can use match() becoz each node appears once in `mat'
  22     O <- match(mat, nodes)
  23     new.nodes <- 1:nb.node + nb.tip
  24     sel <- !is.na(O)
  25     mat[sel] <- new.nodes[O[sel]]
  26     mat <- t(apply(mat, 1, sort))
  27
  28     obj <- list(matching = mat)
  29     if (!is.null(x$edge.length))
  30         warning("branch lengths have been ignored")
  31     if (labels) {
  32         obj$tip.label <- x$tip.label
  33         if (!is.null(x$node.label))
  34             obj$node.label <- x$node.label[match(new.nodes, nodes)]
  35     }
  36     class(obj) <- "matching"
  37     obj
  38 }
  39
  40 as.phylo.matching <- function(x, ...)
  41 {
  42     nb.node <- dim(x$matching)[1]
  43     nb.tip <- nb.node + 1
  44     N <- 2 * nb.node
  45     edge <- matrix(NA, N, 2)
  46     new.nodes <- numeric(N + 1)
  47     new.nodes[N + 1] <- nb.tip + 1
  48     nextnode <- nb.tip + 2
  49     j <- 1
  50     for (i in nb.node:1) {
  51         edge[j:(j + 1), 1] <- new.nodes[i + nb.tip]
  52         for (k in 1:2) {
  53             if (x$matching[i, k] > nb.tip) {
  54                 edge[j + k - 1, 2] <- new.nodes[x$matching[i, k]] <- nextnode
  55                 nextnode <- nextnode + 1
  56             } else edge[j + k - 1, 2] <- x$matching[i, k]
  57         }
  58         j <- j + 2
  59     }
  60     obj <- list(edge = edge)
  61     if (!is.null(x$tip.label)) obj$tip.label <- x$tip.label
  62     else obj$tip.label <- as.character(1:nb.tip)
  63     obj$Nnode <- nb.node
  64     class(obj) <- "phylo"
  65     read.tree(text = write.tree(obj))
  66 }