R/as.phylo.formula.R

   1 ## as.phylo.formula.R (2005-12-10)
   2
   3 ##   Conversion from Taxonomy Variables to Phylogenetic Trees
   4
   5 ## Copyright 2005 Julien Dutheil
   6
   7 ## This file is part of the R-package `ape'.
   8 ## See the file ../COPYING for licensing issues.
   9
  10 as.phylo.formula <- function(x, data=parent.frame(), ...)
  11 {
  12   # Testing formula syntax:
  13   err <- "Formula must be of the kind \"~A1/A2/.../An\"."
  14   if(length(x) != 2) stop(err)
  15   if(x[[1]] != "~") stop(err)
  16   f <- x[[2]]
  17   taxo <- list()
  18   while(length(f) == 3) {
  19     if(f[[1]] != "/") stop(err)
  20     if(!is.factor(data[[deparse(f[[3]])]])) stop(paste("Variable", deparse(f[[3]]), "must be a factor."))
  21     taxo[[deparse(f[[3]])]] <- data[[deparse(f[[3]])]]
  22     if(length(f) > 1) f <- f[[2]]
  23   }
  24   if(!is.factor(data[[deparse(f)]])) stop(paste("Variable", deparse(f), "must be a factor."))
  25   taxo[[deparse(f)]] <- data[[deparse(f)]]
  26   taxo.data <- as.data.frame(taxo)
  27   leaves.names <- as.character(taxo.data[,1])
  28   taxo.data[,1] <- 1:nrow(taxo.data)
  29   # Now builds the phylogeny:
  30
  31   f.rec <- function(subtaxo) { # Recurrent utility function
  32     u <- ncol(subtaxo)
  33     levels <- unique(subtaxo[,u])
  34     if(u == 1) {
  35       if(length(levels) != nrow(subtaxo))
  36         warning("Error, leaves names are not unique.")
  37       return(as.character(subtaxo[,1]))
  38     }
  39     t <- character(length(levels))
  40     for(l in 1:length(levels)) {
  41       x <- f.rec(subtaxo[subtaxo[,u] == levels[l],][1:(u-1)])
  42       if(length(x) == 1) t[l] <- x
  43       else t[l] <- paste("(", paste(x, collapse=","), ")", sep="")
  44     }
  45     return(t)
  46   }
  47   string <- paste("(", paste(f.rec(taxo.data), collapse=","), ");", sep="")
  48   phy<-read.tree(text=string)
  49   phy$tip.label <- leaves.names[as.numeric(phy$tip.label)]
  50   return(phy)
  51 }