More nhx stuff

NAMESPACE

@@ -39,6 +39,7 @@ export(as.polytomy)
 export(collapse)
 export(decimal2Date)
 export(download.phylopic)
+export(drop.tip)
 export(expand)
 export(facet_plot)
 export(flip)
@@ -141,6 +142,7 @@ exportClasses(phangorn)
 exportClasses(phylip)
 exportClasses(r8s)
 exportClasses(raxml)
+exportMethods(drop.tip)
 exportMethods(get.fields)
 exportMethods(get.placements)
 exportMethods(get.subs)

R/NHX.R

@@ -33,7 +33,7 @@ read.nhx <- function(file) {
     matches <- nhx.matches[[1]]
     match.pos <- as.numeric(matches)
     if (length(match.pos) == 1 && (match.pos == -1)) {
-        nhx_stats <- data.frame(node = treeinfo$node)
+        nhx_tags <- data.frame(node = as.numeric(treeinfo$node))
     } else {
         match.len <- attr(matches, 'match.length')
 
@@ -44,22 +44,25 @@ read.nhx <- function(file) {
             gsub("\\[&&NHX:", "", .) %>%
             gsub("\\]", "", .)
 
-        nhx_stats <- get_nhx_feature(nhx_features)
-        fields <- names(nhx_stats)
-        for (i in ncol(nhx_stats)) {
-            if(any(grepl("\\D+", nhx_stats[,i])) == FALSE) {
+        nhx_tags <- get_nhx_feature(nhx_features)
+        fields <- names(nhx_tags)
+        for (i in ncol(nhx_tags)) {
+            if(any(grepl("\\D+", nhx_tags[,i])) == FALSE) {
                 ## should be numerical varialbe
-                nhx_stats[,i] <- as.numeric(nhx_stats[,i])
+                nhx_tags[,i] <- as.numeric(nhx_tags[,i])
             }
         }
-        nhx_stats$node <- node
+        nhx_tags$node <- as.numeric(node)
     }
 
+    # Order rows by row number to facilitate downstream manipulations
+    nhx_tags=nhx_tags[order(nhx_tags$node),]
+
     new("nhx",
         file = filename(file),
         fields = fields,
         phylo = phylo,
-        nhx_tags = nhx_stats
+        nhx_tags = nhx_tags
         )
 }
 

R/method-drop-tip.R

@@ -0,0 +1,57 @@
+#' Drop a tip
+#' 
+#' @param object An nhx object
+#' @return An nhx object
+#' @export
+setGeneric (
+	name = "drop.tip", 
+	def = function( object, ... ) 
+		{ standardGeneric("drop.tip") }
+)
+
+
+##' drop.tip method
+##'
+##'
+##' @docType methods
+##' @name drop.tip
+##' @rdname drop.tip-methods
+##' @aliases drop.tip,nhx
+##' @exportMethod drop.tip
+##' @author Casey Dunn \url{http://dunnlab.org}
+##' @usage drop.tip(object, tip...)
+setMethod("drop.tip", signature(object="nhx"),
+		function(object, tip) {
+
+			# label the internal tree nodes by their number
+			object@phylo$node.label = NULL
+			object@phylo$node.label = (length(object@phylo$tip.label)+1):max(object@phylo$edge)
+
+			# Prepare the nhx object for subsampling
+			object@nhx_tags$node = as.numeric(object@nhx_tags$node)
+			object@nhx_tags = object@nhx_tags[order(object@nhx_tags$node),]
+
+			# add a colmn that has labels for both tips and internal nodes
+			object@nhx_tags$node.label = c(object@phylo$tip.label, as.character(object@phylo$node.label))
+
+			# Will need to take different approaches for subsampling tips 
+			# and internal nodes, add a column to make it easy to tell them apart
+			object@nhx_tags$is_tip = object@nhx_tags$node <= length(object@phylo$tip.label)
+
+			# Remove tips
+			object@phylo = ape::drop.tip( object@phylo, tip )
+
+			# Subsample the tags
+			object@nhx_tags = object@nhx_tags[object@nhx_tags$node.label %in% (c(object@phylo$tip.label, as.character(object@phylo$node.label))),]
+
+			# Update tip node numbers
+			tip_nodes = object@nhx_tags$node.label[ object@nhx_tags$is_tip ]
+			object@nhx_tags$node[ object@nhx_tags$is_tip ] = match(object@phylo$tip.label, tip_nodes)
+
+			# Clean up
+			object@nhx_tags$node.label = NULL
+			object@nhx_tags$is_tip = NULL
+
+
+            return(object)
+		})

tests/testthat/test-nhx.R

@@ -74,4 +74,12 @@ test_that("can parse phyldog nhx tree string", {
 	S.tip.values = c(58, 69, 70, 31, 37, 38, 61, 52, 53, 54, 65, 71, 64, 26, 16, 15)
 	expect_equal( S.tip.values[match(nhx@phylo$tip.label, tip.labels)], as.numeric(tip_tags$S))
 
+})
+
+test_that("can drop tips", {
+	nhx <- read.nhx( textConnection(test_phyldog_nhx_text) )
+		to_drop = c("Physonect_sp_@2066767", "Lychnagalma_utricularia@2253871", "Kephyes_ovata@2606431")
+
+	nhx_reduced = drop.tip(nhx, to_drop)
+	expect_equal( length(nhx_reduced@phylo$tip.label), 13 )
 })