From ab5f8c8caa28bb6122fe1e77bb71d792f8f96430 Mon Sep 17 00:00:00 2001 From: Casey Dunn Date: Thu, 10 Nov 2016 17:36:17 -0500 Subject: [PATCH 1/2] nhx_tags node column now numeric, and dataframe sorted on this column --- R/NHX.R | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/R/NHX.R b/R/NHX.R index 855a4d93..e830aa3e 100644 --- a/R/NHX.R +++ b/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 ) } From b3528e999a40cd3649299256a7212088aa88db01 Mon Sep 17 00:00:00 2001 From: Casey Dunn Date: Thu, 10 Nov 2016 22:08:54 -0500 Subject: [PATCH 2/2] added drop.tip --- NAMESPACE | 2 ++ R/method-drop-tip.R | 57 +++++++++++++++++++++++++++++++++++++++ man/drop.tip-methods.Rd | 17 ++++++++++++ man/drop.tip.Rd | 18 +++++++++++++ tests/testthat/test-nhx.R | 8 ++++++ 5 files changed, 102 insertions(+) create mode 100644 R/method-drop-tip.R create mode 100644 man/drop.tip-methods.Rd create mode 100644 man/drop.tip.Rd diff --git a/NAMESPACE b/NAMESPACE index 63fe4b31..aaf6f99a 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/method-drop-tip.R b/R/method-drop-tip.R new file mode 100644 index 00000000..2c122a59 --- /dev/null +++ b/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) + }) diff --git a/man/drop.tip-methods.Rd b/man/drop.tip-methods.Rd new file mode 100644 index 00000000..990a7d2e --- /dev/null +++ b/man/drop.tip-methods.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/method-drop-tip.R +\docType{methods} +\name{drop.tip} +\alias{drop.tip} +\alias{drop.tip,nhx} +\title{drop.tip method} +\usage{ +drop.tip(object, tip...) +} +\description{ +drop.tip method +} +\author{ +Casey Dunn \url{http://dunnlab.org} +} + diff --git a/man/drop.tip.Rd b/man/drop.tip.Rd new file mode 100644 index 00000000..569b40ab --- /dev/null +++ b/man/drop.tip.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/method-drop-tip.R +\name{drop.tip} +\alias{drop.tip} +\title{Drop a tip} +\usage{ +drop.tip(object, ...) +} +\arguments{ +\item{object}{An nhx object} +} +\value{ +An nhx object +} +\description{ +Drop a tip +} + diff --git a/tests/testthat/test-nhx.R b/tests/testthat/test-nhx.R index a6c4e640..b4ba530f 100644 --- a/tests/testthat/test-nhx.R +++ b/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 ) }) \ No newline at end of file