tests/testthat/test-classification.R

In taxize: Taxonomic Information from Around the Web

# tests for classification fxn in taxize
context("classification")

# is_up <- function(seconds=3, which="itis"){
#   itisfxn <- function(x) tryCatch(itis_ping(config=timeout(x)), error=function(e) e)
#   switch(which,
#          itis = !is(itisfxn(seconds), "OPERATION_TIMEDOUT")
#   )
# }
#
# is_up()
# is_up(which = "ncbi")
#
# skip_if <- function(x){
#   if(!res) skip("API down")
#
#   expect_is(classification(c("Chironomus riparius", "aaa vva"), db = 'itis', messages = FALSE), "classification")
# }

# tpsids <- get_tpsid(sciname=c("Helianthus excubitor", "aaa vva"), messages = FALSE)
# clas_tpids <- classification(tpsids, messages = FALSE)

# clas_tp <- suppressMessages(classification(c("Helianthus excubitor", "aaa vva"), db = 'tropicos'))
# names(clas_tp) <- NULL

test_that("classification returns the correct values and classes", {
  skip_on_cran() # uses secrets
  vcr::use_cassette("classification", {
    clas_ncbi <- classification(c("Chironomus riparius", "aaa vva"), db = 'ncbi',
                                messages = FALSE)
    names(clas_ncbi) <- NULL

    clas_itis <- classification(c("Chironomus riparius", "aaa vva"), db = 'itis',
                                messages = FALSE)
    names(clas_itis) <- NULL
  })

	expect_that(clas_ncbi[[2]], equals(NA))
	expect_that(clas_itis[[2]], equals(NA))
# 	expect_that(clas_tp[[2]], equals(NA))

	expect_is(clas_ncbi, "classification")
	expect_is(clas_ncbi[[1]], "data.frame")
	expect_equal(length(clas_ncbi), 2)

  expect_is(clas_itis, "classification")
	expect_is(clas_itis[[1]], "data.frame")
  expect_equal(length(clas_itis), 2)

# 	expect_that(clas_tp, is_a("classification"))
# 	expect_that(clas_tp[[1]], is_a("data.frame"))
# 	expect_that(length(clas_tp), equals(2))

  vcr::use_cassette("classification_get_fxn", {
    uids <- get_uid(c("Chironomus riparius", "aaa vva"), messages = FALSE)
    tsns <- get_tsn(c("Chironomus riparius", "aaa vva"), messages = FALSE)
    clas_uids <- classification(uids, messages = FALSE)
    names(clas_uids) <- NULL
    clas_tsns <- classification(tsns, messages = FALSE)
    names(clas_tsns) <- NULL
  })
  
  expect_identical(clas_uids, clas_ncbi)
  expect_equal(clas_tsns, clas_itis)
  #### FIX THESE TWO, SHOULD BE MATCHING
#   expect_identical(clas_tpids, clas_tp)
})

test_that("passing in an id works", {
  skip_on_cran() # uses secrets
  vcr::use_cassette("classification_passing_id", {
    fromid_ncbi <- classification(9606, db = 'ncbi')
    fromid_itis <- classification(129313, db = 'itis')
    fromid_gbif <- classification(c(2704179, 2441176), db = 'gbif')
  })
  #fromid_nbn <- classification("NBNSYS0000004786", db = 'nbn')

  expect_is(fromid_ncbi, "classification")
  expect_equal(attr(fromid_ncbi, "db"), "ncbi")

  expect_is(fromid_itis, "classification")
  expect_equal(attr(fromid_itis, "db"), "itis")

  expect_is(fromid_gbif, "classification")
  expect_equal(attr(fromid_gbif, "db"), "gbif")

  #expect_is(fromid_nbn, "classification")
  #expect_equal(attr(fromid_nbn, "db"), "nbn")
})

test_that("rbind and cbind work correctly", {
  skip_on_cran() # uses secrets
  vcr::use_cassette("classification_cbind_rbind", {
    out <- get_ids(c("Puma concolor", "Accipiter striatus"),
                   db = 'ncbi', messages = FALSE, suppress = TRUE)
    cl <- classification(out)
  })

  # rbind
  clr <- rbind(cl)
  expect_is(clr, "data.frame")
  expect_named(clr, c("name", "rank", "id", "query", "db"))

  # cbind
  clc <- cbind(cl)
  expect_is(clc, "data.frame")
  expect_gt(length(names(clc)), 50)
})

set.seed(1)
df <- theplantlist[sample(1:nrow(theplantlist), 50), ]
nn <- apply(df, 1, function(x) paste(x["genus"], x["species"], collapse = " "))

test_that("works on a variety of names", {
  skip_on_cran()
  # skip_on_ci() # keeps timing out on GH actions for unknown reason
  
  vcr::use_cassette("classification_variety_of_names", {
    x <- classification(nn[5], db = "ncbi", messages = FALSE)
    z <- classification(nn[6], db = "ncbi", messages = FALSE)
  })

	expect_is(x, "classification")
	expect_is(z, "classification")
})

test_that("queries with no results fail well", {
  skip_on_cran()
  vcr::use_cassette("classification_no_results", {
    aa <- classification("foobar", db = "itis", messages = FALSE)
    bb <- classification(get_tsn("foobar", messages = FALSE), messages = FALSE)
  })

  expect_true(is.na(unclass(aa)[[1]]))
  expect_identical(unname(aa), unname(bb))
})

test_that("all rank character strings are lower case (all letters)", {
  skip_on_cran() # uses secrets
  vcr::use_cassette("classification_rank_is_lowercase", {
    aa <- classification(9606, db = 'ncbi', messages = FALSE)
    bb <- classification(129313, db = 'itis', messages = FALSE)
    dd <- classification(2441176, db = 'gbif', messages = FALSE)
    #ee <- classification(25509881, db = 'tropicos', messages = FALSE)
    #ff <- classification("NBNSYS0000004786", db = 'nbn', messages = FALSE)
  })

  expect_false(all(grepl("[A-Z]", aa[[1]]$rank)))
  expect_false(all(grepl("[A-Z]", bb[[1]]$rank)))
  expect_false(all(grepl("[A-Z]", dd[[1]]$rank)))
  #expect_false(all(grepl("[A-Z]", ee[[1]]$rank)))
  #expect_false(all(grepl("[A-Z]", ff[[1]]$rank)))
})


test_that("rows parameter, when used, works", {
  skip_on_cran() # uses secrets
  vcr::use_cassette("classification_rows_param", {
    # a <- classification("Asdfafsfd", db = 'ncbi', rows = 1, messages = FALSE)
    b <- classification("Asdfafsfd", db = 'itis', rows = 1, messages = FALSE)
    d <- classification("Asdfafsfd", db = 'gbif', rows = 1, messages = FALSE)
    g <- classification("Asdfafsfd", db = 'tropicos', rows = 1, messages = FALSE)
    h <- classification("Asdfafsfd", db = 'nbn', rows = 1, messages = FALSE)
  })

  # expect_is(a, "classification")
  expect_is(b, "classification")
  expect_is(d, "classification")
  expect_is(g, "classification")
  expect_is(h, "classification")
})

test_that("warn on mismatch 'db'", {
  skip_on_cran()
  vcr::use_cassette("classification_warn_on_db_mismatch", {
    expect_warning(
      classification(
        get_uid("Chironomus riparius", messages = FALSE), db = "itis"))
  })
})

# see https://www.ncbi.nlm.nih.gov/Taxonomy/Browser/wwwtax.cgi?id=668400
test_that("ncbi classification - taxon merged", {
  skip_on_cran()
  vcr::use_cassette("classification_fetches_merged_taxon", {
    a <- classification(668400, db = "ncbi")
  })

  expect_is(a, "classification")
  expect_named(a, "668400")
  # input id is different from id returned
  expect_false(identical("668400", a[[1]]$id[NROW(a[[1]])]))
})