[Phylobase-commits] r644 - pkg/R

[noreply at r-forge.r-project.org]

Author: regetz
Date: 2009-09-12 05:18:31 +0200 (Sat, 12 Sep 2009)
New Revision: 644

Modified:
   pkg/R/treewalk.R
Log:
fixed getEdge bug #647 and revamped function as proposed, but the
handling of missing values may still need to be changed


Modified: pkg/R/treewalk.R
===================================================================
--- pkg/R/treewalk.R	2009-09-12 01:32:25 UTC (rev 643)
+++ pkg/R/treewalk.R	2009-09-12 03:18:31 UTC (rev 644)
@@ -221,50 +221,32 @@
 ###########
 # getEdge
 ###########
-getEdge <- function(phy, node, type=c("node", "ancestor", "all"),
-                    output=c("otherEnd", "allEdge"),
-                    missing=c("warn", "OK", "fail")) {
+getEdge <- function(phy, node, type=c("descendant", "ancestor"),
+    missing=c("warn", "OK", "fail")) {
 
-    type <- match.arg(type)
-    res <- character(0)
-
     if(!identical(class(phy), "phylo4")) phy <- as(phy, "phylo4")
 
-    if(identical(type, "all")) {
-        if(!missing(node))
-            warning("Argument \'node\' is ignored if type=\"all\".")
-        if(!missing(output))
-            warning("Argument \'output\' is ignored if type=\"all\".")
-        res <- names(phy at edge.length)
-    }
-    else {
-        missing <- match.arg(missing)
-        output <- match.arg(output)
-        node <- getNode(phy, node, missing)
+    missing <- match.arg(missing)
+    node <- getNode(phy, node, missing)
 
-        nd <- lapply(node, function(x) {
-            if(is.na(x))
-                res <- NA
-            else {
-                ndTmp <- switch(type,
-                                node = paste("-", x, sep=""),
-                                ancestor = paste(x, "-", sep=""))
-                res <- grep(ndTmp, names(phy at edge.length), value=TRUE)
-            }
-        })
-        nd <- unlist(nd)
-        if(identical(output, "allEdge"))
-            res <- nd
-        else {
-            nd <- strsplit(nd, "-")
+    type <- match.arg(type)
+
+    ##TODO: should missing arg also apply to tips-as-ancestors case?
+    nd <- lapply(node, function(x) {
+        if (is.na(x)) {
+            res <- NA
+        } else {
             res <- switch(type,
-                          node = sapply(nd, function(x) x[2]),
-                          ancestor = sapply(nd, function(x) x[1]))
-            res <- as.integer(res)
-        }
-    }
-    ## if we return names, then it gets confusing if it's not unique
-    ## for instance for edge 17 in geospiza, the names would be:
-    ## 171 172 173
-    unname(res)
+                descendant = edgeId(phy)[edges(phy)[,2] %in% x],
+                ancestor = edgeId(phy)[edges(phy)[,1] %in% x])
+            ## hack to return NA for tip nodes when type='ancestor'
+            if(length(res)==0) res <- NA
+            names(res) <- rep(x, length(res))
+        }   
+        names(res) <- rep(x, length(res))
+        res
+    })  
+
+    return(unlist(unname(nd)))
+
 }