[Phylobase-commits] r558 - in pkg: R inst/unitTests

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

Author: bbolker
Date: 2009-08-21 22:14:13 +0200 (Fri, 21 Aug 2009)
New Revision: 558

Modified:
   pkg/R/subset.R
   pkg/inst/unitTests/runit.subset.R
Log:
  reworked subset to address #595: added tests



Modified: pkg/R/subset.R
===================================================================
--- pkg/R/subset.R	2009-08-21 18:52:59 UTC (rev 557)
+++ pkg/R/subset.R	2009-08-21 20:14:13 UTC (rev 558)
@@ -6,33 +6,60 @@
 setMethod("subset", "phylo4",
           function(x,tips.include=NULL,tips.exclude=NULL,
                    mrca=NULL,node.subtree=NULL,...) {
-              ##  FIXME: could do eliminate NULL and make the test
+              ##  FIXME: could eliminate NULL and make the test
               ## if (!missing) rather than if (!is.null)
-              if (!is.null(tips.include)) {
-                  if (is.numeric(tips.include)) {
-                      tips.include <- x at tip.label[tips.include]
-                  }
-                  return(prune(x,x at tip.label[!(x at tip.label %in% tips.include)]))
+            ## (might have to change next line?)
+            if (sum(!sapply(list(tips.include,tips.exclude,
+                                 mrca,node.subtree),is.null))>1) {
+              stop("must specify at most one criterion for subsetting")
+            }
+            arglist <- list(...)
+            if (length(arglist)>0) {
+              warning("unused arguments: ",
+                      paste(names(arglist),collapse=","))
+            }
+            kept <- x at tip.label
+            dropped <- character(0)
+            if (!is.null(tips.include)) {
+              if (is.numeric(tips.include)) {
+                tips.include <- x at tip.label[tips.include]
               }
-              
-              if (!is.null(tips.exclude)) {
-                  return(prune(x,tips.exclude))
+              unknown <- setdiff(tips.include,x at tip.label)
+              if (length(unknown)>0) {
+                warning("unknown tip labels ignored:",
+                        paste(unknown,collapse=", "))
+                tips.include <- intersect(tips.include,x at tip.label)
               }
-              
-              if (!is.null(node.subtree)) {
-                  return(prune(x,x at tip.label[!(x at tip.label %in% names(descendants(x,node.subtree)))]))
+              kept <- tips.include
+              dropped <- setdiff(x at tip.label,tips.include)
+            }
+            if (!is.null(tips.exclude)) {
+              if (is.numeric(tips.exclude)) {
+                tips.exclude <- x at tip.label[tips.exclude]
               }
-              
-              if (!is.null(mrca)) {
-                  mnode <- MRCA(x,mrca)
-                  return(prune(x,x at tip.label[!(x at tip.label %in% names(descendants(x,mnode)))]))
+              unknown <- setdiff(tips.exclude,x at tip.label)
+              if (length(unknown)>0) {
+                warning("unknown tip labels ignored:",
+                        paste(unknown,collapse=", "))
+                tips.exclude <- intersect(tips.exclude,x at tip.label)
               }
-              arglist <- list(...)
-              if (length(arglist)>0) {
-                  warning("unused arguments: ",
-                          paste(names(arglist),collapse=","))
-              }
-              return(x)
+              dropped <- tips.exclude
+              kept <- setdiff(x at tip.label,tips.exclude)
+            }
+            if (!is.null(node.subtree)) {
+              kept <- intersect(x at tip.label,names(descendants(x,node.subtree)))
+              dropped <- setdiff(x at tip.label,kept)
+            }
+            if (!is.null(mrca)) {
+              mnode <- MRCA(x,mrca)
+              kept <- intersect(x at tip.label,names(descendants(x,mnode)))
+              dropped <- setdiff(x at tip.label,kept)
+            }
+            if (length(kept)<2) {
+              stop("0 or 1 tips would remain after subsetting")
+            }
+            if (length(dropped)==0) return(x)
+            return(prune(x,dropped))
           })
 
 

Modified: pkg/inst/unitTests/runit.subset.R
===================================================================
--- pkg/inst/unitTests/runit.subset.R	2009-08-21 18:52:59 UTC (rev 557)
+++ pkg/inst/unitTests/runit.subset.R	2009-08-21 20:14:13 UTC (rev 558)
@@ -21,6 +21,9 @@
     checkEquals(phy, subset(phy, seq_len(nTips(phy))))
     checkEquals(phy, phy[tipLabels(phy)])
     checkEquals(phy, phy[seq_len(nTips(phy))])
+    checkException(subset(phy,"spA"))
+    checkException(subset(phy,c("spA","spZ")))
+    checkException(subset(phy,c("spZ")))
 }
 
 test.subset.phylo4d <- function() {
@@ -30,9 +33,8 @@
     print(subset(phyd, 1:2))
     # check variants that should all return the original object
     checkEquals(phyd, subset(phyd))
-## TODO: These should ideally work. Bug #586
-#    checkEquals(phyd, subset(phyd, tipLabels(phyd)))
-#    checkEquals(phyd, subset(phyd, seq_len(nTips(phyd))))
+    checkEquals(phyd, subset(phyd, tipLabels(phyd)))
+    checkEquals(phyd, subset(phyd, seq_len(nTips(phyd))))
     checkEquals(phyd, phyd[tipLabels(phyd)])
     checkEquals(phyd, phyd[seq_len(nTips(phyd))])
 }