R/makeNodeLabel.R

   1 ## makeNodeLabel.R (2009-03-22)
   2
   3 ##   Makes Node Labels
   4
   5 ## Copyright 2009 Emmanuel Paradis
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 makeNodeLabel <- function(phy, method = "number", prefix = "Node",
  11                           nodeList = list(), ...)
  12 {
  13     method <- sapply(method, match.arg, c("number", "md5sum", "user"),
  14                      USE.NAMES = FALSE)
  15
  16     if ("number" %in% method)
  17         phy$node.label <- paste(prefix, 1:phy$Nnode, sep = "")
  18
  19     if ("md5sum" %in% method) {
  20         nl <- character(phy$Nnode)
  21         pp <- prop.part(phy, check.labels = FALSE)
  22         labs <- attr(pp, "labels")
  23         fl <- tempfile()
  24         for (i in seq_len(phy$Nnode)) {
  25             cat(sort(labs[pp[[i]]]), sep = "\n", file = fl)
  26             nl[i] <- tools::md5sum(fl)
  27         }
  28         unlink(fl)
  29         phy$node.label <- nl
  30     }
  31
  32     if ("user" %in% method) {
  33         if (is.null(phy$node.label))
  34             phy$node.label <- character(phy$Nnode)
  35         nl <- names(nodeList)
  36         if (is.null(nl)) stop("argument 'nodeList' has no names")
  37         Ntip <- length(phy$tip.label)
  38         seq.nod <- .Call("seq_root2tip", phy$edge, Ntip, phy$Nnode,
  39                          PACKAGE = "ape")
  40         ## a local version to avoid the above call many times:
  41         .getMRCA <- function(seq.nod, tip) {
  42             sn <- seq.nod[tip]
  43             MRCA <- Ntip + 1
  44             i <- 2
  45             repeat {
  46                 x <- unique(unlist(lapply(sn, "[", i)))
  47                 if (length(x) != 1) break
  48                 MRCA <- x
  49                 i <- i + 1
  50             }
  51             MRCA
  52         }
  53         for (i in seq_along(nodeList)) {
  54             tips <- sapply(nodeList[[i]], grep, phy$tip.label, ...,
  55                            USE.NAMES = FALSE)
  56             j <- .getMRCA(seq.nod, unique(unlist(tips)))
  57             phy$node.label[j - Ntip] <- nl[i]
  58         }
  59     }
  60     phy
  61 }