Merge pull request #108 from RichardLitt/add-checklist-tests

Add ebirdchecklist()

NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+export(ebirdchecklist)
 export(ebirdchecklistfeed)
 export(ebirdfreq)
 export(ebirdgeo)

R/ebirdchecklist.R

@@ -0,0 +1,126 @@
+#' View Checklist
+#'
+#' @param subId The checklist identifier
+#' @param sleep Time (in seconds) before function sends API call (defaults to
+#'   zero. Set to higher number if you are using this function in a loop with
+#'   many API calls).
+#' @param key eBird API key. You can obtain one from
+#'   https://ebird.org/api/keygen. We strongly recommend storing it in your
+#'   \code{.Renviron} file as an environment variable called \code{EBIRD_KEY}.
+#' @param other FALSE (default) or TRUE. Whether to return some
+#'   optional/deprecated/unsupported columns. Currently these are all columns in
+#'   subAux, projId, howManyAt*, hideFlags, present, and submissionMethod*.
+#' @param ... Curl options passed on to \code{\link[httr]{GET}}
+#'
+#' @return A 'tibble' 'data.frame' containing checklist information:
+#' @return "subId": submission ID
+#' @return "protocolId": eBird protocol ID
+#' @return "locId": location ID
+#' @return "durationHrs": checklist duration, in hours
+#' @return "allObsReported": whether all observations were reported, i.e.,
+#'   whether it was a 'complete' checklist
+#' @return "subComments": checklist comments
+#' @return "creationDt": checklist creation date
+#' @return "lastEditedDt": checklist last edited date
+#' @return "obsDt": checklist date-time
+#' @return "obsTimeValid": whether checklist date-time is valid
+#' @return "checklistId" checklist ID
+#' @return "numObservers" number of observers on checklist
+#' @return "subnational1Code" country code and subnational1 code
+#' @return "userDisplayName" eBird user display name
+#' @return "numSpecies" number of species reported on checklist
+#' @return "speciesCode" species codes reported on checklist
+#' @return "obsId" observation IDs for each taxon on checklist
+#' @return "howManyStr" number of individuals reported for each taxon
+#' @return "exoticCategory" exotic species categories for each taxon
+#' @return "obsComments" observation comments for each taxon
+#' @return "auxCode" breding code for each taxon
+
+#' @export
+#'
+#' @examples \dontrun{
+#' ebirdchecklist("S121423354")
+#' }
+#' @references \url{http://ebird.org/}
+ebirdchecklist <- function(subId, sleep = 0, key = NULL, other = FALSE, ...) {
+
+  url <- paste0(ebase(), "product/checklist/view/", subId)
+
+  Sys.sleep(sleep)
+
+  response <- GET(URLencode(url),
+            query = ebird_compact(list()),
+            add_headers("X-eBirdApiToken" = get_key(key)),
+            ...)
+
+  content_text <- content(response, as = "text", encoding = "UTF-8")
+  content_json <- fromJSON(content_text, flatten = FALSE)
+
+  # Check if the response contains an error message
+  if (any(grepl('^error', names(content_json)))){
+    err_msg <- 'Unknown error'
+    err_msg <- try(content_json$errors$status, silent = TRUE)
+    if (grepl('subId is invalid', content_json$errors$title)){
+      err_msg <- 'subId is invalid'
+      }
+    stop(err_msg)
+  }
+
+  cl <- bind_rows(content_json)
+
+  # extract sub df
+  col_is_df <- vapply(cl, is.data.frame, TRUE)
+  sub_df <- cl[1, !col_is_df]
+  # 'comments' column has name duplicated with species comments
+  names(sub_df)[names(sub_df) == 'comments'] <- 'subComments'
+
+  # extract subAux df
+  subAux_df <- cl$subAux[1,]
+  # seems empty, and names conflict with breeding codes
+  subAux_df$auxCode <- NULL
+  subAux_df$entryMethodCode <- NULL
+
+  # extract obsAux df
+  obsAux_list <- cl$obs$obsAux
+  # find the list entry that contains the data
+  col_is_df <- vapply(obsAux_list, is.data.frame, TRUE)
+  obsAux_df <- obsAux_list[[which(col_is_df)]]
+  # redundant columns from sub_df
+  obsAux_df$subId <- NULL
+  obsAux_df$speciesCode <- NULL
+  # duplicate info with uninformative name
+  obsAux_df$value <- NULL
+  # names conflict with sub_df, and not very important
+  obsAux_df$fieldName <- NULL
+  obsAux_df$entryMethodCode <- NULL
+
+  # extract obs df
+  obs_df <- cl$obs
+  obs_df$obsAux <- NULL
+  # hideFlags might be useful, but its structure is currently undocumented
+  obs_df$hideFlags <- NULL
+  # remove redundant sub-level columns already in sub_df
+  obs_df$subnational1Code <- NULL
+  obs_df$obsDt <- NULL
+  obs_df$projId <- NULL
+  # mediaCounts appears to just be a nested integer vector (?)
+  obs_df$mediaCounts <- Reduce(c, obs_df$mediaCounts)
+  # 'comments' column has name duplicated with checklist comments
+  names(obs_df)[names(obs_df) == 'comments'] <- 'obsComments'
+
+  # join to get result df
+  out_df <- sub_df
+  if (! is.null(subAux_df) && other){
+    out_df <- dplyr::left_join(out_df, subAux_df, by = 'subId')
+  }
+  out_df <- dplyr::left_join(out_df, obs_df, by = 'subId')
+  if (! is.null(obsAux_df)){
+    out_df <- dplyr::left_join(out_df, obsAux_df, by = 'obsId')
+  }
+  # remove some unneeded columns by default
+  if (! other){
+    regex <- '^projId$|^howManyAt|^hideFlags$|^present$|^submissionMethod'
+    out_df <- out_df[, !grepl(regex, names(out_df)), drop = FALSE]
+  }
+  out_df
+}

tests/fixtures/ebirdchecklist.yml

@@ -0,0 +1,81 @@
+http_interactions:
+- request:
+    method: get
+    uri: https://ebird.org/ws2.0/product/checklist/view/S117450946
+    body:
+      encoding: ''
+      string: ''
+    headers:
+      Accept: application/json, text/xml, application/xml, */*
+      X-eBirdApiToken: <<<redacted>>>
+  response:
+    status:
+      status_code: 200
+      category: Success
+      reason: OK
+      message: 'Success: (200) OK'
+    headers:
+      cache-control: no-cache, no-store, max-age=0, must-revalidate
+      content-encoding: gzip
+      content-type: application/json;charset=utf-8
+      date: Sat, 23 Mar 2024 05:57:03 GMT
+      expires: '0'
+      pragma: no-cache
+      server: Apache
+      strict-transport-security: max-age=31536000 ; includeSubDomains
+      vary: Origin,Accept-Encoding,Access-Control-Request-Method,Access-Control-Request-Headers
+      x-content-type-options: nosniff
+      x-frame-options: DENY
+      x-xss-protection: 1; mode=block
+      content-length: '572'
+    body:
+      encoding: ''
+      file: no
+      string: '{"projId":"EBIRD","subId":"S117450946","protocolId":"P21","locId":"L2906552","durationHrs":0.05,"allObsReported":true,"comments":"7
+        passing cars","creationDt":"2022-08-23 15:18","lastEditedDt":"2022-08-23 15:18","obsDt":"2022-05-30
+        06:55","obsTimeValid":true,"checklistId":"CL24321","numObservers":1,"subnational1Code":"US-WA","submissionMethodCode":"EBIRD_upload","userDisplayName":"Dave
+        Slager","numSpecies":5,"subAux":[{"subId":"S117450946","fieldName":"nocturnal","entryMethodCode":"ebird_nocturnal","auxCode":"0"}],"subAuxAi":[],"obs":[{"speciesCode":"hummin","hideFlags":[],"obsDt":"2022-05-30
+        06:55","subnational1Code":"US-WA","howManyAtleast":1,"howManyAtmost":1,"present":false,"subId":"S117450946","projId":"EBIRD","obsId":"OBS1503894279","howManyStr":"1"},{"speciesCode":"eursta","hideFlags":[],"exoticCategory":"N","obsDt":"2022-05-30
+        06:55","subnational1Code":"US-WA","howManyAtleast":6,"howManyAtmost":6,"present":false,"subId":"S117450946","projId":"EBIRD","obsId":"OBS1503894277","howManyStr":"6"},{"speciesCode":"amerob","hideFlags":[],"obsDt":"2022-05-30
+        06:55","subnational1Code":"US-WA","howManyAtleast":2,"howManyAtmost":2,"present":false,"subId":"S117450946","projId":"EBIRD","obsId":"OBS1503894275","howManyStr":"2"},{"speciesCode":"cedwax","hideFlags":[],"obsDt":"2022-05-30
+        06:55","subnational1Code":"US-WA","howManyAtleast":2,"howManyAtmost":2,"present":false,"subId":"S117450946","projId":"EBIRD","obsId":"OBS1503894278","howManyStr":"2"},{"speciesCode":"houspa","hideFlags":[],"exoticCategory":"N","obsDt":"2022-05-30
+        06:55","subnational1Code":"US-WA","howManyAtleast":1,"howManyAtmost":1,"comments":"ON","present":false,"subId":"S117450946","projId":"EBIRD","obsId":"OBS1503894274","howManyStr":"1","obsAux":[{"subId":"S117450946","fieldName":"breeding_code","entryMethodCode":"ebird_breeding_code","auxCode":"ON","obsId":"OBS1503894274","speciesCode":"houspa","value":"ON"}]},{"speciesCode":"pswspa1","hideFlags":[],"obsDt":"2022-05-30
+        06:55","subnational1Code":"US-WA","howManyAtleast":1,"howManyAtmost":1,"present":false,"subId":"S117450946","projId":"EBIRD","obsId":"OBS1503894276","howManyStr":"1"}]}'
+  recorded_at: 2024-03-23 06:01:43 GMT
+  recorded_with: vcr/1.2.2, webmockr/0.9.0
+- request:
+    method: get
+    uri: https://ebird.org/ws2.0/product/checklist/view/invalid_id
+    body:
+      encoding: ''
+      string: ''
+    headers:
+      Accept: application/json, text/xml, application/xml, */*
+      X-eBirdApiToken: <<<redacted>>>
+  response:
+    status:
+      status_code: 400
+      category: Client error
+      reason: Bad Request
+      message: 'Client error: (400) Bad Request'
+    headers:
+      cache-control: no-cache, no-store, max-age=0, must-revalidate
+      content-encoding: gzip
+      content-type: application/json
+      date: Sat, 23 Mar 2024 05:57:04 GMT
+      expires: '0'
+      pragma: no-cache
+      server: Apache
+      strict-transport-security: max-age=31536000 ; includeSubDomains
+      vary: Origin,Accept-Encoding,Access-Control-Request-Method,Access-Control-Request-Headers
+      x-content-type-options: nosniff
+      x-frame-options: DENY
+      x-xss-protection: 1; mode=block
+      content-length: '129'
+    body:
+      encoding: ''
+      file: no
+      string: '{"errors":[{"status":"400 BAD_REQUEST","code":"Pattern","title":"Field
+        subId of checklistBySubIdCmd: subId is invalid."}]}'
+  recorded_at: 2024-03-23 06:01:43 GMT
+  recorded_with: vcr/1.2.2, webmockr/0.9.0

tests/testthat/test-ebirdchecklist.R

@@ -0,0 +1,27 @@
+vcr::use_cassette("ebirdchecklist", {
+  test_that("ebirdchecklist succeeds reproducibly", {
+
+    expect_no_error(out1 <- ebirdchecklist("S117450946"))
+
+    # check all list-columns removed during preprocessing
+    expect_false(any(vapply(out1, is.list, logical(1))))
+
+    # Works with breeding code
+    expect_true('ON' %in% out1$auxCode)
+
+    expect_is(out1, "data.frame")
+    expect_true(nrow(out1) == 6)
+    expect_true(ncol(out1) > 0)
+    expect_true("checklistId" %in% names(out1))
+    expect_equal(out1$checklistId[1], "CL24321")
+
+  })
+
+  test_that("ebirdchecklist errors for bad input", {
+
+    invalid_checklist_id <- "invalid_id"
+
+    # Expect an error and check if the error message matches the expected pattern
+    expect_error(ebirdchecklist(invalid_checklist_id), "subId is invalid")
+  })
+})