created function get_taxon

R/01_classDefinitions.R

@@ -385,6 +385,7 @@ setClass(
             datasetname = "character",
             age_range_old = "numeric",
             age_range_young = "numeric",
+            age_units = "character",
             notes = "character",
             pi_list = "ANY",
             samples = "samples",
@@ -397,6 +398,7 @@ setClass(
                    datasetname = NA_character_,
                    age_range_old =  NA_integer_,
                    age_range_young =  NA_integer_,
+                   age_units = NA_character_,
                    notes = NA_character_,
                    pi_list = list(),
                    samples = NULL,
@@ -512,3 +514,43 @@ setClass("sites",
                     }) %>%
                       unlist())
                   })
+
+#' @title S4 class for specimen information
+#' @description Taxon class for single taxon information
+#'  from the Neotoma Paleoecology Database.
+#' @returns object of class `taxon`
+#' @export
+setClass("taxon",
+         slots = c(taxonid = "numeric",
+                   taxoncode = "character",
+                   taxonname = "character",
+                   author = "character",
+                   ecolgroup = "character",
+                   highertaxonid = "numeric",
+                   status = "character",
+                   taxagroupid = "character",
+                   publicationid = "numeric",
+                   publication = "character"),
+         prototype = list(taxonid = NA_integer_,
+                   taxoncode = NA_character_,
+                   taxonname = NA_character_,
+                   author = NA_character_,
+                   ecolgroup = NA_character_,
+                   highertaxonid = NA_integer_,
+                   status = NA_character_,
+                   taxagroupid = NA_character_,
+                   publicationid = NA_integer_,
+                   publication = NA_character_))
+
+#' @title S4 class for taxa information
+#' @description Taxa class for taxa information
+#'  from the Neotoma Paleoecology Database.
+#' @returns object of class `taxon`
+#' @export
+setClass("taxa", representation(taxa = "list"),
+         validity = function(object) {
+           all(map(object, function(x) {
+             class(x) == "taxon"
+           }) %>%
+             unlist())
+         })

R/build_dataset.R

@@ -38,6 +38,7 @@ build_dataset <- function(x) {
       datasetname = use_na(testNull(x$datasetname, NA), "char"),
       age_range_old = use_na(testNull(x$agerange[[1]]$ageold, NA), "int"),
       age_range_young = use_na(testNull(x$agerange[[1]]$ageyoung, NA), "int"),
+      age_units = use_na(testNull(x$agerange[[1]]$units, NA), "char"),
       notes = use_na(testNull(x$datasetnotes, NA), "char"),
       pi_list = pi_list,
       samples = samples,

R/dataset-methods.R

@@ -10,6 +10,7 @@ setMethod(f = "show",
                              datasettype = object@datasettype,
                              age_range_old =  object@age_range_old,
                              age_range_young =  object@age_range_young,
+                             age_units = object@age_units,
                              notes = object@notes), row.names = FALSE)
           })
 
@@ -25,6 +26,7 @@ setMethod(f = "show",
                                datasettype = y@datasettype,
                                age_range_old =  y@age_range_old,
                                age_range_young =  y@age_range_young,
+                               age_units = y@age_units,
                                notes = y@notes)
             }) %>%
               bind_rows() %>%
@@ -173,6 +175,7 @@ setMethod(f = "as.data.frame",
                        datasettype = x@datasettype,
                        age_range_old =  x@age_range_old,
                        age_range_young =  x@age_range_young,
+                       age_units = x@age_units,
                        notes = x@notes)
           })
 

R/get_taxa.R

@@ -0,0 +1,127 @@
+#' @md
+#' @title get_taxa
+#' @description a sites object with the requested taxa.
+#' @param x string taxa name or names
+#' @returns A Neotoma2 sites object with datasets with the requested taxa.
+#' 
+#' @export
+get_taxon <- function(x = NA, ...) {
+  if (!missing(x)) {
+    UseMethod("get_taxa", x)
+  } else {
+    UseMethod("get_taxa", NA)
+  }
+}
+
+parse_taxon <- function(result) { # nolint
+
+  fix_null <- function(x) {
+    for (i in seq_len(length(x))) {
+      if (is.null(x[[i]])) {
+        x[[i]] <- NA
+      } else {
+        if (is(x[[i]], "list")) {
+          x[[i]] <- fix_null(x[[i]])
+        }
+      }
+    }
+    return(x)
+  }
+
+  data <- result$data %>%
+    fix_null()
+
+  # With a large dataset this seems to take some time, but it's not too bad.
+  newTaxon <- map(data, function(x) {
+
+    new_taxon <- new("taxon",
+                     taxonid = x$taxonid,
+                     taxoncode = x$taxoncode,
+                     taxonname = x$taxonname,
+                     author = x$author,
+                     ecolgroup = x$ecolgroup,
+                     highertaxonid = x$highertaxonid,
+                     status = x$status,
+                     taxagroupid = x$taxagroupid,
+                     publicationid = x$publicationid,
+                     publication = x$publication)
+
+    print(new_taxon)
+  })
+
+  return(new_taxon)
+
+}
+
+
+#' @title Get Taxa Default
+#' @param x Use a taxon ID to extract site information
+#' @param ... accepted arguments, see details for more information.
+#' @importFrom utils URLencode
+#' @returns `sites` object containing the requested `taxa`
+#' @export
+get_taxon.default <- function(x, ...) {
+  oo <- options(scipen = 9999999)
+  on.exit(options(oo))
+  cl <- as.list(match.call())
+
+  cl[[1]] <- NULL
+
+  cl <- lapply(cl, eval, envir = parent.frame())
+
+  all_data <- ifelse(is.null(cl$all_data), FALSE, TRUE)
+  error_check <- check_args(cl) # nolint
+
+  if (error_check[[2]]$flag == 1) {
+    stop(paste0(unlist(error_check[[2]]$message), collapse = "\n  "))
+  } else {
+    cl <- error_check[[1]]
+  }
+
+    base_url <- paste0("data/taxa")
+    result <- parseURL(base_url, ...) %>%
+      cleanNULL()
+
+  if (is.null(result$data[1][[1]]) || is.null(result[1][[1]])) {
+    return(NULL)
+
+  } else {
+    output <- parse_taxa(result)
+    return(output)
+  }
+}
+
+#' @title Get Taxa Numeric
+#' @param x Use a taxon ID to extract sites information
+#' @param ... Additional parameters to get_taxa
+#' @returns `sites` object with requested `taxa`
+#' @examples \donttest{
+#' allds <- get_datasets(1:3)
+#' }
+#' @export
+get_taxon.numeric <- function(x, ...) {
+  use_na <- function(x, type) {
+    if (is.na(x)) {
+      return(switch(type,
+                    "char" = NA_character_,
+                    "int" = NA_integer_))
+    } else {
+      return(x)
+    }
+  }
+
+  if (length(x) > 0) {
+    taxa_id <- paste0(x, collapse = ",")
+  }
+
+  base_url <- paste0("data/taxa/", taxa_id)
+  result <- neotoma2::parseURL(base_url, ...)
+  result_length <- length(result[2]$data)
+
+  if (result_length > 0) {
+    output <- parse_taxa(result)
+    return(output)
+  } else {
+    return(NULL)
+  }
+}

R/get_taxon.R

@@ -0,0 +1,124 @@
+#' @md
+#' @title get_taxon
+#' @description a sites object with the requested taxa.
+#' @param x string taxa name or names
+#' @returns A Neotoma2 sites object with datasets with the requested taxa.
+#' 
+#' @export
+get_taxon <- function(x = NA, ...) {
+  if (!missing(x)) {
+    UseMethod("get_taxon", x)
+  } else {
+    UseMethod("get_taxon", NA)
+  }
+}
+
+parse_taxon <- function(result) { # nolint
+
+  fix_null <- function(x) {
+    for (i in seq_len(length(x))) {
+      if (is.null(x[[i]])) {
+        x[[i]] <- NA
+      } else {
+        if (is(x[[i]], "list")) {
+          x[[i]] <- fix_null(x[[i]])
+        }
+      }
+    }
+    return(x)
+  }
+
+  data <- result$data %>%
+    fix_null()
+
+  newTaxa <- map(data, function(x) {
+    new_taxon <- new("taxon",
+                     taxonid = use_na(testNull(x$taxonid, NA), "int"),
+                     taxoncode = use_na(testNull(x$taxoncode, NA), "char"),
+                     taxonname = use_na(testNull(x$taxonname, NA), "char"),
+                     author = use_na(testNull(x$author, NA), "char"),
+                     ecolgroup = use_na(testNull(x$ecolgroup, NA), "char"),
+                     highertaxonid = use_na(testNull(x$highertaxonid, NA), "int"),
+                     status = use_na(testNull(x$status, NA), "char"),
+                     taxagroupid = use_na(testNull(x$taxagroupid, NA), "int"),
+                     publicationid = use_na(testNull(x$publicationid, NA), "int"),
+                     publication = use_na(testNull(x$publication, NA), "char"))
+  })
+
+  taxa <- new("taxa", taxa = newTaxa)
+
+  return(taxa)
+}
+
+
+#' @title Get Taxa Default
+#' @param x Use a taxon ID to extract site information
+#' @param ... accepted arguments, see details for more information.
+#' @importFrom utils URLencode
+#' @returns `sites` object containing the requested `taxa`
+#' @export
+get_taxon.default <- function(x, ...) {
+  oo <- options(scipen = 9999999)
+  on.exit(options(oo))
+  cl <- as.list(match.call())
+
+  cl[[1]] <- NULL
+
+  cl <- lapply(cl, eval, envir = parent.frame())
+
+  all_data <- ifelse(is.null(cl$all_data), FALSE, TRUE)
+  error_check <- check_args(cl) # nolint
+
+  if (error_check[[2]]$flag == 1) {
+    stop(paste0(unlist(error_check[[2]]$message), collapse = "\n  "))
+  } else {
+    cl <- error_check[[1]]
+  }
+
+  base_url <- paste0("data/taxa")
+  result <- parseURL(base_url, ...) %>%
+    cleanNULL()
+
+  if (is.null(result$data[1][[1]]) || is.null(result[1][[1]])) {
+    return(NULL)
+
+  } else {
+    output <- parse_taxon(result)
+    return(output)
+  }
+}
+
+#' @title Get Taxa Numeric
+#' @param x Use a taxon ID to extract sites information
+#' @param ... Additional parameters to get_taxa
+#' @returns `sites` object with requested `taxa`
+#' @examples \donttest{
+#' allds <- get_datasets(1:3)
+#' }
+#' @export
+get_taxon.numeric <- function(x, ...) {
+  use_na <- function(x, type) {
+    if (is.na(x)) {
+      return(switch(type,
+                    "char" = NA_character_,
+                    "int" = NA_integer_))
+    } else {
+      return(x)
+    }
+  }
+
+  if (length(x) > 0) {
+    taxa_id <- paste0(x, collapse = ",")
+  }
+
+  base_url <- paste0("data/taxa/", taxa_id)
+  result <- neotoma2::parseURL(base_url, ...)
+  result_length <- length(result[2]$data)
+
+  if (result_length > 0) {
+    output <- parse_taxon(result)
+    return(output)
+  } else {
+    return(NULL)
+  }
+}