From de44f8279c7c1166029360a73b5813cdd21b1dcf Mon Sep 17 00:00:00 2001 From: Andrew Gene Brown Date: Fri, 10 Mar 2023 10:35:07 -0800 Subject: [PATCH] Add `taxonTree()` (#44) * Add `taxonTree()` #43 * taxonTree: cleanup and add customizable `level` argument * Add custom print method for data.tree subclass `SoilTaxonNode` #43 * verbose = FALSE default, no args to default print() method, allow replacement of all markup chars * Add support for custom (e.g. unicode) tree markup for printing * cleanup+test * skip test when data.tree not available --- DESCRIPTION | 3 +- NAMESPACE | 3 ++ R/taxonTree.R | 83 +++++++++++++++++++++++++++++++++ man/taxonTree.Rd | 47 +++++++++++++++++++ tests/testthat/test-taxonTree.R | 25 ++++++++++ 5 files changed, 160 insertions(+), 1 deletion(-) create mode 100644 R/taxonTree.R create mode 100644 man/taxonTree.Rd create mode 100644 tests/testthat/test-taxonTree.R diff --git a/DESCRIPTION b/DESCRIPTION index 041b58d..ce7021b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -20,7 +20,8 @@ Suggests: rmarkdown, markdown, soilDB, - ape + ape, + data.tree RoxygenNote: 7.2.3 Roxygen: list(markdown = TRUE) VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index 6d72933..2feef8b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,6 @@ # Generated by roxygen2: do not edit by hand +S3method(print,SoilTaxonNode) export(FormativeElements) export(GreatGroupFormativeElements) export(OrderFormativeElements) @@ -29,10 +30,12 @@ export(parent_level) export(parse_family) export(preceding_taxon_codes) export(relative_taxon_code_position) +export(taxonTree) export(taxon_code_to_taxon) export(taxon_to_level) export(taxon_to_taxon_code) import(data.table) +importFrom(stats,complete.cases) importFrom(stats,na.omit) importFrom(stats,setNames) importFrom(stringr,fixed) diff --git a/R/taxonTree.R b/R/taxonTree.R new file mode 100644 index 0000000..2fcdb2b --- /dev/null +++ b/R/taxonTree.R @@ -0,0 +1,83 @@ +#' Create a `data.tree` Object from Taxon Names +#' +#' This function takes one or more taxon names and taxonomic levels as input. +#' +#' A subclass of data.tree `Node` object is returned. This object has a custom `print()` method +#' +#' @param taxon A vector of taxon names +#' @param level One or more of: `"order"`, `"suborder"`, `"greatgroup"`, `"subgroup"`. The lowest level is passed to `getChildLevel()` to generate the leaf nodes. +#' @param root Label for root node. Default: `"Soil Taxonomy"`; `NULL` for "unrooted" tree. +#' @param verbose Print tree output? Default: `TRUE` +#' @param special.chars Characters used to print the tree to console. Default: `c("|", "|", "--")`. For fancy markup try: `c("\u251c", "\u2514", "\u2500 ")` +#' @param ... Additional arguments to `data.tree::as.Node.data.frame()` +#' +#' @return A `SoilTaxonNode` (subclass of `data.tree` `Node`) object (invisibly). A text representation of the tree is printed to stdout when `verbose=TRUE`. +#' @export +#' @importFrom stats complete.cases +#' @examplesIf !inherits(requireNamespace("data.tree", quietly = TRUE), 'try-error') +#' @examples +#' +#' # hapludults and hapludalfs (to subgroup level) +#' taxonTree(c("hapludults", "hapludalfs")) +#' +#' # alfisols suborders and great groups +#' taxonTree("alfisols", root = "Alfisols", level = c("suborder", "greatgroup")) +taxonTree <- function(taxon, + level = c("order", "suborder", "greatgroup", "subgroup"), + root = "Soil Taxonomy", + verbose = TRUE, + special.chars = c("|", "|", "--"), + ...) { + if (!requireNamespace("data.tree")) { + stop("package 'data.tree' is required", call. = FALSE) + } + + level <- tolower(trimws(level)) + + # get child taxa at most detailed `level` + lh <- level_hierarchy(family = FALSE) + lowest_level <- max(match(level, lh)) + x <- unique(do.call('c', getChildTaxa(taxon, + level = as.character(lh[lowest_level])))) + y <- getTaxonAtLevel(x, level = level) + + # we build the tree from the terminal/leaf node information + # parent taxa are included based on `level` + y <- y[order(taxon_to_taxon_code(x)),] + y <- y[stats::complete.cases(y),] + + # create data.tree node + y$pathString <- apply(data.frame(root, as.data.frame(lapply(level, function(z) { + paste0("/", y[[z]]) + }))), MARGIN = 1, FUN = paste0, collapse = "") + n <- data.tree::as.Node(y, ...) + + # allow for S3 dispatch for "soil taxonomic data.tree objects" SoilTaxonNode + attr(n, "class") <- c("SoilTaxonNode", attr(n, "class")) + + if (isTRUE(verbose)) { + print(n, special.chars = special.chars) + } + + invisible(n) +} + +#' @export +print.SoilTaxonNode <- function(x, + special.chars = "|", + ...) { + res <- as.data.frame(x, ...) + + # replace unicode markup + special.chars.default <- c("\u00a6", "\u00b0", "--") + if (is.null(special.chars) || length(special.chars) == 0) { + special.chars <- "|" + } + + special.chars <- rep(special.chars, 3)[1:3] + for (i in 1:3) { + res$levelName <- gsub(special.chars.default[i], special.chars[i], res$levelName, fixed = TRUE) + } + + cat(res$levelName, sep = "\n") +} diff --git a/man/taxonTree.Rd b/man/taxonTree.Rd new file mode 100644 index 0000000..5fe6c99 --- /dev/null +++ b/man/taxonTree.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/taxonTree.R +\name{taxonTree} +\alias{taxonTree} +\title{Create a \code{data.tree} Object from Taxon Names} +\usage{ +taxonTree( + taxon, + level = c("order", "suborder", "greatgroup", "subgroup"), + root = "Soil Taxonomy", + verbose = TRUE, + special.chars = c("|", "|", "--"), + ... +) +} +\arguments{ +\item{taxon}{A vector of taxon names} + +\item{level}{One or more of: \code{"order"}, \code{"suborder"}, \code{"greatgroup"}, \code{"subgroup"}. The lowest level is passed to \code{getChildLevel()} to generate the leaf nodes.} + +\item{root}{Label for root node. Default: \code{"Soil Taxonomy"}; \code{NULL} for "unrooted" tree.} + +\item{verbose}{Print tree output? Default: \code{TRUE}} + +\item{special.chars}{Characters used to print the tree to console. Default: \code{c("|", "|", "--")}. For fancy markup try: \code{c("\\u251c", "\\u2514", "\\u2500 ")}} + +\item{...}{Additional arguments to \code{data.tree::as.Node.data.frame()}} +} +\value{ +A \code{SoilTaxonNode} (subclass of \code{data.tree} \code{Node}) object (invisibly). A text representation of the tree is printed to stdout when \code{verbose=TRUE}. +} +\description{ +This function takes one or more taxon names and taxonomic levels as input. +} +\details{ +A subclass of data.tree \code{Node} object is returned. This object has a custom \code{print()} method +} +\examples{ +\dontshow{if (!inherits(requireNamespace("data.tree", quietly = TRUE), 'try-error')) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{\}) # examplesIf} + +# hapludults and hapludalfs (to subgroup level) +taxonTree(c("hapludults", "hapludalfs")) + +# alfisols suborders and great groups +taxonTree("alfisols", root = "Alfisols", level = c("suborder", "greatgroup")) +} diff --git a/tests/testthat/test-taxonTree.R b/tests/testthat/test-taxonTree.R new file mode 100644 index 0000000..1b7f323 --- /dev/null +++ b/tests/testthat/test-taxonTree.R @@ -0,0 +1,25 @@ +test_that("taxonTree works", { + + skip_if_not_installed("data.tree") + + tf <- tempfile() + sink(file = tf) + x <- taxonTree(c("hapludults", "hapludalfs")) + expect_true(inherits(x, 'SoilTaxonNode')) + + x <- taxonTree( + "alfisols", + root = "Alfisols", + level = c("suborder", "greatgroup"), + verbose = FALSE + ) + expect_true(inherits(x, 'SoilTaxonNode')) + + x <- taxonTree("durixeralfs", + special.chars = c("\u251c", + "\u2514", + "\u2500 ")) + sink() + expect_true(inherits(x, 'SoilTaxonNode')) + unlink(tf) +})