added nbn version of classificationa and started to incorporate to ge…

…neric classification fxn, #332
ropensci · Oct 1, 2014 · f12978a · f12978a
1 parent fa85ba7
commit f12978a
Show file tree

Hide file tree

Showing 5 changed files with 137 additions and 19 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -12,6 +12,7 @@ S3method(classification,default)
 S3method(classification,eolid)
 S3method(classification,gbifid)
 S3method(classification,ids)
+S3method(classification,nbnid)
 S3method(classification,tpsid)
 S3method(classification,tsn)
 S3method(classification,uid)
@@ -140,6 +141,7 @@ export(iucn_getname)
 export(iucn_status)
 export(iucn_summary)
 export(names_list)
+export(nbn_classifcation)
 export(nbn_search)
 export(ncbi_children)
 export(ncbi_get_taxon_summary)

diff --git a/R/classification.R b/R/classification.R
@@ -42,9 +42,10 @@
 #' classification(c("Chironomus riparius", "aaa vva"), db = 'itis', verbose=FALSE)
 #' classification(c("Chironomus riparius", "aaa vva"), db = 'eol')
 #' classification(c("Chironomus riparius", "aaa vva"), db = 'col')
+#' classification("Alopias vulpinus", db = 'nbn')
 #' classification(c("Chironomus riparius", "aaa vva"), db = 'col', verbose=FALSE)
 #' classification(c("Chironomus riparius", "asdfasdfsfdfsd"), db = 'gbif')
-#' classification(c("Poa annua", "aaa vva"), db = 'tropicos')
+#' classification("Poa annua", db = 'tropicos')
 #' 
 #' # Use methods for get_uid, get_tsn, get_eolid, get_colid, get_tpsid
 #' classification(get_uid(c("Chironomus riparius", "Puma concolor")))
@@ -88,6 +89,11 @@
 #' tsns <- get_tsn(c("Puma concolor","Accipiter striatus"))
 #' cl_tsns <- classification(tsns)
 #' cbind(cl_tsns)
+#' 
+#' # NBN data
+#' res <- classification(c("Alopias vulpinus","Pinus sylvestris"), db = 'nbn')
+#' rbind(res)
+#' cbind(res)
 #' }
 #' 
 #' @examples \donttest{
@@ -139,6 +145,11 @@ classification.default <- function(x, db = NULL, callopts=list(), ...){
     out <- classification(id, callopts=callopts, ...)
     names(out) <- x
   }
+  if (db == 'nbn') {
+    id <- process_ids(x, get_nbnid, ...)
+    out <- classification(id, callopts=callopts, ...)
+    names(out) <- x
+  }
   return(out)
 }
 
@@ -172,9 +183,7 @@ classification.tsn <- function(id, callopts = list(), ...)
   }
   out <- lapply(id, fun)
   names(out) <- id
-  class(out) <- 'classification'
-  attr(out, 'db') <- 'itis'
-  return(out)
+  structure(out, class='classification', db='itis')
 }
 
 
@@ -206,9 +215,7 @@ classification.uid <- function(id, ...) {
   }
   out <- lapply(id, fun)
   names(out) <- id
-  class(out) <- 'classification'
-  attr(out, 'db') <- 'ncbi'
-  return(out)
+  structure(out, class='classification', db='ncbi')
 }
 
 
@@ -241,9 +248,7 @@ classification.eolid <- function(id, key = NULL, callopts = list(), ...) {
   }
   out <- lapply(id, fun)
   names(out) <- id
-  class(out) <- 'classification'
-  attr(out, 'db') <- 'eol'
-  return(out)
+  structure(out, class='classification', db='eol')
 }
 
 #' @method classification colid
@@ -283,9 +288,7 @@ classification.colid <- function(id, start = NULL, checklist = NULL, ...) {
   }
   out <- lapply(id, fun)
   names(out) <- id
-  class(out) <- 'classification'
-  attr(out, 'db') <- 'col'
-  return(out)
+  structure(out, class='classification', db='col')
 }
 
 
@@ -314,8 +317,7 @@ classification.tpsid <- function(id, key = NULL, callopts = list(), ...) {
   }
   out <- lapply(id, fun)
   names(out) <- id
-  class(out) <- 'classification'
-  return(out)
+  structure(out, class='classification', db='tropicos')
 }
 
 #' @method classification gbifid
@@ -339,8 +341,27 @@ classification.gbifid <- function(id, callopts = list(), ...) {
   }
   out <- lapply(id, fun)
   names(out) <- id
-  class(out) <- 'classification'
-  return(out)
+structure(out, class='classification', db='gbif')
+}
+
+
+#' @method classification nbnid
+#' @export
+#' @rdname classification
+classification.nbnid <- function(id, callopts = list(), ...) {
+  fun <- function(x){
+    if(is.na(x)) {
+      out <- NA
+    } else {
+      out <- suppressWarnings(tryCatch(nbn_classifcation(id=x, ...), error=function(e) e))
+      if(is(out, "simpleError")){ NA } else {
+        out[ , c('name','rank') ]
+      }
+    }
+  }
+  out <- lapply(id, fun)
+  names(out) <- id
+  structure(out, class='classification', db='nbn')
 }
 
 #' @method classification ids
@@ -387,7 +408,7 @@ rbind.classification <- function(x)
   input <- x
   db <- attr(input, "db")
   x <- input[vapply(x, class, "") %in% "data.frame"]
-  df <- do.call(rbind, x)
+  df <- do.call(rbind.fill, x)
   df <- data.frame(source = db, taxonid = gsub("\\.[0-9]+", "", row.names(df)), df)
   row.names(df) <- NULL
   return( df )

diff --git a/R/nbn_classification.R b/R/nbn_classification.R
@@ -0,0 +1,40 @@
+#' Search UK National Biodiversity Network database for taxonomic classification
+#' 
+#' @export
+#' 
+#' @param q (character) The query terms(s)
+#' @param prefered (logical) Restrict search to preferred or any
+#' @param order (character) The order in which we should sort the results. Default: asc
+#' @param sort (character) Sort the results or not.
+#' @param start (integer/numeric) The page that the user wants to start displaying the results at. 
+#' Default: 0
+#' @param rows (integer/numeric) The number of rows to show in each page of search results. 
+#' Default: 25
+#' @param taxonOutputGroupKey (character) Vector of taxon output groups.
+#' @param all (logical) Get all results, overrides rows parameter if TRUE. Default: FALSE
+#' @param ... Further args passed on to \code{\link[httr]{GET}}. 
+#' 
+#' @author Scott Chamberlain, \email{myrmecocystus@@gmail.com}
+#' 
+#' @examples \donttest{
+#' nbn_classifcation(id="NHMSYS0000502940")
+#' 
+#' # get id first, then pass to this fxn
+#' id <- get_nbnid("blue tit", rec_only = TRUE, rank = "Species")
+#' nbn_classifcation(id)
+#' 
+#' library('httr')
+#' nbn_classifcation(id="NHMSYS0000502940", config=verbose())
+#' }
+nbn_classifcation <- function(id, ...)
+{
+  url <- sprintf("https://data.nbn.org.uk/api/taxa/%s/taxonomy", id)
+  nbn_class_GET(url, ...)
+}
+
+nbn_class_GET <- function(url, ...){
+  res <- GET(url, ...)
+  stop_for_status(res)
+  tt <- content(res, as = "text")
+  jsonlite::fromJSON(tt, TRUE)
+}
diff --git a/man/classification.Rd b/man/classification.Rd
@@ -8,6 +8,7 @@
 \alias{classification.eolid}
 \alias{classification.gbifid}
 \alias{classification.ids}
+\alias{classification.nbnid}
 \alias{classification.tpsid}
 \alias{classification.tsn}
 \alias{classification.uid}
@@ -31,6 +32,8 @@ classification(...)
 
 \method{classification}{gbifid}(id, callopts = list(), ...)
 
+\method{classification}{nbnid}(id, callopts = list(), ...)
+
 \method{classification}{ids}(id, ...)
 
 \method{cbind}{classification}(x)
@@ -91,9 +94,10 @@ classification(c("Chironomus riparius", "aaa vva"), db = 'itis')
 classification(c("Chironomus riparius", "aaa vva"), db = 'itis', verbose=FALSE)
 classification(c("Chironomus riparius", "aaa vva"), db = 'eol')
 classification(c("Chironomus riparius", "aaa vva"), db = 'col')
+classification("Alopias vulpinus", db = 'nbn')
 classification(c("Chironomus riparius", "aaa vva"), db = 'col', verbose=FALSE)
 classification(c("Chironomus riparius", "asdfasdfsfdfsd"), db = 'gbif')
-classification(c("Poa annua", "aaa vva"), db = 'tropicos')
+classification("Poa annua", db = 'tropicos')
 
 # Use methods for get_uid, get_tsn, get_eolid, get_colid, get_tpsid
 classification(get_uid(c("Chironomus riparius", "Puma concolor")))
@@ -137,6 +141,10 @@ cbind(cl_tsn)
 tsns <- get_tsn(c("Puma concolor","Accipiter striatus"))
 cl_tsns <- classification(tsns)
 cbind(cl_tsns)
+
+# NBN data
+res <- classification(c("Alopias vulpinus","Pinus sylvestris"), db = 'nbn')
+cbind(res)
 }
 }
 \seealso{

diff --git a/man/nbn_classifcation.Rd b/man/nbn_classifcation.Rd
@@ -0,0 +1,47 @@
+% Generated by roxygen2 (4.0.2): do not edit by hand
+\name{nbn_classifcation}
+\alias{nbn_classifcation}
+\title{Search UK National Biodiversity Network database for taxonomic classification}
+\usage{
+nbn_classifcation(id, ...)
+}
+\arguments{
+\item{...}{Further args passed on to \code{\link[httr]{GET}}.}
+
+\item{q}{(character) The query terms(s)}
+
+\item{prefered}{(logical) Restrict search to preferred or any}
+
+\item{order}{(character) The order in which we should sort the results. Default: asc}
+
+\item{sort}{(character) Sort the results or not.}
+
+\item{start}{(integer/numeric) The page that the user wants to start displaying the results at.
+Default: 0}
+
+\item{rows}{(integer/numeric) The number of rows to show in each page of search results.
+Default: 25}
+
+\item{taxonOutputGroupKey}{(character) Vector of taxon output groups.}
+
+\item{all}{(logical) Get all results, overrides rows parameter if TRUE. Default: FALSE}
+}
+\description{
+Search UK National Biodiversity Network database for taxonomic classification
+}
+\examples{
+\donttest{
+nbn_classifcation(id="NHMSYS0000502940")
+
+# get id first, then pass to this fxn
+id <- get_nbnid("blue tit", rec_only = TRUE, rank = "Species")
+nbn_classifcation(id)
+
+library('httr')
+nbn_classifcation(id="NHMSYS0000502940", config=verbose())
+}
+}
+\author{
+Scott Chamberlain, \email{myrmecocystus@gmail.com}
+}
+