[Phylobase-commits] r400 - pkg/R

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

Author: francois
Date: 2008-12-24 00:39:33 +0100 (Wed, 24 Dec 2008)
New Revision: 400

Modified:
   pkg/R/methods-phylo4.R
   pkg/R/phylo4.R
Log:
implemented replace method for labels

Modified: pkg/R/methods-phylo4.R
===================================================================
--- pkg/R/methods-phylo4.R	2008-12-22 22:31:45 UTC (rev 399)
+++ pkg/R/methods-phylo4.R	2008-12-23 23:39:33 UTC (rev 400)
@@ -143,8 +143,9 @@
             )
 })
 
-setMethod("nodeLabels", "phylo4", function(x) {
-    x at node.label
+setMethod("nodeLabels", "phylo4", function(phy) {
+    #x at node.label
+    labels(phy, which="node")
 })
 
 setMethod("nodeId", "phylo4", function(x,which=c("internal","tip","all")) {
@@ -157,11 +158,8 @@
 
 setReplaceMethod("nodeLabels", "phylo4",
                  function(object, ..., value) {
-                   ## FIXME: test length!
-                   if (length(value)!=nNodes(object))
-                     stop("label vector must have as many elements as number of internal nodes")
-                   object at node.label <- value
-                   object
+                     labels(object, "node") <- value
+                     return(object)
                  })
 
 setMethod("edgeLabels", "phylo4", function(x) {
@@ -347,18 +345,46 @@
     length(x at edge.length)>0
 })
 
-setReplaceMethod("labels","phylo4", function(object,...,value) {
-    if (length(value) != length(object at tip.label))
-        stop("Number of tip labels does not match number of tips.")
-    object at tip.label <- value
-    object
-})
+setReplaceMethod("labels", "phylo4",
+   function(object, which = c("tip", "node", "allnode"), ..., value) {
+       which <- match.arg(which)
+       switch(which,
+              ## If 'tip'
+              tip = {
+                  if(length(value) != nTips(object))
+                      stop("Number of tip labels does not match number of tips.")
+                  else {
+                      object at tip.label[order(nodeId(object, "tip"))] <- value
+                      return(object)
+                  }
+              },
+              ## If 'node'
+              node = {
+                  if(length(value) != nNodes(object))
+                      stop("Number of node labels does not match number of internal nodes.")
+                  else {
+                      #object at node.label <- character(nNodes(object))
+                      object at node.label[order(nodeId(object, "internal"))] <- value
+                      return(object)
+                  }
+              },
+              ## If 'allnode'
+              allnode = {
+                  if(length(value) != nEdges(object))
+                      stop("Number of labels does not match total number of nodes.")
+                  else {
+                      object at tip.label[order(nodeId(object, "tip"))] <- value[1:nTips(object)]
+                      object at node.label[order(nodeId(object, "internal"))] <- value[-(1:nTips(object))]
+                      return(object)
+                  }
+              })
+   })
 
 orderIndex <- function(phy, order = c('preorder', 'postorder')) {
     ## recursive functions are placed first and calls to those functions below
     postOrder <- function(node) {
         ## this function returns a list of nodes in the post order traversal
-        ## get the descendants 
+        ## get the descendants
         ## dec <- edge[, 1] == node
         ## print(dec)
         ## recursive call to get the descendants of the descendants
@@ -373,22 +399,22 @@
         ## only difference here is that we record current node, then descendants
         return(c(node, unlist(mapply(preOrder, edge[edge[, 1] == node, 2]))))
     }
-    
+
     if(order == 'postorder') {
-        ## get an root node free edge matrix 
+        ## get an root node free edge matrix
         edge <- phy at edge[!is.na(phy at edge[, 1]), ]
         ## match the new node order to the old order to get an index
         index <- match(postOrder(rootNode(phy)), phy at edge[, 2])
-    
+
     } else if(order == 'preorder') {
-        ## get an root node free edge matrix 
+        ## get an root node free edge matrix
         edge <- phy at edge[!is.na(phy at edge[, 1]), ]
         ## match the new node order to the old order to get an index
         index <- match(preOrder(rootNode(phy)), phy at edge[, 2])
     } else {stop(paste("Method for", order, "not implemented"))}
 }
 
-setMethod("reorder", signature(x = 'phylo4'), 
+setMethod("reorder", signature(x = 'phylo4'),
     function(x, order = c('preorder', 'postorder')) {
     ## call orderIndex and use that index to order edges, labels and lengths
     order   <- match.arg(order)

Modified: pkg/R/phylo4.R
===================================================================
--- pkg/R/phylo4.R	2008-12-22 22:31:45 UTC (rev 399)
+++ pkg/R/phylo4.R	2008-12-23 23:39:33 UTC (rev 400)
@@ -56,15 +56,15 @@
 
 setGeneric("labels")
 
-setGeneric("labels<-", 
-           function(object, ..., value) {
+setGeneric("labels<-",
+           function(object, which, ..., value) {
                standardGeneric("labels<-")
            })
 
-setGeneric("nodeLabels", function(x) {
+setGeneric("nodeLabels", function(phy) {
     standardGeneric("nodeLabels")
 })
-setGeneric("nodeLabels<-", 
+setGeneric("nodeLabels<-",
            function(object, ..., value) {
                standardGeneric("nodeLabels<-")
            })
@@ -77,7 +77,7 @@
     standardGeneric("edgeLabels")
 })
 
-setGeneric("edgeLabels<-", 
+setGeneric("edgeLabels<-",
            function(object, ..., value) {
                standardGeneric("edgeLabels<-")
            })