added support for dna records

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: robis
 Title: Ocean Biodiversity Information System (OBIS) Client
 Description: Client for the Ocean Biodiversity Information System (<https://obis.org>).
-Version: 2.7.2
-Date: 2021-09-24
+Version: 2.8.0
+Date: 2021-09-27
 Authors@R: c(
     person("Pieter", "Provoost", , "[email protected]", c("cre", "aut")),
     person("Samuel", "Bosch", , "[email protected]", role = "aut"),
@@ -29,7 +29,20 @@ Imports:
     stringr,
     curl,
     data.table,
-    tidyselect
+    tidyselect,
+    xml2
+Collate:
+    robis.R
+    util.R
+    area.R
+    checklist.R
+    dataset.R
+    dna.R
+    map.R
+    mof.R
+    node.R
+    occurrence.R
+    taxon.R    
 License: MIT + file LICENSE
 Suggests:
     testthat,

NAMESPACE

@@ -3,6 +3,7 @@
 export(area)
 export(checklist)
 export(dataset)
+export(dna_records)
 export(get_geometry)
 export(map_ggplot)
 export(map_leaflet)
@@ -21,6 +22,7 @@ import(stringr)
 import(tibble)
 import(tidyr)
 import(tidyselect)
+import(xml2)
 importFrom(curl,has_internet)
 importFrom(data.table,as.data.table)
 importFrom(rlang,.data)

NEWS.md

@@ -1,3 +1,7 @@
+# robis 2.8.0
+
+Added support for DNADerivedData records.
+
 # robis 2.7.2
 
 Improved handling of API connection errors. Skip tests that fail when the API is down on CRAN.

R/dna.R

@@ -0,0 +1,50 @@
+utils::globalVariables("where")
+
+dna_cols <- get_dwc_fields("https://rs.gbif.org/extension/gbif/1.0/dna_derived_data_2021-07-05.xml")
+
+fast_unnest_dna <- function(dt, cols) {
+  dna <- NULL
+  dt[, unlist(dna, recursive = FALSE), by = mget(cols)]
+}
+
+clean_dna_table <- function(m) {
+  if (is.data.frame(m)) {
+    m <- m %>%
+      select(where(~!all(is.na(.x))))
+    missing_cols <- setdiff(dna_cols, names(m))
+    m[missing_cols] <- as.character(NA)
+    m %>%
+      select(all_of(c(dna_cols, "level")))
+  } else {
+    NULL
+  }
+}
+
+#' Extract DNA records from occurrence data with a dna column.
+#'
+#' @usage dna_records(df, fields = "id")
+#' @param df the occurrence dataframe.
+#' @param fields columns from the occurrence dataframe to include.
+#' @return The DNA records.
+#' @export
+dna_records <- function(df, fields = "id") {
+  dna <- NULL
+  fields <- unique(c("id", fields))
+  if ("id" %in% names(df) & "dna" %in% names(df)) {
+    if (class(df$dna) == "list") {
+      dt <- df %>%
+        select(all_of(c(fields, "dna"))) %>%
+        filter(!sapply(.data$dna, is.null)) %>%
+        mutate(dna = lapply(dna, clean_dna_table)) %>%
+        as.data.table()
+      dt %>%
+        fast_unnest_dna(fields) %>%
+        as_tibble()
+    } else {
+      tibble()
+    }
+  } else {
+    warning("Missing columns id or dna")
+    NULL
+  }
+}

R/mof.R

@@ -1,8 +1,8 @@
 utils::globalVariables("where")
 
-mof_cols <- c("measurementID", "occurrenceID", "measurementType", "measurementTypeID", "measurementValue", "measurementValueID", "measurementAccuracy", "measurementUnit", "measurementUnitID", "measurementDeterminedDate", "measurementDeterminedBy", "measurementMethod", "measurementRemarks")
+mof_cols <- get_dwc_fields("https://rs.gbif.org/extension/obis/extended_measurement_or_fact.xml")
 
-fast_unnest <- function(dt, cols) {
+fast_unnest_mof <- function(dt, cols) {
   mof <- NULL
   dt[, unlist(mof, recursive = FALSE), by = mget(cols)]
 }
@@ -38,7 +38,7 @@ measurements <- function(df, fields = "id") {
         mutate(mof = lapply(mof, clean_mof_table)) %>%
         as.data.table()
       dt %>%
-        fast_unnest(fields) %>%
+        fast_unnest_mof(fields) %>%
         as_tibble()
     } else {
       tibble()

R/occurrence.R

@@ -5,7 +5,7 @@
 #'   startdepth = NULL, enddepth = NULL, geometry = NULL,
 #'   measurementtype = NULL, measurementtypeid = NULL, measurementvalue = NULL,
 #'   measurementvalueid = NULL, measurementunit = NULL, measurementunitid = NULL,
-#'   redlist = NULL, hab = NULL, wrims = NULL, mof = NULL, absence = NULL,
+#'   redlist = NULL, hab = NULL, wrims = NULL, mof = NULL, dna = NULL, absence = NULL,
 #'   event = NULL, dropped = NULL, flags = NULL, exclude = NULL, fields = NULL,
 #'   qcfields = NULL, verbose = FALSE)
 #' @param scientificname the scientific name.
@@ -29,6 +29,7 @@
 #' @param hab include only IOC-UNESCO HAB species.
 #' @param wrims include only WRiMS species.
 #' @param mof include measurements data (default = \code{NULL}).
+#' @param dna include DNA data (default = \code{NULL}).
 #' @param absence only include absence records (\code{TRUE}), exclude absence records (\code{NULL}) or include absence records (\code{include}).
 #' @param event only include pure event records (\code{TRUE}), exclude pure event records (\code{NULL}) or include event records (\code{include}).
 #' @param dropped only include dropped records (\code{TRUE}), exclude dropped records (\code{NULL}) or include dropped records (\code{include}).
@@ -65,6 +66,7 @@ occurrence <- function(
   hab = NULL,
   wrims = NULL,
   mof = NULL,
+  dna = NULL,
   absence = NULL,
   event = NULL,
   dropped = NULL,
@@ -103,6 +105,7 @@ occurrence <- function(
     hab = handle_logical(hab),
     wrims = handle_logical(wrims),
     mof = handle_logical(mof),
+    dna = handle_logical(dna),
     absence = absence,
     event = event,
     dropped = dropped,

R/robis.R

@@ -8,7 +8,7 @@
 #'
 #' @docType package
 #' @name robis
-#' @import dplyr jsonlite leaflet ggplot2 tidyr tibble httr mapedit sf stringr tidyselect
+#' @import dplyr jsonlite leaflet ggplot2 tidyr tibble httr mapedit sf stringr tidyselect xml2
 #' @importFrom rlang .data
 #' @importFrom curl has_internet
 #' @importFrom data.table as.data.table

R/util.R

@@ -108,3 +108,11 @@ log_progress <- function(count, total) {
   }
   message(paste0("\rRetrieved ", count, " records of approximately ", total, " (", pct, "%)", sep = ""), appendLF = FALSE)
 }
+
+get_dwc_fields <- function(url) {
+  cont <- xml2::read_xml(content(GET(url), "text"))
+  cont %>%
+    xml_ns_strip() %>%
+    xml_find_all("//property") %>%
+    xml_attr("name")
+}