add function is_in_tree (workaround #31)

NAMESPACE

@@ -8,6 +8,7 @@ S3method(get_publication,study_meta)
 S3method(get_study_year,study_meta)
 S3method(get_tree_ids,study_meta)
 S3method(inspect,match_names)
+S3method(is_in_tree,otl_ott_id)
 S3method(is_suppressed,match_names)
 S3method(is_suppressed,taxon_info)
 S3method(is_suppressed,taxon_mrca)
@@ -68,6 +69,7 @@ export(get_study_tree)
 export(get_study_year)
 export(get_tree_ids)
 export(inspect)
+export(is_in_tree)
 export(is_suppressed)
 export(list_trees)
 export(ott_id)

R/is_in_tree.R

@@ -0,0 +1,50 @@
+##' Some valid taxonomic names do not occur in the Synthetic
+##' Tree. This convenience function allows you to check whether a
+##' given Open Tree Taxonomy identifier (OTT id) is in the tree. A taxonomic
+##' name may not occur in the synthetic tree because (1) it is an
+##' extinct or invalid taxon, or (2) it is part of a group that is not
+##' monophyletic in the tree.
+##'
+##' @title Check that OTT ids occur in the Synthetic Tree
+##' @param ott_ids a vector of Open Tree Taxonomy identifiers
+##' @param ...  additional arguments to customize the API request (see
+##'     \code{\link{rotl}} package documentation).
+##' @return A named logical vector. \code{TRUE} indicates that the OTT
+##'     id is in the synthetic tree, and \code{FALSE} that it is not.
+##' @examples
+##' \dontrun{
+##'   plant_families <- c("Asteraceae", "Solanaceae", "Poaceae", "Amaranthaceae",
+##'                       "Zamiaceae", "Araceae", "Juncaceae")
+##'   matched_names <- tnrs_match_names(plant_families)
+##'   ## This fails because some ott ids are not in the tree
+##'   ## plant_tree <- tol_induced_subtree(ott_id(matched_names))
+##'   ## So let's check which ones are actually in the tree first:
+##'   in_tree <- is_in_tree(ott_id(matched_names))
+##'   ## This now works:
+##'   plant_tree <- tol_induced_subtree(ott_id(matched_names)[in_tree])
+##' }
+##'
+##' @export
+is_in_tree <- function(ott_ids, ...) UseMethod("is_in_tree")
+
+
+##' @export
+is_in_tree.otl_ott_id <- function(ott_ids, ...) {
+
+    in_tree <- vapply(ott_ids, function(ottid) {
+        test <- try(tol_node_info(ottid, ...), silent = TRUE)
+        if (inherits(test, "try-error")) {
+            if (grepl("not find any synthetic tree nodes corresponding to the OTT id provided", test) &&
+                grepl(paste0("(", ottid, ")"), test)) {
+            } else {
+                warning("something seems off, check your internet connection?")
+            }
+            return(FALSE)
+        } else {
+            ott_id(test)[[1]] == ottid
+        }
+
+    }, logical(1), USE.NAMES = TRUE)
+
+    in_tree
+}

R/tax_utils.R

@@ -71,3 +71,9 @@ add_otl_class <- function(res, .f) {
                     class(res))
     res
 }
+
+`[.otl_ott_id` <- function(x, i, ...) {
+    r <- NextMethod("[")
+    class(r) <- class(x)
+    r
+}

tests/testthat/test-taxonomy.R

@@ -171,6 +171,15 @@ test_that("taxonomy_mrca with ott_id for tax_info", {
 })
 
 
+test_that("ott_id subset works", {
+    expect_true(inherits(ott_id(tax_info), "otl_ott_id"))
+    expect_true(inherits(ott_id(tax_info)[1], "otl_ott_id"))
+    expect_true(!is.null(names(ott_id(tax_info))))
+})
+
+
+
+
 ############################################################################
 ## taxon subtree                                                          ##
 ############################################################################
@@ -225,6 +234,8 @@ test_that("taxonomy subtree works if taxa has only 1 descendant", {
     expect_true(inherits(tt$tip_label, "character"))
 })
 
+
+
 ############################################################################
 ## taxonomic MRCA                                                         ##
 ############################################################################
@@ -254,7 +265,7 @@ test_that("mrca tax_name method", {
 
 test_that("mrca ott_id method", {
     skip_on_cran()
-    expect_equal(ott_id(tax_mrca)[1],
+    expect_equivalent(ott_id(tax_mrca)[1],
                  list("Asterales" = 1042120))
     expect_true(inherits(ott_id(tax_mrca), "otl_ott_id"))
 })
@@ -339,3 +350,25 @@ test_that("taxonomy_mrca with ott_id for tax_mrca", {
     expect_equivalent(ott_id(tax_mrca_mono),
                       ott_id(taxonomy_mrca(ott_id(tax_mrca_mono))))
 })
+
+test_that("ott_id subset works", {
+    expect_true(inherits(ott_id(tax_mrca_mono), "otl_ott_id"))
+    expect_true(inherits(ott_id(tax_mrca_mono)[1], "otl_ott_id"))
+    expect_true(!is.null(names(ott_id(tax_mrca_mono))))
+})
+
+
+
+### is_in_tree() ---------------------------------------------------------------
+
+if (identical(Sys.getenv("NOT_CRAN"), "true"))  {
+    spp <- c("Tyrannosaurus rex", "Velociraptor", "Fabaceae", "Solanaceae")
+    ot_names <- tnrs_match_names(spp)
+    ot_ids <- ott_id(ot_names)
+}
+
+test_that("test is_in_tree", {
+    in_tree <- is_in_tree(ot_ids)
+    expect_equal(sum(in_tree), 1)
+    expect_true(all(names(in_tree) %in% spp))
+})