From 14ab4d8555de9e031ebfeb5c925c522357c5618e Mon Sep 17 00:00:00 2001 From: Socorro DominguezVidana Date: Wed, 21 Oct 2026 20:33:18 -0700 Subject: [PATCH 1/5] Fixing parsing of calls when API fails --- R/get_datasets.R | 28 +-- R/get_downloads.R | 96 ++++++-- R/get_sites.R | 4 + R/get_table.R | 19 +- tests/testthat/test_get_downloads.R | 122 ++++++++- tests/testthat/test_get_table.R | 67 ++++- tests/testthat/test_parseURL.R | 369 ++++++++++++++++++++++++++-- 7 files changed, 636 insertions(+), 69 deletions(-) diff --git a/R/get_datasets.R b/R/get_datasets.R index 3f670028..463c332e 100644 --- a/R/get_datasets.R +++ b/R/get_datasets.R @@ -29,6 +29,11 @@ #' the datasets at that site. #' The `get_datasets()` command wraps the Neotoma API #' ([api.neotomadb.org](https://api.neotomadb.org)) call for `datasets`. +#' Some queries are slow for the API however few records they return: a spatial +#' query (`loc`) costs tens of seconds even when it matches no datasets, and a +#' broad `taxa` filter (many names, or a wildcard) can take a minute or more. +#' Add other filters to narrow a query, test it with a small `limit` first, and +#' avoid running it in a loop. #' The call itself uses a SQL query which accepts any one of the following #' parameters: #' * `siteid` The unique site ID (integer) in Neotoma. Can be passed as a @@ -158,22 +163,14 @@ get_datasets.default <- function(x, ...) { #' @exportS3Method get_datasets sites get_datasets.sites <- function(x, ...) { ids <- getids(x) - cl <- as.list(match.call()) - cl[[1]] <- NULL ids <- ids %>% select(.data$datasetid) %>% unique() %>% unlist() %>% as.numeric() - if ("all_data" %in% cl) { - all_data <- cl$all_data - } else { - all_data <- TRUE - } + # `all_data` defaults to TRUE here, and a value supplied by the caller wins. dots <- list(...) - if ("all_data" %in% names(dots)) { - dots$all_data <- NULL - } + all_data <- if ("all_data" %in% names(dots)) dots$all_data else TRUE output <- get_datasets(x = ids, all_data = all_data) return(output) } @@ -182,8 +179,6 @@ get_datasets.sites <- function(x, ...) { #' @exportS3Method get_datasets site get_datasets.site <- function(x, ...) { # List of datasets ids - cl <- as.list(match.call()) - cl[[1]] <- NULL ids1 <- getids(x) ids <- ids1 %>% filter(!is.na(suppressWarnings(as.numeric(.data$siteid))), @@ -201,15 +196,8 @@ get_datasets.site <- function(x, ...) { } dataset_list <- ids$datasetid dataset_list <- as.numeric(unlist(dataset_list)) - if ("all_data" %in% cl) { - all_data <- cl$all_data - } else { - all_data <- TRUE - } dots <- list(...) - if ("all_data" %in% names(dots)) { - dots$all_data <- NULL - } + all_data <- if ("all_data" %in% names(dots)) dots$all_data else TRUE output <- get_datasets(dataset_list, all_data = all_data) return(output) } diff --git a/R/get_downloads.R b/R/get_downloads.R index 46b32020..85eca4c7 100644 --- a/R/get_downloads.R +++ b/R/get_downloads.R @@ -17,6 +17,14 @@ #' as a vector of dataset IDs. #' * `all_data` The API only downloads the first 25 records of the query. #' For the complete records, use `all_data=TRUE` +#' +#' Download responses are large, and every request costs the Neotoma API real +#' work. Pass all the dataset IDs you need to **one** call rather than calling +#' `get_downloads()` in a loop: a long vector is split into batches of 25 +#' datasets and requested one after another. The answer for a set of IDs is +#' kept for the rest of the R session, so asking for the same IDs again does +#' not call the API again. Set `options(neotoma2.cache = FALSE)` to turn this +#' off. #' @returns The function returns either a single item of class #' \code{"try-error"} describing the reason for failure #' (either misdefined parameters or an error from the Neotoma API), @@ -76,24 +84,79 @@ get_downloads <- function(x = NA, ...) { UseMethod("get_downloads", x) } +# Number of datasets requested per call to the API. A download response can +# reach tens of megabytes, so a long vector is fetched in modest batches, one +# after another, rather than as one very large request. +downloads_batch_size <- 25 + +# Number of batch results kept in the session cache; the oldest is dropped +# first, so a long session does not hold every download in memory. +downloads_cache_max <- 20 + +#' @title downloads_cached +#' @description An internal helper that runs `fetch()` for one batch of dataset +#' ids and keeps the answer for the rest of the session, so asking for the same +#' ids again does not call the API again. The raw API result is cached and +#' parsed into a fresh object on every call, so callers never share an object. +#' @param key `character` identifying the batch and its query arguments. +#' @param fetch A function with no arguments that performs the request. +#' @returns The (parsed JSON) API result. +#' @noRd +downloads_cached <- function(key, fetch) { + if (!neotoma_cache_on()) { + return(fetch()) + } + store <- neotoma_cache$downloads + if (is.null(store)) { + store <- list() + } + if (!is.null(store[[key]])) { + return(store[[key]]) + } + result <- fetch() + store[[key]] <- result + if (length(store) > downloads_cache_max) { + store <- utils::tail(store, downloads_cache_max) + } + neotoma_cache$downloads <- store + result +} + #' @rdname get_downloads #' @exportS3Method get_downloads numeric get_downloads.numeric <- function(x, ...) { - if (length(x) > 0) { - dataset <- paste0(x, collapse = ",") + if (length(x) == 0) { + return(NULL) + } + oo <- options(scipen = 9999) + on.exit(options(oo)) + dots <- list(...) + ids <- unique(x) + # A caller who sets `limit` or `offset` is slicing the result themselves, so + # the ids are sent together and the request is left exactly as asked. + if (any(c("limit", "offset") %in% names(dots))) { + batches <- list(ids) + } else { + batches <- split(ids, ceiling(seq_along(ids) / downloads_batch_size)) } - baseURL <- paste0("data/downloads?datasetid=", dataset) - result <- tryCatch( - parseURL(baseURL, ...), - error = function(e1) { + records <- list() + for (batch in batches) { + baseURL <- paste0("data/downloads?datasetid=", + paste0(batch, collapse = ",")) + key <- paste(baseURL, paste(names(dots), unlist(dots), collapse = "&")) + # A failed request is raised as it is. It is not repeated with the + # arguments removed: that is a different query, and it doubled the load on + # a server that had just failed. Batches that succeeded stay cached, so a + # second attempt only asks for the batches still missing. + result <- downloads_cached(key, function() { tryCatch( - parseURL(baseURL), - error = function(e2) { - stop("API call failed: ", e2$message) - } + do.call(parseURL, c(list(baseURL), dots)), + error = function(e) stop("API call failed: ", e$message, call. = FALSE) ) - } - ) + }) + records <- c(records, result$data) + } + result <- list(status = 200, data = records, message = "Success") if (!is.null(result[2]$data) || (length(result[2]$data) > 0)) { output <- parse_site(result) return(output) @@ -106,13 +169,8 @@ get_downloads.numeric <- function(x, ...) { #' @exportS3Method get_downloads sites get_downloads.sites <- function(x, verbose = TRUE, ...) { ids <- getids(x)$datasetid - cl <- as.list(match.call()) - cl[[1]] <- NULL - if ("all_data" %in% cl) { - all_data <- cl$all_data - } else { - all_data <- TRUE - } + dots <- list(...) + all_data <- if ("all_data" %in% names(dots)) dots$all_data else TRUE output <- get_downloads(x = ids, all_data = all_data) return(output) } diff --git a/R/get_sites.R b/R/get_sites.R index 3575445b..9d9e2307 100644 --- a/R/get_sites.R +++ b/R/get_sites.R @@ -18,6 +18,10 @@ #' parameters, and returns them as a `sites` object, a list of `site` #' objects. The `get_sites()` command wraps the Neotoma API #' ([api.neotomadb.org](https://api.neotomadb.org)) call for `sites`. +#' Some queries are slow for the API however few records they return: a spatial +#' query (`loc`) costs tens of seconds even when it matches no sites, and so do +#' wildcard (`%`) names and broad `taxa` filters. Add other filters to narrow a +#' query, test it with a small `limit` first, and avoid running it in a loop. #' The call itself uses a SQL query which accepts any one of the following #' parameters: #' * `siteid` The unique site ID (integer) in Neotoma. Can be passed as a diff --git a/R/get_table.R b/R/get_table.R index ca546552..9f70afe0 100644 --- a/R/get_table.R +++ b/R/get_table.R @@ -5,6 +5,11 @@ #' for a complete list of table names. #' @param limit Default 25 records #' @param offset Default 0. +#' @param refresh Default `FALSE`. Tables in the Neotoma database change rarely, +#' so the answer to a query is kept for the rest of the R session and asking +#' for the same `x`, `limit` and `offset` again does not call the API again. +#' Use `refresh = TRUE` to ask the API again. The session cache can be turned +#' off with `options(neotoma2.cache = FALSE)`. #' @returns selected `table` values from the Database. #' @examples \dontrun{ #' # Returns only the first 25 specimen records. @@ -13,7 +18,11 @@ #' @importFrom dplyr bind_rows #' @importFrom purrr map #' @export -get_table <- function(x, limit = 25, offset = 0) { +get_table <- function(x, limit = 25, offset = 0, refresh = FALSE) { + key <- paste("table", x, limit, offset, sep = "|") + if (!refresh && neotoma_cache_on() && !is.null(neotoma_cache[[key]])) { + return(neotoma_cache[[key]]) + } result <- tryCatch( parseURL("dbtables/table", table = x, limit = limit, offset = offset), error = function(e) { @@ -24,11 +33,15 @@ get_table <- function(x, limit = 25, offset = 0) { if (is.null(result$data)) { return(NULL) } else { - result <- result$data$data + result <- result$data$data output <- result %>% cleanNULL() %>% map(data.frame) %>% bind_rows() + # Only a successful answer is kept, so a failed call is tried again. + if (neotoma_cache_on()) { + neotoma_cache[[key]] <- output + } return(output) } -} \ No newline at end of file +} diff --git a/tests/testthat/test_get_downloads.R b/tests/testthat/test_get_downloads.R index 6f28151d..4e21eace 100644 --- a/tests/testthat/test_get_downloads.R +++ b/tests/testthat/test_get_downloads.R @@ -22,8 +22,8 @@ test_that("get_downloads from get_datasets() on.exit(Sys.sleep(10), add = TRUE) # `brazil_sf` comes from setup.R. A small `limit` is enough to prove # that downloading a multi-dataset object preserves the id set -- - # `all_data = TRUE` over the whole region is unnecessary here and was - # the single heaviest call in the suite. + # `all_data = TRUE` over the whole region is unnecessary here and + # was the single heaviest call in the suite. brazil_datasets <- get_datasets(loc = brazil_sf, limit = 5) brazil_dl <- get_downloads(brazil_datasets) testthat::expect_identical(nrow(getids(brazil_datasets)), @@ -63,16 +63,16 @@ test_that("get_downloads with or without all_data works.", { uk_bbox_geojson <- "{\n\"type\": \"FeatureCollection\",\n\"name\": \"out\",\n\"crs\": { \"type\": \"name\", \"properties\": { \"name\": \"urn:ogc:def:crs:OGC:1.3:CRS84\" } },\n\"features\": [\n{ \"type\": \"Feature\", \"properties\": { }, \"geometry\": { \"type\": \"Polygon\", \"coordinates\": [ [ [ -10.390234374999977, 50.021386718749994 ], [ 1.74658203125, 50.021386718749994 ], [ 1.74658203125, 60.831884765624991 ], [ -10.390234374999977, 60.831884765624991 ], [ -10.390234374999977, 50.021386718749994 ] ] ] } }\n]\n}" uk_datasets <- get_datasets( loc = uk_bbox_geojson, - datasettype = 'pollen', - limit=5 + datasettype = "pollen", + limit = 5 ) - uk_dl <- get_downloads(uk_datasets, all_data=TRUE) + uk_dl <- get_downloads(uk_datasets, all_data = TRUE) uk_dl2 <- get_downloads(uk_datasets) - testthat::expect_equal(nrow(as.data.frame(datasets(uk_dl))), + testthat::expect_equal(nrow(as.data.frame(datasets(uk_dl))), nrow(as.data.frame(datasets(uk_dl2)))) # expect no error - testthat::expect_error(get_downloads(uk_datasets, all_data=TRUE), NA) - testthat::expect_error(get_downloads(uk_datasets, all_data=FALSE), NA) + testthat::expect_error(get_downloads(uk_datasets, all_data = TRUE), NA) + testthat::expect_error(get_downloads(uk_datasets, all_data = FALSE), NA) testthat::expect_error(get_downloads(uk_datasets), NA) }) @@ -82,7 +82,7 @@ test_that("get_downloads handles empty result", { skip_on_ci() skip_if_api_unreachable() gpids <- c(7326, 6442, 7923, 7990, 7368, 8480, 8981, 7934) - ne_sites <- c() + ne_sites <- c() for (id in gpids) { search_1 <- get_sites(gpid = id) ne_sites <- c(ne_sites, search_1) @@ -90,9 +90,107 @@ test_that("get_downloads handles empty result", { diatom_list <- c("diatom", "diatom top-bottom", "diatom bottom sample") bottom_diat_info <- c() for (type in diatom_list) { - ne_sites - bottom_diatoms <- c(bottom_diat_info, ne_sites) - } + ne_sites + bottom_diatoms <- c(bottom_diat_info, ne_sites) + } bottom_diatoms testthat::expect_error(get_downloads(bottom_diatoms), NA) }) + +## Offline tests: parseURL() and parse_site() are replaced, so these touch no +## API. + +# Stand in for the API: answer each request with one record per dataset id, and +# log the ids and query arguments of every request. +mock_downloads <- function(log, fail_on = NULL) { + fake_parse_url <- function(x, ...) { + ids <- as.numeric(strsplit(sub(".*datasetid=", "", x), ",")[[1]]) + log$ids <- c(log$ids, list(ids)) + log$args <- c(log$args, list(list(...))) + if (!is.null(fail_on) && fail_on %in% ids) stop("HTTP 504") + list(status = "success", + data = lapply(ids, function(i) list(datasetid = i))) + } + local_mocked_bindings(parseURL = fake_parse_url, parse_site = function(x) x, + .package = "neotoma2", .env = parent.frame()) +} + +test_that("get_downloads fetches a long id vector in sequential batches", { + neotoma2:::neotoma_cache_clear() + on.exit(neotoma2:::neotoma_cache_clear()) + log <- new.env() + mock_downloads(log) + out <- get_downloads(1:60) + expect_equal(lengths(log$ids), c(25, 25, 10)) + expect_equal(unlist(log$ids), 1:60) + expect_equal(vapply(out$data, function(r) r$datasetid, numeric(1)), 1:60) +}) + +test_that("get_downloads keeps the caller's arguments on every batch", { + neotoma2:::neotoma_cache_clear() + on.exit(neotoma2:::neotoma_cache_clear()) + log <- new.env() + mock_downloads(log) + get_downloads(1:30, all_data = TRUE) + expect_true(all(vapply(log$args, function(a) isTRUE(a$all_data), logical(1)))) +}) + +test_that("a caller's limit or offset is sent as one request", { + neotoma2:::neotoma_cache_clear() + on.exit(neotoma2:::neotoma_cache_clear()) + log <- new.env() + mock_downloads(log) + get_downloads(1:60, limit = 10) + expect_length(log$ids, 1) + expect_equal(log$args[[1]]$limit, 10) +}) + +test_that("asking for the same datasets twice calls the API once", { + neotoma2:::neotoma_cache_clear() + on.exit({ + neotoma2:::neotoma_cache_clear() + options(neotoma2.cache = NULL) + }) + log <- new.env() + mock_downloads(log) + get_downloads(c(24, 1001)) + get_downloads(c(24, 1001)) + expect_length(log$ids, 1) + + options(neotoma2.cache = FALSE) + get_downloads(c(24, 1001)) + expect_length(log$ids, 2) +}) + +test_that("a failed batch is raised once, not repeated without arguments", { + # The old code answered any error with a second request that dropped + # `all_data`: a different query, sent to a server that had just failed. + neotoma2:::neotoma_cache_clear() + on.exit(neotoma2:::neotoma_cache_clear()) + log <- new.env() + mock_downloads(log, fail_on = 30) + expect_error(get_downloads(1:60, all_data = TRUE), "API call failed") + # Batch 1 (1-25) succeeded, batch 2 (26-50) failed once; batch 3 never ran. + expect_length(log$ids, 2) + + # The successful batch is cached, so a second attempt asks only for the rest. + log$ids <- NULL + expect_error(get_downloads(1:60, all_data = TRUE), "API call failed") + expect_length(log$ids, 1) + expect_equal(log$ids[[1]], 26:50) +}) + +test_that("get_downloads(sites) lets a caller turn all_data off", { + seen <- NULL + record_args <- function(x, ...) { + seen <<- list(...) + NULL + } + local_mocked_bindings(getids = function(x) data.frame(datasetid = c(1, 2)), + get_downloads = record_args, .package = "neotoma2") + # Call the method itself: get_downloads() is the thing being replaced. + neotoma2:::get_downloads.sites(new("sites", sites = list()), all_data = FALSE) + expect_false(seen$all_data) + neotoma2:::get_downloads.sites(new("sites", sites = list())) + expect_true(seen$all_data) +}) diff --git a/tests/testthat/test_get_table.R b/tests/testthat/test_get_table.R index 5cad27cd..28c39932 100644 --- a/tests/testthat/test_get_table.R +++ b/tests/testthat/test_get_table.R @@ -31,4 +31,69 @@ test_that("Correct table", { cols <- c("agetypeid", "agetype", "precedence", "shortagetype", "recdatecreated", "recdatemodified") testthat::expect_identical(colnames(tb1), cols) -}) \ No newline at end of file +}) + +## Offline tests: parseURL() is replaced, so these touch no API. + +table_result <- function() { + list(status = "success", + data = list(data = list(list(agetypeid = 1, agetype = "A"), + list(agetypeid = 2, agetype = "B")))) +} + +test_that("get_table asks the API once for the same table in one session", { + neotoma2:::neotoma_cache_clear() + on.exit(neotoma2:::neotoma_cache_clear()) + calls <- 0 + local_mocked_bindings(parseURL = function(...) { + calls <<- calls + 1 + table_result() + }, .package = "neotoma2") + + first <- get_table("agetypes") + second <- get_table("agetypes") + expect_equal(calls, 1) + expect_identical(first, second) + expect_equal(nrow(first), 2) + + # A different limit or offset is a different query. + get_table("agetypes", limit = 1) + get_table("agetypes", offset = 1) + expect_equal(calls, 3) +}) + +test_that("get_table(refresh = TRUE) and the cache option ask again", { + neotoma2:::neotoma_cache_clear() + on.exit({ + neotoma2:::neotoma_cache_clear() + options(neotoma2.cache = NULL) + }) + calls <- 0 + local_mocked_bindings(parseURL = function(...) { + calls <<- calls + 1 + table_result() + }, .package = "neotoma2") + + get_table("agetypes") + get_table("agetypes", refresh = TRUE) + expect_equal(calls, 2) + + options(neotoma2.cache = FALSE) + get_table("agetypes") + get_table("agetypes") + expect_equal(calls, 4) +}) + +test_that("a failed get_table call is not cached", { + neotoma2:::neotoma_cache_clear() + on.exit(neotoma2:::neotoma_cache_clear()) + calls <- 0 + local_mocked_bindings(parseURL = function(...) { + calls <<- calls + 1 + stop("server busy") + }, .package = "neotoma2") + expect_message(first <- get_table("agetypes"), "API call failed") + expect_null(first) + suppressMessages(get_table("agetypes")) + expect_equal(calls, 2) +}) diff --git a/tests/testthat/test_parseURL.R b/tests/testthat/test_parseURL.R index 3c2e58a5..45a16554 100644 --- a/tests/testthat/test_parseURL.R +++ b/tests/testthat/test_parseURL.R @@ -7,7 +7,7 @@ test_that("neotoma_baseurl resolves servers and honors APIPOINT", { expect_equal(neotoma2:::neotoma_baseurl("neotoma"), "https://api.neotomadb.org/v2.0/") expect_equal(neotoma2:::neotoma_baseurl("dev"), - "http://api-dev.neotomadb.org/v2.0/") + "https://api-dev.neotomadb.org/v2.0/") expect_equal(neotoma2:::neotoma_baseurl("local"), "http://localhost:3001/v2.0/") old <- Sys.getenv("APIPOINT") @@ -17,13 +17,6 @@ test_that("neotoma_baseurl resolves servers and honors APIPOINT", { if (old == "") Sys.unsetenv("APIPOINT") else Sys.setenv("APIPOINT" = old) }) -test_that("neotoma_id_param names the identifier from the endpoint path", { - expect_equal(neotoma2:::neotoma_id_param("data/sites/1,2,3"), "siteid") - expect_equal(neotoma2:::neotoma_id_param("data/datasets/1,2"), "datasetid") - expect_equal(neotoma2:::neotoma_id_param("data/downloads?datasetid=5"), - "datasetid") -}) - test_that("neotoma_body builds a JSON body from the query", { body <- neotoma2:::neotoma_body(list(siteid = c(1, 2), limit = 50)) expect_type(body, "character") @@ -39,10 +32,10 @@ cz_geojson <- paste0("{\"type\":\"Polygon\",\"coordinates\":[[[12.4,50.14],", api_url <- "https://api.neotomadb.org/v2.0/data/sites" -fake_response <- function(status) { +fake_response <- function(status, headers = list()) { structure(list(url = "https://api.neotomadb.org/v2.0/data/sites", status_code = as.integer(status), - headers = list(), + headers = headers, all_headers = list(), content = raw(0), request = list(), @@ -176,17 +169,91 @@ test_that("a timed-out request is retried at most once", { expect_equal(attempts, 2) }) -test_that("transient server failures are retried up to `times`", { +test_that("rate limiting (429) is retried up to `times`", { attempts <- 0 local_mocked_bindings(VERB = function(...) { attempts <<- attempts + 1 - fake_response(502) - }, .package = "neotoma2") + fake_response(429) + }, neotoma_wait = function(response, attempt) invisible(0), + .package = "neotoma2") response <- neotoma2:::neotoma_retry("GET", api_url, times = 3) expect_equal(attempts, 3) - expect_equal(response$status_code, 502) + expect_equal(response$status_code, 429) +}) + +test_that("a busy gateway (502/503/504) is retried at most once", { + # The API keeps working on a query the gateway gave up on, so a second request + # stacks a second heavy query on the first. + for (status in c(502, 503, 504)) { + attempts <- 0 + local_mocked_bindings(VERB = function(...) { + attempts <<- attempts + 1 + fake_response(status) + }, neotoma_wait = function(response, attempt) invisible(0), + .package = "neotoma2") + + response <- neotoma2:::neotoma_retry("GET", api_url, times = 4) + + expect_equal(attempts, 2, info = paste("status", status)) + expect_equal(response$status_code, status) + } +}) + +test_that("a deterministic server error (500) is not retried", { + # Four identical requests for a 500 that can never succeed was the pattern + # seen in the API logs. + attempts <- 0 + local_mocked_bindings(VERB = function(...) { + attempts <<- attempts + 1 + fake_response(500) + }, neotoma_wait = function(response, attempt) { + stop("must not wait for a 500") + }, .package = "neotoma2") + + response <- neotoma2:::neotoma_retry("POST", api_url, times = 4) + + expect_equal(attempts, 1) + expect_equal(response$status_code, 500) +}) + +test_that("the wait before a retry follows the policy", { + slept <- NULL + local_mocked_bindings(neotoma_sleep = function(seconds) { + slept <<- c(slept, seconds) + }, .package = "neotoma2") + + # A busy gateway waits 30 to 60 s, with jitter. + busy <- fake_response(503) + suppressMessages(replicate(20, neotoma2:::neotoma_wait(busy, 1))) + expect_true(all(slept >= 30 & slept <= 60)) + expect_gt(length(unique(slept)), 1) + + # Retry-After is honoured as sent, and capped at two minutes. + slept <- NULL + neotoma2:::neotoma_wait(fake_response(429, list("retry-after" = "7")), 1) + too_long <- fake_response(429, list("retry-after" = "9999")) + suppressMessages(neotoma2:::neotoma_wait(too_long, 1)) + expect_equal(slept, c(7, 120)) + + # A Retry-After that is a date, or nonsense, is ignored; so is a connection + # error. Both fall back to a short jittered backoff. + slept <- NULL + a_date <- fake_response(429, + list("retry-after" = "Wed, 21 Oct 2026 07:28:00 GMT")) + neotoma2:::neotoma_wait(a_date, 2) + neotoma2:::neotoma_wait(simpleError("Could not resolve host"), 2) + expect_true(all(slept >= 3 & slept <= 5)) +}) + +test_that("the default timeout sits just above the gateway cut-off", { + old <- Sys.getenv("NEOTOMA_TIMEOUT", unset = NA) + Sys.unsetenv("NEOTOMA_TIMEOUT") + on.exit(if (!is.na(old)) Sys.setenv(NEOTOMA_TIMEOUT = old)) + expect_equal(formals(neotoma2:::neotoma_retry)$seconds[[3]], 125) + Sys.setenv(NEOTOMA_TIMEOUT = "30") + expect_equal(neotoma2:::neotoma_env_num("NEOTOMA_TIMEOUT", 125), 30) }) test_that("client errors are not retried", { @@ -253,3 +320,277 @@ test_that("get_params fetches the Swagger document once per session", { expect_true(all(c("siteid", "sitename", "limit", "offset", "all_data") %in% unlist(first))) }) + + +## Request identity, error messages, and the paths that send an id list. + +fake_body <- function(text, status = 200) { + r <- fake_response(status) + r$content <- charToRaw(text) + r +} + +test_that("the User-Agent carries the package and R versions", { + ua <- neotoma2:::neotoma_user_agent() + expect_match(ua, "^neotoma2/[0-9][0-9.]* \\(R [0-9.]+\\)$") + expect_match(ua, as.character(utils::packageVersion("neotoma2")), + fixed = TRUE) +}) + +test_that("a contact is added to the User-Agent only when one is set", { + old_opt <- options(neotoma2.contact = NULL) + old_env <- Sys.getenv("NEOTOMA_CONTACT", unset = NA) + Sys.unsetenv("NEOTOMA_CONTACT") + on.exit({ + options(old_opt) + if (!is.na(old_env)) Sys.setenv(NEOTOMA_CONTACT = old_env) + }) + expect_false(grepl("contact", neotoma2:::neotoma_user_agent())) + + Sys.setenv(NEOTOMA_CONTACT = "env@example.org") + expect_match(neotoma2:::neotoma_user_agent(), + "; contact: env@example.org)", fixed = TRUE) + + options(neotoma2.contact = "opt@example.org") + expect_match(neotoma2:::neotoma_user_agent(), + "; contact: opt@example.org)", fixed = TRUE) +}) + +test_that("a web page in place of data gets a clear error", { + # The API's catch-all redirects an unknown route to its documentation. + html <- fake_body("api-docs") + expect_error(neotoma2:::neotoma_content(html), "web page instead of data") + ok <- fake_body('{"status":"success"}') + expect_equal(neotoma2:::neotoma_content(ok)$status, "success") +}) + +json_failure <- function(status, json) { + r <- fake_response(status) + r$content <- charToRaw(json) + r$headers <- list("content-type" = "application/json") + r +} + +test_that("the API's reason for a failure is shown to the user", { + # Current shape: the database error is in `message`, `data` is null. + json <- paste0('{"status":"failure","data":null,', + '"message":"operator does not exist: integer = text"}') + new_shape <- json_failure(500, json) + expect_equal(neotoma2:::neotoma_api_message(new_shape), + "operator does not exist: integer = text") + expect_error(neotoma2:::neotoma_status_check(new_shape), + "The API said: operator does not exist: integer = text") + # Earlier shape: the database error is in `data`, `message` is generic. + json <- paste0('{"status":"failure","data":', + '"operator does not exist: integer = text",', + '"message":"SQL Error."}') + old_shape <- json_failure(500, json) + expect_equal(neotoma2:::neotoma_api_message(old_shape), + "operator does not exist: integer = text") + # No usable reason: the plain HTTP error still comes through. + html <- fake_response(500) + html$content <- charToRaw("oops") + expect_true(is.na(neotoma2:::neotoma_api_message(html))) + expect_error(neotoma2:::neotoma_status_check(html), "500") + expect_true(is.na(neotoma2:::neotoma_api_message(fake_response(500)))) +}) + +test_that("a busy server is named as such, not blamed on the API path", { + expect_error(neotoma2:::neotoma_status_check(fake_response(504)), + "busy or restarting") + expect_error(neotoma2:::neotoma_status_check(fake_response(429)), + "Too many requests") +}) + +## Capture the requests that neotoma_retry() would make, and answer each with +## `data` records that name the ids found in the request URL. +record_requests <- function(log) { + function(verb, url, ...) { + args <- list(...) + log$verb <- c(log$verb, verb) + log$url <- c(log$url, url) + log$body <- c(log$body, if (!is.null(args$body)) as.character(args$body)) + log$config <- c(log$config, list(Filter(function(a) inherits(a, "request"), + args))) + ids <- if (!is.null(args$body)) { + sent <- jsonlite::fromJSON(as.character(args$body)) + as.character(if (!is.null(sent$siteid)) sent$siteid else sent$datasetid) + } else { + regmatches(url, regexpr("[0-9][0-9,]*$", url)) + } + recs <- if (length(ids)) { + lapply(strsplit(ids, ",")[[1]], function(i) list(id = as.numeric(i))) + } else { + list() + } + body <- list(status = "success", data = recs) + fake_body(as.character(jsonlite::toJSON(body, auto_unbox = TRUE))) + } +} + +test_that("long id lists go as short GETs where there is no POST route", { + # Taxa, publications and contacts have no POST route: a POST to them is + # redirected to /api-docs. + for (endpoint in c("data/taxa/", "data/publications/", "data/contacts/")) { + log <- new.env() + local_mocked_bindings(neotoma_retry = record_requests(log), + .package = "neotoma2") + path <- paste0(endpoint, paste(1:1500, collapse = ",")) + result <- neotoma2:::neotoma_fetch("https://api.neotomadb.org/", path, + list(offset = 0, limit = 2000)) + expect_true(all(log$verb == "GET"), info = endpoint) + expect_length(log$url, 15) + expect_true(all(nchar(log$url) < 2000), info = endpoint) + # every id is requested exactly once, in order, and the records come back + # combined in that order + requested <- as.numeric(unlist(strsplit(sub(".*[=/]", "", log$url), ","))) + expect_equal(requested, 1:1500, info = endpoint) + expect_equal(vapply(result$data, function(r) r$id, numeric(1)), 1:1500, + info = endpoint) + } +}) + +test_that("long id lists for sites, datasets, downloads POST in chunks", { + cases <- list( + list(path = "data/sites/", post = "data/sites", key = "siteid"), + list(path = "data/datasets/", post = "data/datasets", key = "datasetid"), + list(path = "data/downloads?datasetid=", post = "data/downloads", + key = "datasetid") + ) + for (case in cases) { + log <- new.env() + local_mocked_bindings(neotoma_retry = record_requests(log), + .package = "neotoma2") + path <- paste0(case$path, paste(1:1500, collapse = ",")) + result <- neotoma2:::neotoma_fetch("https://api.neotomadb.org/v2.0/", path, + list(offset = 0, limit = 2000)) + expect_true(all(log$verb == "POST"), info = case$path) + expect_length(log$url, 15) + # the ids are in the body, never in the URL, so no `?datasetid=` prefix can + # leak into a body value + expect_true(all(log$url == paste0("https://api.neotomadb.org/v2.0/", + case$post)), info = case$path) + bodies <- lapply(log$body, jsonlite::fromJSON) + expect_true(all(vapply(bodies, function(b) !is.null(b[[case$key]]), + logical(1))), info = case$path) + expect_true(all(vapply(bodies, function(b) b$limit == 2000, logical(1))), + info = case$path) + sent <- as.numeric(unlist(strsplit(vapply(bodies, function(b) b[[case$key]], + character(1)), ","))) + expect_equal(sent, 1:1500, info = case$path) + expect_equal(vapply(result$data, function(r) r$id, numeric(1)), 1:1500, + info = case$path) + } +}) + +test_that("a POST keeps its method and body through a redirect", { + # libcurl turns a redirected POST into a GET and drops the body unless asked + # not to; the API then answers with its unfiltered first page. + log <- new.env() + local_mocked_bindings(neotoma_retry = record_requests(log), + .package = "neotoma2") + neotoma2:::neotoma_post("https://api.neotomadb.org/v2.0/data/sites", + list(siteid = "24,25")) + expect_true(any(vapply(log$config[[1]], + function(a) identical(a$options$postredir, 7), + logical(1)))) +}) + +test_that("a POST for ids that were not applied is reported, not returned", { + # A server that ignores the body returns its default page of records. + default_page <- function(verb, url, ...) { + recs <- lapply(1:25, function(i) list(siteid = i)) + body <- list(status = "success", data = recs) + fake_body(as.character(jsonlite::toJSON(body, auto_unbox = TRUE))) + } + local_mocked_bindings(neotoma_retry = default_page, .package = "neotoma2") + # more records than ids + api <- "https://api.neotomadb.org/v2.0/" + expect_error(neotoma2:::neotoma_get_ids(api, "data/sites/24,25,26", list()), + "ids were not applied") + # fewer records than ids, but not the ones asked for + other_ids <- paste0("data/sites/", paste(101:200, collapse = ",")) + expect_error(neotoma2:::neotoma_get_ids(api, other_ids, list()), + "ids were not applied") + returned <- list(list(siteid = 24), list(siteid = 25)) + expect_true(neotoma2:::neotoma_ids_applied(returned, "siteid", + c("24", "25", "26"))) +}) + +test_that("a spatial loc query is still sent as a POST body", { + log <- new.env() + local_mocked_bindings(neotoma_retry = record_requests(log), + .package = "neotoma2") + neotoma2:::neotoma_fetch("https://api.neotomadb.org/", "data/datasets", + list(loc = cz_geojson, limit = 5)) + expect_equal(log$verb, "POST") + expect_equal(log$url, "https://api.neotomadb.org/data/datasets") + expect_true(jsonlite::validate(log$body)) +}) + +test_that("a long filter list is POSTed where there is a route, else one GET", { + log <- new.env() + local_mocked_bindings(neotoma_retry = record_requests(log), + .package = "neotoma2") + neotoma2:::parseURL("data/datasets", taxa = paste0("Taxon", 1:300), limit = 5) + expect_equal(log$verb, "POST") + expect_equal(jsonlite::fromJSON(log$body)$limit, 5) + expect_length(strsplit(jsonlite::fromJSON(log$body)$taxa, ",")[[1]], 300) + + log2 <- new.env() + local_mocked_bindings(neotoma_retry = record_requests(log2), + .package = "neotoma2") + neotoma2:::parseURL("data/publications", search = strrep("word ", 500), + limit = 5) + expect_equal(log2$verb, "GET") + expect_length(log2$url, 1) +}) + +test_that("only the endpoints the API accepts a POST for are POST-routed", { + yes <- c("data/sites", "data/datasets", "data/downloads", "data/datasets/24", + "data/sites/24/datasets", "data/geopoliticalunits/1/sites", + "data/downloads?datasetid=1,2") + no <- c("data/taxa", "data/taxa/1,2", "data/publications", "data/contacts", + "data/sites/24", "data/sites/24/chronologies", + "data/dbtables/agetypes") + expect_true(all(vapply(yes, neotoma2:::neotoma_post_route, logical(1)))) + expect_false(any(vapply(no, neotoma2:::neotoma_post_route, logical(1)))) +}) + +test_that("a short id list is still a single GET", { + log <- new.env() + local_mocked_bindings(neotoma_retry = record_requests(log), + .package = "neotoma2") + neotoma2:::neotoma_fetch("https://api.neotomadb.org/", "data/taxa/1,2,3", + list()) + expect_equal(log$verb, "GET") + expect_length(log$url, 1) +}) + +test_that("a multi-valued argument is sent as one comma-separated value", { + # httr/modify_url take one value per parameter; vectors used to stop the + # request with "values must be length 1". + sent <- NULL + local_mocked_bindings(neotoma_fetch = function(baseurl, x, query) { + sent <<- query + list(status = 200, data = list()) + }, .package = "neotoma2") + neotoma2:::parseURL("data/datasets", taxa = c("Abies", "Pinus"), + datasettype = c("pollen", "macrofossil"), limit = 5, + loc = c(-80, 40, -70, 50)) + expect_equal(sent$taxa, "Abies,Pinus") + expect_equal(sent$datasettype, "pollen,macrofossil") + expect_equal(sent$limit, 5) + expect_equal(sent$loc, c(-80, 40, -70, 50)) +}) + +test_that("a vector parameter makes a valid GET URL end to end", { + log <- new.env() + local_mocked_bindings(neotoma_retry = function(verb, url, ..., query = NULL) { + log$query <- query + fake_body('{"status":"success","data":[]}') + }, .package = "neotoma2") + expect_no_error(neotoma2:::parseURL("data/datasets", + taxa = c("Abies", "Pinus"))) + expect_equal(log$query$taxa, "Abies,Pinus") +}) From 608dbc614857cbfcf138fb0e551c81459b48f6a6 Mon Sep 17 00:00:00 2001 From: Socorro DominguezVidana Date: Wed, 21 Oct 2026 20:33:45 -0700 Subject: [PATCH 2/5] Fixing taxa calls based on Jessica's msg --- R/get_taxa.R | 139 ++++++++++++++++++++++++++++++++------------------ R/get_taxon.R | 32 +++++++++--- 2 files changed, 112 insertions(+), 59 deletions(-) diff --git a/R/get_taxa.R b/R/get_taxa.R index e5f43498..c14f2151 100644 --- a/R/get_taxa.R +++ b/R/get_taxa.R @@ -1,18 +1,37 @@ #' @title get_taxa #' @name get_taxa #' @author Socorro Dominguez \email{dominguezvid@wisc.edu} -#' @description a `sites` object with sites that contain the requested `taxa.` -#' @param x A `taxon` ID to extract site information +#' @description Find the Neotoma datasets that contain a taxon, and return +#' them as a `sites` object. +#' @param x A taxon ID (integer, or a vector of IDs) in Neotoma. #' @param ... accepted arguments, see details for more information. #' @details -#' The `get_taxa` function searches for a sites within Neotoma -#' that contain the requested taxa. -#' The `get_taxa` command wraps the Neotoma API`. -#' The call itself accepts any one of the following -#' parameters: -#' * `taxonid` The unique taxon ID (integer) in Neotoma. Can be passed as a -#' vector of site IDs. -#' @returns A Neotoma2 sites object with datasets with the requested taxa. +#' `get_taxa()` works in two steps. First it resolves the taxon you supplied +#' to taxon names, with [get_taxon()]. Then it asks Neotoma for the datasets +#' that contain those names, with [get_datasets()]. The second step is the +#' expensive one: the API can take a minute or more to answer a broad +#' `taxa=` filter, so a taxon ID, or a name with a wildcard, that stands for +#' many names produces a slow request. `get_taxa()` warns when it is about to +#' send more than 25 distinct names, and it never sends the dataset request +#' without a taxon filter: if no taxon is found it returns `NULL`. +#' +#' The taxon can be given in any one of the following ways: +#' * `x` A taxon ID (integer) in Neotoma. Can be passed as a vector of IDs. +#' * `taxonname` A taxon name, or a partial name using `%` as a wildcard, +#' which is resolved with [get_taxon()]. +#' * `taxa` One or more exact taxon names, used as they are. +#' +#' Any other argument that [get_datasets()] accepts (`datasettype`, `loc`, +#' `ageyoung`, `ageold`, `limit`, `offset`, `all_data`, ...) is passed on to +#' that second step. +#' @returns A Neotoma2 `sites` object holding the datasets with the requested +#' taxa, or `NULL` if no taxon or no dataset was found. +#' @examples \dontrun{ +#' # Datasets containing taxon 1 (Abies), at most five of them: +#' abies <- get_taxa(1, limit = 5) +#' # The same, starting from the taxon name: +#' abies <- get_taxa(taxonname = "Abies", limit = 5) +#' } #' @md #' @export get_taxa <- function(x = NA, ...) { @@ -23,58 +42,76 @@ get_taxa <- function(x = NA, ...) { } } +# The largest number of taxon names sent in one `taxa=` filter before +# `get_taxa()` warns that the request will be slow. +taxa_name_warn_limit <- 25 + +#' @title taxon_names +#' @description An internal helper that returns the distinct names in a `taxa` +#' object, or `character(0)` for `NULL` (nothing was found). +#' @param taxa_data A `taxa` object, or `NULL`. +#' @returns `character` vector of taxon names. +#' @noRd +taxon_names <- function(taxa_data) { + if (is.null(taxa_data)) { + return(character(0)) + } + nm <- unique(as.data.frame(taxa_data)$taxonname) + nm[!is.na(nm)] +} + +#' @title datasets_with_taxa +#' @description An internal helper shared by the `get_taxa()` methods. It sends +#' one `get_datasets()` request filtered by taxon name, and refuses to send it +#' with no names: an empty filter would ask the API for every dataset. +#' @param taxon `character` taxon names. +#' @param dots A named list of the arguments to pass on to `get_datasets()`. +#' @returns A `sites` object, or `NULL` if there is nothing to look for. +#' @noRd +datasets_with_taxa <- function(taxon, dots) { + taxon <- unique(taxon) + if (length(taxon) == 0) { + message("No taxon found with the provided information. ", + "No datasets were requested.") + return(NULL) + } + if (length(taxon) > taxa_name_warn_limit) { + warning(length(taxon), " taxon names will be sent to the API in one ", + "request. Broad `taxa` queries can take a minute or more to ", + "answer. Consider a narrower taxon name or ID, or add other ", + "filters such as `datasettype`, `loc`, or `limit`.", + call. = FALSE) + } + do.call(get_datasets, c(list(taxa = taxon), dots)) +} + #' @rdname get_taxa #' @method get_taxa numeric #' @exportS3Method get_taxa numeric get_taxa.numeric <- function(x, ...) { oo <- options(scipen = 9999) on.exit(options(oo)) - taxa_data <- get_taxon(x, ...) - taxa_names <- unique(as.data.frame(taxa_data)$taxonname) - cl <- as.list(match.call()) - cl[[1]] <- NULL - cl <- lapply(cl, eval, envir = parent.frame()) - params <- suppressWarnings(get_params("datasets")) - params <- c(params, "limit", "offset", "all_data") - ds_params <- list() - for (name in names(cl)) { - if (name %in% params){ - if (name != "taxa") { - ds_params[name] <- cl[[name]] - } else { - ds_params[['taxa']] <- list(taxa_names) - } - } - } - if (is.null(ds_params)) { - ds_params <- list() - } - sites <- do.call(get_datasets, ds_params) - return(sites) + # Only the taxon ID goes to the taxa endpoint: the dataset arguments in `...` + # (limit, offset, all_data, loc, ...) belong to the datasets request. + datasets_with_taxa(taxon_names(get_taxon(x)), list(...)) } #' @rdname get_taxa #' @method get_taxa default #' @exportS3Method get_taxa default get_taxa.default <- function(...) { - cl <- as.list(match.call()) - cl[[1]] <- NULL - cl <- lapply(cl, eval, envir = parent.frame()) - if ("all_data" %in% cl) { - all_data <- cl$all_data + oo <- options(scipen = 9999) + on.exit(options(oo)) + dots <- list(...) + if ("taxa" %in% names(dots)) { + taxon <- as.character(unlist(dots$taxa)) + } else if ("taxonname" %in% names(dots)) { + taxon <- taxon_names(get_taxon(taxonname = dots$taxonname)) } else { - all_data <- FALSE - } - if ("taxa" %in% names(cl)){ - sites <- get_datasets(taxa = taxa, all_data = all_data) - } else if ("taxonname" %in% names(cl)) { - taxon_data <- get_taxon(taxonname = cl$taxonname) - taxon_names <- unique(as.data.frame(taxon_data)$taxonname) - sites <- get_datasets(taxa = taxon_names, all_data = all_data) - } else { - stop("Please provide a taxon ID, taxon name, - or taxon object to extract site information.") - return(NULL) + stop("Please provide a taxon ID, a taxon name (`taxonname`), ", + "or exact taxon names (`taxa`) to extract site information.") } - return(sites) -} \ No newline at end of file + dots$taxa <- NULL + dots$taxonname <- NULL + datasets_with_taxa(taxon, dots) +} diff --git a/R/get_taxon.R b/R/get_taxon.R index 3ab83d98..eb672863 100644 --- a/R/get_taxon.R +++ b/R/get_taxon.R @@ -15,7 +15,7 @@ parse_taxon <- function(data) { 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"), + taxagroupid = use_na(testNull(x$taxagroupid, NA), "char"), publicationid = use_na(testNull(x$publicationid, NA), "int"), publication = use_na(testNull(x$publication, NA), "char")) }) @@ -65,7 +65,7 @@ get_taxon.default <- function(...) { cl <- as.list(match.call()) cl[[1]] <- NULL cl <- lapply(cl, eval, envir = parent.frame()) - if ("all_data" %in% cl) { + if ("all_data" %in% names(cl)) { all_data <- cl$all_data } else { all_data <- TRUE @@ -76,8 +76,13 @@ get_taxon.default <- function(...) { are: ", paste(unlist(params), collapse = ", ")) } baseURL <- paste0("data/taxa") + # `all_data` is handed to parseURL() explicitly, and taken out of `...` so it + # is not passed twice. Without this a wildcard such as `taxonname = "Pinus%"` + # came back as the API's first page only, with no warning. + dots <- list(...) + dots$all_data <- NULL result <- tryCatch( - parseURL(baseURL, ...), + do.call(parseURL, c(list(baseURL, all_data = all_data), dots)), error = function(e) { stop("API call failed: ", e$message) NULL @@ -102,9 +107,19 @@ get_taxon.default <- function(...) { #' @export #' @method get_taxon numeric get_taxon.numeric <- function(x, ...) { - if (length(x) > 0) { - taxa_id <- paste0(x, collapse = ",") + # An NA would become `data/taxa/NA`, which the API answers with a database + # error rather than "nothing found". + x <- x[!is.na(x)] + if (length(x) == 0) { + message("No taxon ID provided.") + return(NULL) } + oo <- options(scipen = 9999) + on.exit(options(oo)) + taxa_id <- paste0(unique(x), collapse = ",") + # A long vector of ids makes a URL the API will not take. parseURL() then + # sends the ids in several short GET requests (there is no POST route for + # taxa), so it is safe to pass any number of ids here. baseURL <- paste0("data/taxa/", taxa_id) result <- tryCatch( parseURL(baseURL, ...), @@ -113,12 +128,13 @@ get_taxon.numeric <- function(x, ...) { NULL } ) - result_length <- length(result[2]$data) + result_length <- length(result$data) if (result_length > 0) { output <- parse_taxon(result) return(output) } else { - message("No taxon data found for taxon ID: ", taxa_id) + message("No taxon data found for taxon ID: ", + substr(taxa_id, 1, 60), if (nchar(taxa_id) > 60) "...") return(NULL) } -} \ No newline at end of file +} From 9278bb1b2d899f4d03e7afbc1fbd540eada3856a Mon Sep 17 00:00:00 2001 From: Socorro DominguezVidana Date: Wed, 21 Oct 2026 20:33:52 -0700 Subject: [PATCH 3/5] Fixing taxa calls based on Jessica's msg --- tests/testthat/test_get_taxa.R | 155 +++++++++++++++++++++++++++++++- tests/testthat/test_get_taxon.R | 103 ++++++++++++++++++++- 2 files changed, 254 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test_get_taxa.R b/tests/testthat/test_get_taxa.R index 0ba0c59b..06e1bd52 100644 --- a/tests/testthat/test_get_taxa.R +++ b/tests/testthat/test_get_taxa.R @@ -13,8 +13,159 @@ test_that("get_taxa() sites object", { testthat::expect_is(abies, "sites") abies_df <- abies %>% get_downloads() %>% taxa() %>% suppressWarnings() testthat::expect_true(any(grepl("Abies", abies_df$variablename))) - abies <- get_taxa(taxonname = 'abies') + abies <- get_taxa(taxonname = "abies") testthat::expect_is(abies, "sites") abies_df <- abies %>% get_downloads() %>% taxa() %>% suppressWarnings() testthat::expect_true(any(grepl("Abies", abies_df$variablename))) -}) \ No newline at end of file +}) + +## Offline tests. `get_taxon()` and `get_datasets()` are replaced, so these +## touch no API and need no skip. They check the requests `get_taxa()` makes. + +fake_taxon <- function(names) { + force(names) + function(...) { + if (is.null(names)) return(NULL) + new("taxa", taxa = lapply(seq_along(names), function(i) { + new("taxon", taxonid = i, taxonname = names[[i]]) + })) + } +} + +# Replace get_taxon()/get_datasets(); `log` records what get_datasets() gets. +mock_taxa_steps <- function(names, log, .env = parent.frame()) { + record_datasets <- function(...) { + log$calls <- c(log$calls, list(list(...))) + "datasets" + } + local_mocked_bindings(get_taxon = fake_taxon(names), + get_datasets = record_datasets, + .package = "neotoma2", .env = .env) +} + +test_that("get_taxa(taxa=) sends the names, not the taxa() generic", { + log <- new.env() + mock_taxa_steps("Abies", log) + expect_equal(get_taxa(taxa = "Pinus"), "datasets") + expect_equal(log$calls[[1]]$taxa, "Pinus") + expect_type(log$calls[[1]]$taxa, "character") +}) + +test_that("get_taxa honours a caller's all_data in both calls", { + log <- new.env() + mock_taxa_steps("Abies", log) + get_taxa(taxonname = "Abies", all_data = TRUE) + get_taxa(taxa = "Abies", all_data = TRUE) + expect_true(log$calls[[1]]$all_data) + expect_true(log$calls[[2]]$all_data) +}) + +test_that("get_taxa(taxonname=) forwards the dataset arguments", { + log <- new.env() + mock_taxa_steps("Pinus", log) + get_taxa(taxonname = "Pinus", datasettype = c("pollen", "macrofossil"), + loc = c(-80, 40, -70, 50), limit = 5, offset = 10, + ageyoung = 100, ageold = 5000) + call <- log$calls[[1]] + expect_equal(call$taxa, "Pinus") + expect_equal(call$datasettype, c("pollen", "macrofossil")) + expect_equal(call$loc, c(-80, 40, -70, 50)) + expect_equal(call[c("limit", "offset", "ageyoung", "ageold")], + list(limit = 5, offset = 10, ageyoung = 100, ageold = 5000)) + expect_false("taxonname" %in% names(call)) +}) + +test_that("get_taxa() filters the datasets by the taxon's names", { + # The numeric method used to call get_datasets() with no taxa filter at all. + log <- new.env() + mock_taxa_steps(c("Abies", "Abies alba"), log) + expect_equal(get_taxa(1, limit = 5), "datasets") + expect_equal(log$calls[[1]]$taxa, c("Abies", "Abies alba")) + expect_equal(log$calls[[1]]$limit, 5) +}) + +test_that("get_taxa sends only the id to the taxa endpoint", { + seen <- NULL + fake_get_taxon <- function(...) { + seen <<- list(...) + new("taxa", taxa = list(new("taxon", taxonid = 1, taxonname = "Abies"))) + } + local_mocked_bindings(get_taxon = fake_get_taxon, + get_datasets = function(...) "datasets", + .package = "neotoma2") + get_taxa(1, limit = 5, offset = 2, all_data = TRUE, loc = c(1, 2, 3, 4)) + expect_equal(seen, list(1)) +}) + +test_that("get_taxa never asks for datasets without a taxon filter", { + log <- new.env() + mock_taxa_steps(NULL, log) + expect_message(res <- get_taxa(taxonname = "Zzzzz not a taxon"), + "No datasets were requested") + expect_null(res) + expect_message(res <- get_taxa(999999999), "No datasets were requested") + expect_null(res) + expect_message(res <- get_taxa(taxa = character(0)), + "No datasets were requested") + expect_null(log$calls) +}) + +test_that("get_taxa asks for a taxon", { + expect_error(get_taxa(limit = 5), "taxon ID") +}) + +test_that("get_taxa warns before sending a very broad taxa filter", { + log <- new.env() + mock_taxa_steps(paste("Taxon", 1:80), log) + expect_warning(get_taxa(taxonname = "Taxon%"), "80 taxon names") + expect_length(log$calls[[1]]$taxa, 80) + + mock_taxa_steps(paste("Taxon", 1:25), log) + expect_no_warning(get_taxa(taxonname = "Taxon%")) +}) + +test_that("get_taxa() searches datasets for that taxon, not all", { + # A user looked up `Bison*`, took the second record (Bison bison, 5868) and + # passed its id to get_taxa(). The datasets that came back were pollen surface + # samples with none of the taxon: the old get_taxa() called get_datasets() + # with no taxon filter, so it returned the API's first page of datasets. + bison_taxa <- list(new("taxon", taxonid = 6774, taxonname = "Bison"), + new("taxon", taxonid = 5868, taxonname = "Bison bison"), + new("taxon", taxonid = 6772, taxonname = "Bison priscus")) + bison <- new("taxa", taxa = bison_taxa) + seen <- new.env() + fake_get_taxon <- function(x = NULL, ...) { + seen$taxon_args <- c(seen$taxon_args, list(list(x, ...))) + if (is.numeric(x)) { + new("taxa", taxa = Filter(function(t) t@taxonid %in% x, bison@taxa)) + } else { + bison + } + } + fake_get_datasets <- function(...) { + seen$datasets <- c(seen$datasets, list(list(...))) + "datasets" + } + local_mocked_bindings(get_taxon = fake_get_taxon, + get_datasets = fake_get_datasets, + .package = "neotoma2") + + second <- get_taxon(taxonname = "Bison*")[2] + expect_equal(second$taxonid, 5868) + expect_equal(get_taxa(second$taxonid, all_data = TRUE), "datasets") + + # the taxon id is looked up on its own: nothing for the datasets request + # leaks into the taxa endpoint + expect_equal(seen$taxon_args[[2]], list(5868)) + # exactly one datasets request, filtered by that taxon's name and by nothing + # else the caller did not ask for + expect_length(seen$datasets, 1) + expect_equal(seen$datasets[[1]], list(taxa = "Bison bison", all_data = TRUE)) +}) + +test_that("get_taxa() asks for no datasets when the id is unknown", { + log <- new.env() + mock_taxa_steps(NULL, log) + expect_message(expect_null(get_taxa(999999999)), "No taxon found") + expect_null(log$calls) +}) diff --git a/tests/testthat/test_get_taxon.R b/tests/testthat/test_get_taxon.R index 451ff735..6dd22473 100644 --- a/tests/testthat/test_get_taxon.R +++ b/tests/testthat/test_get_taxon.R @@ -6,9 +6,108 @@ test_that("`get_taxon` yields specific taxon information", { abies_num <- get_taxon(1) testthat::expect_is(abies_num, "taxa") testthat::expect_is(abies_num[[1]], "taxon") - + abies_name <- get_taxon(taxonname = "abies") testthat::expect_is(abies_name, "taxa") testthat::expect_is(abies_name[[1]], "taxon") testthat::expect_equal(as.data.frame(abies_num), as.data.frame(abies_name)) -}) \ No newline at end of file +}) + +## Offline tests: parseURL() is replaced, so these touch no API. + +taxon_result <- function(n) { + list(status = "success", message = "ok", + data = lapply(seq_len(n), function(i) { + list(taxonid = i, taxonname = paste("Taxon", i)) + })) +} + +taxon_params <- function(...) list("taxonname", "limit", "offset", "all_data") + +test_that("get_taxon(taxonname=) fetches every page by default", { + # all_data was computed and never handed to parseURL(), so a wildcard came + # back as the API's first page only. + seen <- NULL + fake_parse_url <- function(x, ...) { + seen <<- list(x = x, ...) + taxon_result(3) + } + local_mocked_bindings(get_params = taxon_params, parseURL = fake_parse_url, + .package = "neotoma2") + out <- get_taxon(taxonname = "Pinus%") + expect_equal(seen$x, "data/taxa") + expect_true(seen$all_data) + expect_equal(seen$taxonname, "Pinus%") + expect_s4_class(out, "taxa") + expect_length(out, 3) +}) + +test_that("get_taxon honours all_data = FALSE and never sends it twice", { + seen <- NULL + fake_parse_url <- function(x, ...) { + seen <<- list(...) + taxon_result(1) + } + local_mocked_bindings(get_params = taxon_params, parseURL = fake_parse_url, + .package = "neotoma2") + get_taxon(taxonname = "Pinus%", all_data = FALSE) + expect_false(seen$all_data) + expect_equal(sum(names(seen) == "all_data"), 1) +}) + +test_that("a long vector of taxon ids never POSTs to data/taxa", { + # The API has no POST route for taxa; the POST was redirected to /api-docs. + verbs <- character(0) + urls <- character(0) + fake_retry <- function(verb, url, ...) { + verbs <<- c(verbs, verb) + urls <<- c(urls, url) + ids <- strsplit(sub(".*/", "", url), ",")[[1]] + records <- lapply(ids, function(i) { + list(taxonid = as.numeric(i), taxonname = paste("Taxon", i)) + }) + body <- jsonlite::toJSON(list(status = "success", data = records), + auto_unbox = TRUE) + structure(list(url = url, status_code = 200L, headers = list(), + content = charToRaw(as.character(body))), + class = "response") + } + local_mocked_bindings(neotoma_retry = fake_retry, .package = "neotoma2") + out <- get_taxon(1:1500) + expect_true(all(verbs == "GET")) + expect_length(urls, 15) + expect_true(all(nchar(urls) < 2000)) + expect_s4_class(out, "taxa") + expect_length(out, 1500) +}) + +test_that("get_taxon with no ids returns NULL and asks for nothing", { + local_mocked_bindings(parseURL = function(...) stop("must not be called"), + .package = "neotoma2") + expect_message(res <- get_taxon(numeric(0)), "No taxon ID") + expect_null(res) +}) + + +test_that("a taxon record without a taxon group still parses", { + # `taxagroupid` is a character slot; a missing value used to be coerced to an + # integer NA, which made the whole taxa object invalid. + records <- list(list(taxonid = 1, taxonname = "Abies"), + list(taxonid = 2, taxonname = "Pinus", taxagroupid = "VPL")) + out <- neotoma2:::parse_taxon(list(data = records)) + expect_s4_class(out, "taxa") + expect_true(is.na(out[[1]]@taxagroupid)) + expect_equal(out[[2]]@taxagroupid, "VPL") +}) + +test_that("a missing taxon id sends no request", { + # `data/taxa/NA` makes the API fail with a database error. + requests <- 0 + local_mocked_bindings(parseURL = function(...) { + requests <<- requests + 1 + NULL + }, .package = "neotoma2") + expect_message(expect_null(get_taxon(NA_integer_)), "No taxon ID") + expect_message(expect_null(get_taxon(c(NA_real_, NA_real_))), "No taxon ID") + expect_equal(requests, 0) +}) From 1b6aeff02a551e427a954440e16e94131a4c92cd Mon Sep 17 00:00:00 2001 From: Socorro DominguezVidana Date: Wed, 21 Oct 2026 20:35:36 -0700 Subject: [PATCH 4/5] fixing api calls and documentation --- NAMESPACE | 2 +- NEWS.md | 48 ++++- R/parseURL.R | 503 ++++++++++++++++++++++++++++++++----------- man/get_datasets.Rd | 5 + man/get_downloads.Rd | 8 + man/get_sites.Rd | 4 + man/get_table.Rd | 8 +- man/get_taxa.Rd | 41 +++- 8 files changed, 480 insertions(+), 139 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 0c1bfd6d..6ae993f0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -159,6 +159,7 @@ importFrom(httr,GET) importFrom(httr,HEAD) importFrom(httr,VERB) importFrom(httr,add_headers) +importFrom(httr,config) importFrom(httr,content) importFrom(httr,http_error) importFrom(httr,modify_url) @@ -206,7 +207,6 @@ importFrom(sf,st_transform) importFrom(sf,st_union) importFrom(stats,na.omit) importFrom(stringr,str_detect) -importFrom(stringr,str_extract_all) importFrom(stringr,str_match) importFrom(stringr,str_match_all) importFrom(tidyr,pivot_wider) diff --git a/NEWS.md b/NEWS.md index 891a7de9..e6029f42 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,50 @@ # News neotoma2 R package +## neotoma2 1.1.1 + +* The default request timeout is 125 seconds, just above the 120 seconds at which the API gateway gives up, so the client and the gateway agree and a slow query is reported once instead of being abandoned and repeated. `NEOTOMA_TIMEOUT` and `NEOTOMA_RETRIES` still override both. +* Gentler on the Neotoma API: + * An HTTP 500 is no longer retried (it cannot succeed on a repeat), and a busy + gateway (502, 503, 504) is retried once, after a jittered wait of 30 to 60 + seconds. A `Retry-After` header on a 429 or 503 is honoured. + * Requests identify the package: the User-Agent is now + `neotoma2/ (R )`. Set `options(neotoma2.contact = "you@example.org")` + or the `NEOTOMA_CONTACT` environment variable to add a contact address. + * `get_table()` keeps its answer for the rest of the session (use `refresh = TRUE` + to ask again), and `get_downloads()` requests long vectors of dataset IDs in + batches of 25 and keeps the answers for the session. `options(neotoma2.cache = FALSE)` + turns the cache off. + * `get_downloads()` no longer repeats a failed request with its arguments removed. + * A long list of IDs for `data/taxa`, `data/publications` or other endpoints + without a POST route is now sent as several short `GET` requests, instead of a + `POST` the API answered with a redirect to its documentation. + * A long `get_downloads()` request that used `all_data = TRUE` sent a malformed + list of dataset IDs, which the API rejected with an HTTP 500. + * An answer that is a web page rather than data now raises a clear error. + * A failed request reports the reason the API gives (`The API said: ...`), in + both the current response shape (`data: null`, `message`) and the earlier one + (the error in `data`). +* The development server is now reached over `https`. `http://api-dev...` redirects + to `https`, and the redirect turned a `POST` into a `GET` without its body, so a + spatial (`loc`) query sent with `set_server("dev")` came back as the unfiltered + first page of records. A `POST` now also keeps its method and body through any + redirect. +* Long lists of IDs for `get_sites()`, `get_datasets()` and `get_downloads()` are + sent as `POST` requests in chunks of 100, as the API accepts them there, and a + long list of filter values (for example many taxon names) is sent as a `POST` + body instead of a URL too long to send. An answer that does not match the IDs + asked for raises an error instead of being returned. +* `get_taxa()` was rewritten. `get_taxa()` used to ask for datasets with no + taxon filter at all; `get_taxa(taxa = )` passed a function in place of the names; + `all_data`, `datasettype`, `loc`, `limit` and other arguments were dropped or + ignored. It now forwards them, never requests datasets without a taxon filter, + and warns before sending more than 25 taxon names in one request. +* `get_taxon(taxonname = "Pinus%")` now returns every page of matches (`all_data` + defaults to `TRUE`, as documented) instead of only the first, and a taxon record + without a `taxagroupid` no longer makes it fail. `get_taxon(numeric(0))` returns `NULL`. +* `all_data` is now honoured in `get_datasets()` and `get_downloads()` when called on a + `sites` object; the argument was previously ignored. + ## neotoma2 1.1.0 * Added `count()` to tally sites, collection units, or datasets in a record object. @@ -13,9 +58,6 @@ * A request that times out is retried at most once. Retrying a slow query stacks work onto an API that is already struggling, which made spatial (`loc`) queries worse rather than better; other transient failures still retry as before. -* Raised the default request timeout to 180 seconds, above the observed latency of - the spatial endpoints, so healthy-but-slow queries are no longer aborted - mid-flight. `NEOTOMA_TIMEOUT` and `NEOTOMA_RETRIES` still override both. * A spatial geometry is now converted once per query rather than once per page, and the API's parameter list is fetched once per session rather than on every `get_*()` call. diff --git a/R/parseURL.R b/R/parseURL.R index 51c97d54..f7f8e365 100644 --- a/R/parseURL.R +++ b/R/parseURL.R @@ -13,12 +13,65 @@ neotoma_baseurl <- function(use = "neotoma") { use <- apipoint } switch(use, - "dev" = "http://api-dev.neotomadb.org/v2.0/", + "dev" = "https://api-dev.neotomadb.org/v2.0/", "neotoma" = "https://api.neotomadb.org/v2.0/", "local" = "http://localhost:3001/v2.0/", use) } +#' @title neotoma_cache +#' @description An internal, session-long store for results that are expensive +#' to fetch and do not change while R is running: static database tables +#' (`get_table()`) and dataset downloads (`get_downloads()`). Keeping them here +#' means a script that asks for the same thing twice costs the API one request, +#' not two. It is emptied when R restarts, and with `neotoma_cache_clear()`. +#' Set `options(neotoma2.cache = FALSE)` to switch it off. +#' @noRd +neotoma_cache <- new.env(parent = emptyenv()) + +#' @title neotoma_cache_on +#' @description An internal helper: TRUE unless the user has switched the +#' session cache off with `options(neotoma2.cache = FALSE)`. +#' @returns `logical` +#' @noRd +neotoma_cache_on <- function() { + !identical(getOption("neotoma2.cache", TRUE), FALSE) +} + +#' @title neotoma_cache_clear +#' @description Empties the session cache. +#' @returns `NULL`, invisibly. +#' @noRd +neotoma_cache_clear <- function() { + rm(list = ls(neotoma_cache, all.names = TRUE), envir = neotoma_cache) + invisible(NULL) +} + +#' @title neotoma_user_agent +#' @description An internal helper that builds the User-Agent string: +#' `neotoma2/ (R )`, with `; contact:
` appended when +#' the user has set `options(neotoma2.contact = "name@example.org")` or the +#' `NEOTOMA_CONTACT` environment variable. A self-identifying client is the +#' easiest for the API team to reach if a script misbehaves. The version is +#' looked up once per session. +#' @returns `character` User-Agent value. +#' @noRd +neotoma_user_agent <- function() { + if (is.null(neotoma_cache$user_agent)) { + version <- tryCatch(as.character(utils::packageVersion("neotoma2")), + error = function(e) "unknown") + neotoma_cache$user_agent <- paste0("neotoma2/", version, " (R ", + getRversion()) + } + contact <- getOption("neotoma2.contact", Sys.getenv("NEOTOMA_CONTACT", "")) + if (is.character(contact) && length(contact) == 1 && !is.na(contact) && + nzchar(contact)) { + paste0(neotoma_cache$user_agent, "; contact: ", contact, ")") + } else { + paste0(neotoma_cache$user_agent, ")") + } +} + #' @title neotoma_headers #' @author Socorro Dominguez \email{dominguezvid@wisc.edu} #' @importFrom httr add_headers @@ -28,10 +81,10 @@ neotoma_baseurl <- function(use = "neotoma") { #' @noRd neotoma_headers <- function(json = FALSE) { if (json) { - add_headers("User-Agent" = "neotoma2 R package", + add_headers("User-Agent" = neotoma_user_agent(), "Content-Type" = "application/json") } else { - add_headers("User-Agent" = "neotoma2 R package") + add_headers("User-Agent" = neotoma_user_agent()) } } @@ -83,27 +136,6 @@ is_parsed_location <- function(loc) { is.list(loc) && length(loc) == 1 && inherits(loc[[1]], "json") } -#' @title neotoma_id_param -#' @author Simon Goring \email{goring@wisc.edu} -#' @description An internal helper that names the identifier parameter for a -#' POST-by-id request, based on the endpoint path built by the calling -#' `get_*()` function. -#' @param x The endpoint path (e.g. "data/sites/1,2,3"). -#' @returns `character` name of the id parameter ("siteid", "datasetid", ...). -#' @noRd -neotoma_id_param <- function(x) { - parts <- strsplit(x, "/")[[1]] - base <- sub("\\?.*$", "", paste(parts[seq_len(min(2, length(parts)))], - collapse = "/")) - if (grepl("site", base)) { - "siteid" - } else if (grepl("dataset|download", base)) { - "datasetid" - } else { - parts[length(parts) - 1] - } -} - #' @title neotoma_env_num #' @description An internal helper that reads a positive number from an #' environment variable, falling back to a default when the variable is unset @@ -120,11 +152,96 @@ neotoma_env_num <- function(name, default) { #' @title neotoma_terminal_status #' @description An internal helper listing the HTTP statuses that cannot succeed #' on a retry. A malformed or not-found request will fail the same way every -#' time, so it is raised immediately. +#' time, so it is raised immediately. So does a 500: the API answers 500 for a +#' request it cannot process (for example a malformed id list), which a repeat +#' will not change, while a crash that a retry could outlive surfaces as a +#' gateway status (see `neotoma_busy_status()`). #' @returns `numeric` vector of terminal status codes. #' @noRd neotoma_terminal_status <- function() { - c(400, 401, 403, 404, 405, 410, 422) + c(400, 401, 403, 404, 405, 410, 422, 500) +} + +#' @title neotoma_busy_status +#' @description An internal helper listing the gateway statuses that mean the +#' server is overloaded or restarting (502, 503, 504). The API usually keeps +#' working on a query after the gateway gives up on it, so an immediate repeat +#' only stacks a second heavy query on top of the first. These are retried at +#' most once, after a long wait. +#' @returns `numeric` vector of status codes. +#' @noRd +neotoma_busy_status <- function() { + c(502, 503, 504) +} + +#' @title neotoma_is_busy +#' @description An internal helper that recognises a gateway "server busy" +#' response. +#' @param response The `httr` response or the condition raised by the attempt. +#' @returns `logical` TRUE for a 502, 503 or 504 response. +#' @noRd +neotoma_is_busy <- function(response) { + inherits(response, "response") && + response$status_code %in% neotoma_busy_status() +} + +#' @title neotoma_retry_after +#' @description An internal helper that reads a `Retry-After` header given as a +#' number of seconds. A date, a missing header and a nonsense value all return +#' `NA`. The wait is capped at two minutes so a misconfigured server cannot +#' park a script indefinitely. +#' @param response The `httr` response or the condition raised by the attempt. +#' @returns `numeric` seconds to wait, or `NA`. +#' @noRd +neotoma_retry_after <- function(response) { + if (!inherits(response, "response")) { + return(NA_real_) + } + value <- response$headers[["retry-after"]] + if (is.null(value)) { + return(NA_real_) + } + seconds <- suppressWarnings(as.numeric(value)) + if (length(seconds) != 1 || is.na(seconds) || seconds < 0) { + return(NA_real_) + } + min(seconds, 120) +} + +#' @title neotoma_sleep +#' @description An internal helper that pauses. It exists so that tests can +#' check how long the client would wait without actually waiting. +#' @param seconds Number of seconds to pause. +#' @noRd +neotoma_sleep <- function(seconds) { + Sys.sleep(seconds) +} + +#' @title neotoma_wait +#' @description An internal helper that sleeps between attempts. A `Retry-After` +#' header is honoured as sent. Otherwise a busy gateway (502/503/504) gets a +#' long, jittered wait of 30 to 60 seconds, and any other transient failure an +#' exponential backoff with jitter, so that many clients that failed together +#' do not retry together. Kept as its own function so tests can replace it. +#' @param response The `httr` response or the condition raised by the attempt. +#' @param attempt The number of attempts made so far. +#' @returns The number of seconds slept, invisibly. +#' @noRd +neotoma_wait <- function(response, attempt) { + seconds <- neotoma_retry_after(response) + if (is.na(seconds)) { + seconds <- if (neotoma_is_busy(response)) { + stats::runif(1, 30, 60) + } else { + min(30, 2^attempt) * stats::runif(1, 0.75, 1.25) + } + } + if (neotoma_is_busy(response) || seconds >= 10) { + message("The Neotoma API is busy; waiting ", round(seconds), + " s before trying again.") + } + neotoma_sleep(seconds) + invisible(seconds) } #' @title neotoma_is_timeout @@ -141,7 +258,8 @@ neotoma_is_timeout <- function(response) { #' @title neotoma_should_retry #' @importFrom httr http_error #' @description An internal helper that decides whether an attempt is worth -#' repeating: any error, and any HTTP failure that is not terminal. +#' repeating: a connection error, and an HTTP failure that is not terminal +#' (429 rate limiting and 502/503/504 gateway failures). #' @param response The `httr` response or the condition raised by the attempt. #' @returns `logical` TRUE when another attempt may succeed. #' @noRd @@ -159,22 +277,23 @@ neotoma_should_retry <- function(response) { #' @author Socorro Dominguez \email{dominguezvid@wisc.edu} #' @importFrom httr VERB timeout #' @description An internal helper that issues a request, retrying with -#' exponential backoff when the failure is transient. Slow queries (wildcard -#' site searches, large downloads) intermittently return a gateway timeout from -#' the API, and rate limiting returns a 429; both succeed on a later attempt, so -#' they are retried rather than raised. Client errors (400-level) are returned -#' immediately -- a malformed or not-found request cannot succeed on a retry. +#' a wait when the failure is transient. Rate limiting (429) succeeds on a later +#' attempt, so it is retried, waiting as long as the `Retry-After` header asks. +#' Client errors (400-level) and a 500 are returned immediately -- a malformed +#' or not-found request cannot succeed on a retry. A gateway failure +#' (502/503/504) is retried once, after a long jittered wait (see +#' `neotoma_wait()`). #' #' Every attempt carries a timeout. Without one, a server that accepts the -#' connection and then never responds blocks forever. A timeout is retried at -#' most once, and deliberately not `times` times: the API keeps working on a -#' query we have already abandoned, so a client that retries a slow request -#' stacks concurrent work onto an endpoint that is by definition already -#' struggling. The spatial (`loc`) endpoints are slow enough that this +#' connection and then never responds blocks forever. A timeout, like a gateway +#' failure, is retried at most once, and deliberately not `times` times: the API +#' keeps working on a query we have already abandoned, so a client that retries +#' a slow request stacks concurrent work onto an endpoint that is by definition +#' already struggling. The spatial (`loc`) endpoints are slow enough that this #' matters -- a polygon matching no sites at all still costs tens of seconds -#' server-side -- so the default timeout is set well above their observed -#' latency rather than inside it, where it would abort healthy requests -#' mid-flight. +#' server-side. The default timeout (125 s) sits just above the 120 s at which +#' the API gateway gives up, so the client and the gateway agree and a slow +#' query is reported once rather than abandoned and repeated. #' #' Both bounds can be lowered through `NEOTOMA_TIMEOUT` (seconds per attempt) #' and `NEOTOMA_RETRIES` (attempts), which lets test runs fail fast while @@ -189,19 +308,19 @@ neotoma_should_retry <- function(response) { #' @noRd neotoma_retry <- function(verb, url, ..., times = neotoma_env_num("NEOTOMA_RETRIES", 4), - seconds = neotoma_env_num("NEOTOMA_TIMEOUT", 180)) { + seconds = neotoma_env_num("NEOTOMA_TIMEOUT", 125)) { budget <- max(1, times) attempt <- 1 repeat { response <- tryCatch(VERB(verb, url, ..., timeout(seconds)), error = function(e) e) - if (neotoma_is_timeout(response)) { + if (neotoma_is_timeout(response) || neotoma_is_busy(response)) { budget <- min(budget, 2) } if (attempt >= budget || !neotoma_should_retry(response)) { break } - Sys.sleep(min(30, 2^attempt)) + neotoma_wait(response, attempt) attempt <- attempt + 1 } if (neotoma_is_timeout(response)) { @@ -243,8 +362,8 @@ neotoma_request <- function(expr) { #' @author Socorro Dominguez \email{dominguezvid@wisc.edu} #' @importFrom httr http_error stop_for_status #' @description An internal helper that validates an API response, raising a -#' clear error for a missing response, a rate limit (429), or any other HTTP -#' failure. +#' clear error for a missing response, a rate limit (429), a busy server +#' (502/503/504), or any other HTTP failure. #' @param response The `httr` response to check. #' @returns The `response` invisibly if it is valid. #' @noRd @@ -255,97 +374,221 @@ neotoma_status_check <- function(response) { if (inherits(response, "response") && http_error(response)) { if (response$status_code == 429) { stop("Error 429: Too many requests. Please wait and retry.") + } else if (neotoma_is_busy(response)) { + stop("Error ", response$status_code, ": the Neotoma API is busy or ", + "restarting. Try again later, or reduce the size of the query ", + "(fewer ids, a smaller area, a narrower taxon or name filter).", + call. = FALSE) } else { - stop_for_status(response, - task = "Could not connect to the Neotoma API. - Check that the path is valid, and - check the current status of the - Neotoma API services at - http://data.neotomadb.org") + detail <- neotoma_api_message(response) + tryCatch( + stop_for_status(response, + task = "Could not connect to the Neotoma API. + Check that the path is valid, and + check the current status of the + Neotoma API services at + http://data.neotomadb.org"), + error = function(e) { + stop(conditionMessage(e), + if (!is.na(detail)) paste0("\nThe API said: ", detail), + call. = FALSE) + } + ) } } invisible(response) } +#' @title neotoma_api_message +#' @description An internal helper that reads the reason the API gives for a +#' failed request. The API answers a failure with +#' `{status: "failure", data: null, message: }`. Older versions +#' put the database error in `data` and a generic sentence in `message`, so a +#' string in `data` is preferred when there is one. A body that is not JSON (an +#' HTML error page, an empty gateway reply) gives `NA`. +#' @param response The failed `httr` response. +#' @returns `character` message, or `NA_character_`. +#' @noRd +neotoma_api_message <- function(response) { + parsed <- tryCatch( + fromJSON(content(response, as = "text", encoding = "UTF-8"), + simplifyVector = FALSE), + error = function(e) NULL + ) + if (!is.list(parsed)) { + return(NA_character_) + } + one_string <- function(x) { + is.character(x) && length(x) == 1 && !is.na(x) && nzchar(x) + } + if (one_string(parsed$data)) { + parsed$data + } else if (one_string(parsed$message)) { + parsed$message + } else { + NA_character_ + } +} + #' @title neotoma_content #' @author Socorro Dominguez \email{dominguezvid@wisc.edu} #' @importFrom httr content #' @importFrom jsonlite fromJSON #' @description An internal helper that parses the JSON payload of a response -#' into an R list. +#' into an R list. An HTML body (what the API's catch-all redirect returns) is +#' reported as such, rather than failing inside `fromJSON()`. #' @param response The `httr` response. #' @returns `list` with the parsed API response. #' @noRd neotoma_content <- function(response) { - fromJSON(content(response, as = "text"), - flatten = FALSE, - simplifyVector = FALSE) + text <- content(response, as = "text", encoding = "UTF-8") + if (grepl("^\\s*<", text)) { + stop("The Neotoma API returned a web page instead of data, which usually ", + "means the request was redirected (for example to the API ", + "documentation). Check that the endpoint accepts this kind of ", + "request: ", response$url, call. = FALSE) + } + fromJSON(text, flatten = FALSE, simplifyVector = FALSE) } -#' @title neotoma_post_ids -#' @author Socorro Dominguez \email{dominguezvid@wisc.edu} +#' @title neotoma_get #' @importFrom httr http_error -#' @importFrom stringr str_extract_all -#' @description An internal helper that POSTs a query whose identifier list is -#' too long for a `GET`. When no other query parameters are supplied the ids are -#' chunked (50 per request) and all pages are returned; otherwise a single POST -#' is issued. +#' @description An internal helper that issues one `GET` and returns the parsed +#' body. #' @param baseurl The API base URL. -#' @param x The endpoint path (e.g. "data/sites/1,2,3"). +#' @param x The endpoint path. #' @param query A named list of query parameters. -#' @param chunk Number of ids to request per POST when chunking. -#' @returns `list` with cleaned and parsed data from the HTTP request. +#' @returns `list` with the parsed API response. #' @noRd -neotoma_post_ids <- function(baseurl, x, query, chunk = 50) { - parts <- strsplit(x, "/")[[1]] - base <- sub("\\?.*$", "", paste(parts[seq_len(min(2, length(parts)))], - collapse = "/")) - url <- paste0(baseurl, base) - resource <- neotoma_id_param(x) - value <- parts[length(parts)] - - if (length(query) == 0) { - query$limit <- chunk - ids <- as.numeric(str_extract_all(value, "[0-9.]+")[[1]]) - batches <- split(ids, ceiling(seq_along(ids) / chunk)) - results <- list() - for (batch in batches) { - query[[resource]] <- batch - body <- neotoma_body(query) - response <- neotoma_request(function() { - neotoma_retry("POST", url, body = body, encode = "raw", - neotoma_headers(json = TRUE)) - }) - if (http_error(response)) { - warning("Skipping failed request with status ", response$status_code) - next - } - r <- neotoma_content(response) - if (!is.null(r$data)) { - results <- c(results, r$data) - } - } - return(list(status = 200, data = results, message = "Success")) - } +neotoma_get <- function(baseurl, x, query) { + response <- neotoma_request(function() { + neotoma_retry("GET", paste0(baseurl, x), neotoma_headers(), + query = query) + }) + neotoma_status_check(response) + neotoma_content(response) +} - if (!resource %in% names(query)) { - query[[resource]] <- value - } +#' @title neotoma_post_route +#' @description An internal helper that tells whether the API accepts a `POST` +#' for an endpoint. Only the site, dataset and download queries do (and the +#' `spatial` ones, which this package does not call): a body lets a query carry +#' a long spatial `loc`, a long list of ids or a long list of names that would +#' not fit in a URL. Taxa, publications and contacts have no POST route, and a +#' POST to them is redirected to the API documentation. +#' @param x The endpoint path, with or without a query string. +#' @returns `logical` TRUE when the endpoint accepts a `POST`. +#' @noRd +neotoma_post_route <- function(x) { + path <- sub("\\?.*$", "", x) + grepl("^data/(sites|datasets|downloads)/?$", path) || + grepl("^data/datasets/[^/]+$", path) || + grepl("^data/(sites|geopoliticalunits)/[^/]+/datasets$", path) || + grepl("^data/(datasets|geopoliticalunits|contacts)/[^/]+/sites$", path) +} + +#' @title neotoma_post +#' @importFrom httr config +#' @description An internal helper that issues one `POST`, with the query as a +#' JSON body, and returns the parsed answer. The request keeps its method and +#' body if the server redirects it (`postredir`). Without that, `libcurl` +#' follows a 301 or 302 with a `GET` and drops the body, so the API sees a query +#' with no filter at all and answers with its first page of records, which looks +#' like a valid answer. That is what a `POST` to `http://api-dev...` used to do: +#' the dev server redirects to `https`. +#' @param url The full request URL. +#' @param query A named list of parameters, sent as the JSON body. +#' @returns `list` with the parsed API response. +#' @noRd +neotoma_post <- function(url, query) { body <- neotoma_body(query) response <- neotoma_request(function() { neotoma_retry("POST", url, body = body, encode = "raw", - neotoma_headers(json = TRUE)) + neotoma_headers(json = TRUE), config(postredir = 7)) }) neotoma_status_check(response) neotoma_content(response) } +#' @title neotoma_ids_applied +#' @description An internal helper that checks the answer to a request for a +#' list of ids really came from those ids. A server that ignores the request +#' body answers with its default page of records, which looks like data. The +#' answer is rejected when it holds more records than ids were asked for, or a +#' record whose own id (`siteid`, `datasetid`) is not among them. +#' @param records The `data` element of the answer. +#' @param key The id field to compare, "siteid" or "datasetid". +#' @param ids `character` ids that were requested. +#' @returns `logical` FALSE when the answer cannot have come from the ids. +#' @noRd +neotoma_ids_applied <- function(records, key, ids) { + if (length(records) > length(ids)) { + return(FALSE) + } + found <- unlist(lapply(records, function(r) { + if (is.list(r) && !is.null(r[[key]])) as.character(r[[key]]) else NULL + })) + all(found %in% ids) +} + +#' @title neotoma_get_ids +#' @description An internal helper for an identifier list that is too long for +#' one `GET`. The ids are requested `chunk` at a time, one request after +#' another, and the records are combined. The list may end the path +#' (`data/taxa/1,2,3`) or follow a parameter (`data/downloads?datasetid=1,2,3`); +#' a path that ends in neither is requested as it stands. +#' +#' Where the API has a POST route (sites, datasets and downloads) each chunk is +#' sent as a `POST` whose body holds the ids and the rest of the query. Where it +#' has none (taxa, publications, contacts) each chunk is a `GET`. A chunk that +#' returns more records than the ids it asked for was not filtered by them, so +#' it is reported rather than returned. +#' @param baseurl The API base URL. +#' @param x The endpoint path (e.g. "data/taxa/1,2,3"). +#' @param query A named list of query parameters. +#' @param chunk Number of ids to request at a time. +#' @returns `list` with `status`, the combined `data`, and `message`. +#' @noRd +neotoma_get_ids <- function(baseurl, x, query, chunk = 100) { + if (!grepl("^.*[=/][0-9][0-9,.]*$", x)) { + return(neotoma_get(baseurl, x, query)) + } + prefix <- sub("[0-9][0-9,.]*$", "", x) + endpoint <- sub("(/|\\?[A-Za-z]+=)$", "", prefix) + ids <- strsplit(sub("^.*[=/]", "", x), ",")[[1]] + batches <- split(ids, ceiling(seq_along(ids) / chunk)) + use_post <- neotoma_post_route(endpoint) + id_key <- if (grepl("^data/sites", endpoint)) "siteid" else "datasetid" + results <- list() + for (batch in batches) { + if (use_post) { + query[[id_key]] <- paste(batch, collapse = ",") + r <- neotoma_post(paste0(baseurl, endpoint), query) + if (!neotoma_ids_applied(r$data, id_key, batch)) { + stop("The Neotoma API returned records that do not match the ", + length(batch), " ids requested from ", endpoint, ". The ids ", + "were not applied to the query.", call. = FALSE) + } + } else { + r <- neotoma_get(baseurl, paste0(prefix, paste(batch, collapse = ",")), + query) + } + if (!is.null(r$data)) { + results <- c(results, r$data) + } + } + list(status = 200, data = results, message = "Success") +} + #' @title neotoma_fetch #' @author Socorro Dominguez \email{dominguezvid@wisc.edu} #' @importFrom httr modify_url #' @description An internal helper that performs a single (non-paginated) API -#' request. A `GET` is used for short URLs; a `POST` is used for spatial (`loc`) -#' queries and for URLs long enough to be rejected by the server. +#' request. A `GET` is used unless the query has a spatial `loc`, which is sent +#' as a `POST` body. A URL too long to send is either a long list of ids, +#' which is split into several requests (see `neotoma_get_ids()`), or a long +#' list of filter values. The latter is sent as a `POST` body where the +#' endpoint has a POST route, and otherwise as the `GET` it is. #' @param baseurl The API base URL. #' @param x The endpoint path. #' @param query A named list of query parameters. @@ -355,33 +598,23 @@ neotoma_fetch <- function(baseurl, x, query) { full_url <- modify_url(baseurl, path = file.path("v2.0", x), query = query[setdiff(names(query), "loc")]) - use_loc <- "loc" %in% names(query) - too_long <- nchar(full_url) >= 2000 - - if (!use_loc && !too_long) { - response <- neotoma_request(function() { - neotoma_retry("GET", paste0(baseurl, x), neotoma_headers(), - query = query) - }) - neotoma_status_check(response) - return(neotoma_content(response)) - } - if (use_loc) { - body <- neotoma_body(query) + if ("loc" %in% names(query)) { parts <- strsplit(x, "/")[[1]] url <- paste0(baseurl, paste(parts[seq_len(min(2, length(parts)))], collapse = "/")) - response <- neotoma_request(function() { - neotoma_retry("POST", url, body = body, encode = "raw", - neotoma_headers(json = TRUE)) - }) - neotoma_status_check(response) - return(neotoma_content(response)) + return(neotoma_post(url, query)) } - # URL too long for a GET: POST the identifier list. - neotoma_post_ids(baseurl, x, query) + if (nchar(full_url) >= 2000) { + if (grepl("^.*[=/][0-9][0-9,.]*$", x)) { + return(neotoma_get_ids(baseurl, x, query)) + } + if (neotoma_post_route(x)) { + return(neotoma_post(paste0(baseurl, sub("\\?.*$", "", x)), query)) + } + } + neotoma_get(baseurl, x, query) } #' @title neotoma_paginate @@ -437,6 +670,28 @@ neotoma_paginate <- function(baseurl, x, query, page = 2000) { list(status = 200, data = responses, message = "Success") } +#' @title neotoma_flatten_query +#' @description An internal helper that joins every multi-valued query +#' parameter into one comma-separated value (`datasettype = c("pollen", +#' "macrofossil")` becomes `datasettype=pollen,macrofossil`). A URL query holds +#' one value per parameter, and the API reads such a list with a comma +#' separator. Without this, building the URL stopped with "values must be +#' length 1" for any vector argument, and the `get_*()` function reported it as +#' a failed API call. `loc` is left alone: it is converted to a GeoJSON body +#' by `neotoma_body()`. +#' @param query A named list of query parameters. +#' @returns The `query`, with atomic vectors of length two or more collapsed. +#' @noRd +neotoma_flatten_query <- function(query) { + for (name in setdiff(names(query), "loc")) { + value <- query[[name]] + if (is.atomic(value) && length(value) > 1) { + query[[name]] <- paste(value, collapse = ",") + } + } + query +} + #' @title parseURL #' @author Socorro Dominguez \email{dominguezvid@wisc.edu} #' @author Simon Goring \email{goring@wisc.edu} @@ -456,7 +711,7 @@ neotoma_paginate <- function(baseurl, x, query, page = 2000) { #' @noRd parseURL <- function(x, use = "neotoma", all_data = FALSE, ...) { baseurl <- neotoma_baseurl(use) - query <- list(...) + query <- neotoma_flatten_query(list(...)) if (all_data) { return(neotoma_paginate(baseurl, x, query)) } diff --git a/man/get_datasets.Rd b/man/get_datasets.Rd index a823f465..5e180723 100644 --- a/man/get_datasets.Rd +++ b/man/get_datasets.Rd @@ -53,6 +53,11 @@ a list of \code{site} objects, plus returns all the additional metadata for the datasets at that site. The \code{get_datasets()} command wraps the Neotoma API (\href{https://api.neotomadb.org}{api.neotomadb.org}) call for \code{datasets}. +Some queries are slow for the API however few records they return: a spatial +query (\code{loc}) costs tens of seconds even when it matches no datasets, and a +broad \code{taxa} filter (many names, or a wildcard) can take a minute or more. +Add other filters to narrow a query, test it with a small \code{limit} first, and +avoid running it in a loop. The call itself uses a SQL query which accepts any one of the following parameters: \itemize{ diff --git a/man/get_downloads.Rd b/man/get_downloads.Rd index 7e750bc8..d503ae0d 100644 --- a/man/get_downloads.Rd +++ b/man/get_downloads.Rd @@ -69,6 +69,14 @@ as a vector of dataset IDs. \item \code{all_data} The API only downloads the first 25 records of the query. For the complete records, use \code{all_data=TRUE} } + +Download responses are large, and every request costs the Neotoma API real +work. Pass all the dataset IDs you need to \strong{one} call rather than calling +\code{get_downloads()} in a loop: a long vector is split into batches of 25 +datasets and requested one after another. The answer for a set of IDs is +kept for the rest of the R session, so asking for the same IDs again does +not call the API again. Set \code{options(neotoma2.cache = FALSE)} to turn this +off. } \examples{ \dontrun{ diff --git a/man/get_sites.Rd b/man/get_sites.Rd index 34d375c4..e249aaab 100644 --- a/man/get_sites.Rd +++ b/man/get_sites.Rd @@ -50,6 +50,10 @@ function searches for each site within Neotoma that matches the query parameters, and returns them as a \code{sites} object, a list of \code{site} objects. The \code{get_sites()} command wraps the Neotoma API (\href{https://api.neotomadb.org}{api.neotomadb.org}) call for \code{sites}. +Some queries are slow for the API however few records they return: a spatial +query (\code{loc}) costs tens of seconds even when it matches no sites, and so do +wildcard (\verb{\%}) names and broad \code{taxa} filters. Add other filters to narrow a +query, test it with a small \code{limit} first, and avoid running it in a loop. The call itself uses a SQL query which accepts any one of the following parameters: \itemize{ diff --git a/man/get_table.Rd b/man/get_table.Rd index 66a341ab..6e1e9905 100644 --- a/man/get_table.Rd +++ b/man/get_table.Rd @@ -4,7 +4,7 @@ \alias{get_table} \title{Get table record from Neotoma} \usage{ -get_table(x, limit = 25, offset = 0) +get_table(x, limit = 25, offset = 0, refresh = FALSE) } \arguments{ \item{x}{Table name (consult \url{https://open.neotomadb.org/dbschema/} @@ -13,6 +13,12 @@ for a complete list of table names.} \item{limit}{Default 25 records} \item{offset}{Default 0.} + +\item{refresh}{Default \code{FALSE}. Tables in the Neotoma database change rarely, +so the answer to a query is kept for the rest of the R session and asking +for the same \code{x}, \code{limit} and \code{offset} again does not call the API again. +Use \code{refresh = TRUE} to ask the API again. The session cache can be turned +off with \code{options(neotoma2.cache = FALSE)}.} } \value{ selected \code{table} values from the Database. diff --git a/man/get_taxa.Rd b/man/get_taxa.Rd index 33177ced..64c0ffe1 100644 --- a/man/get_taxa.Rd +++ b/man/get_taxa.Rd @@ -13,25 +13,46 @@ get_taxa(x = NA, ...) \method{get_taxa}{default}(...) } \arguments{ -\item{x}{A \code{taxon} ID to extract site information} +\item{x}{A taxon ID (integer, or a vector of IDs) in Neotoma.} \item{...}{accepted arguments, see details for more information.} } \value{ -A Neotoma2 sites object with datasets with the requested taxa. +A Neotoma2 \code{sites} object holding the datasets with the requested +taxa, or \code{NULL} if no taxon or no dataset was found. } \description{ -a \code{sites} object with sites that contain the requested \code{taxa.} +Find the Neotoma datasets that contain a taxon, and return +them as a \code{sites} object. } \details{ -The \code{get_taxa} function searches for a sites within Neotoma -that contain the requested taxa. -The \code{get_taxa} command wraps the Neotoma API`. -The call itself accepts any one of the following -parameters: +\code{get_taxa()} works in two steps. First it resolves the taxon you supplied +to taxon names, with \code{\link[=get_taxon]{get_taxon()}}. Then it asks Neotoma for the datasets +that contain those names, with \code{\link[=get_datasets]{get_datasets()}}. The second step is the +expensive one: the API can take a minute or more to answer a broad +\verb{taxa=} filter, so a taxon ID, or a name with a wildcard, that stands for +many names produces a slow request. \code{get_taxa()} warns when it is about to +send more than 25 distinct names, and it never sends the dataset request +without a taxon filter: if no taxon is found it returns \code{NULL}. + +The taxon can be given in any one of the following ways: \itemize{ -\item \code{taxonid} The unique taxon ID (integer) in Neotoma. Can be passed as a -vector of site IDs. +\item \code{x} A taxon ID (integer) in Neotoma. Can be passed as a vector of IDs. +\item \code{taxonname} A taxon name, or a partial name using \verb{\%} as a wildcard, +which is resolved with \code{\link[=get_taxon]{get_taxon()}}. +\item \code{taxa} One or more exact taxon names, used as they are. +} + +Any other argument that \code{\link[=get_datasets]{get_datasets()}} accepts (\code{datasettype}, \code{loc}, +\code{ageyoung}, \code{ageold}, \code{limit}, \code{offset}, \code{all_data}, ...) is passed on to +that second step. +} +\examples{ +\dontrun{ +# Datasets containing taxon 1 (Abies), at most five of them: +abies <- get_taxa(1, limit = 5) +# The same, starting from the taxon name: +abies <- get_taxa(taxonname = "Abies", limit = 5) } } \author{ From 0c05b0dac207827b96308074f75d85c8d572c0cb Mon Sep 17 00:00:00 2001 From: Socorro DominguezVidana Date: Wed, 21 Oct 2026 21:01:29 -0700 Subject: [PATCH 5/5] Linter added --- .Rbuildignore | 1 + .lintr | 17 + R/01_classDefinitions.R | 884 +++++++++++++----------- R/02_genericDefinitions.R | 63 +- R/build_chron.R | 34 +- R/build_collunit.R | 14 +- R/build_dataset.R | 38 +- R/build_sample.R | 29 +- R/build_site.R | 22 +- R/build_specimen.R | 50 +- R/build_speleothem.R | 59 +- R/check_contacts.R | 14 +- R/chroncontrols.R | 58 +- R/chronology-methods.R | 280 ++++---- R/clean.R | 26 +- R/cleanNULL.R | 2 +- R/collunits-methods.R | 461 ++++++------ R/contact-methods.R | 207 +++--- R/dataset-methods.R | 306 ++++---- R/filter.R | 123 ++-- R/get_contacts.R | 124 ++-- R/get_datasets.R | 103 +-- R/get_documentation.R | 6 +- R/get_downloads.R | 48 +- R/get_manual.R | 6 +- R/get_params.R | 43 +- R/get_publications.R | 139 ++-- R/get_sites.R | 36 +- R/get_specimens.R | 38 +- R/get_speleothems.R | 8 +- R/get_stats.R | 23 +- R/get_table.R | 2 +- R/get_taxa.R | 21 +- R/get_taxon.R | 53 +- R/getids.r | 38 +- R/group_data.R | 2 +- R/parseLocation.R | 53 +- R/parseURL.R | 125 ++-- R/parse_speleothem.R | 50 +- R/pingNeotoma.r | 20 +- R/plotLeaflet.R | 127 ++-- R/pubAuthors.R | 19 +- R/publication-methods.R | 318 +++++---- R/samples-methods.R | 142 ++-- R/samples.R | 195 +++--- R/set_chronology.R | 8 +- R/set_collunit.R | 6 +- R/set_contact.R | 9 +- R/set_dataset.R | 16 +- R/set_publication.R | 57 +- R/set_sample.R | 10 +- R/set_server.R | 12 +- R/set_site.R | 16 +- R/set_speleothem.R | 4 +- R/site-methods.R | 803 +++++++++++---------- R/speleothem-methods.R | 377 +++++----- R/speleothemdetails.R | 110 +-- R/speleothems.R | 122 ++-- R/subset-methods.R | 273 ++++---- R/taxa.R | 215 +++--- R/taxon-methods.R | 311 +++++---- R/testNull.R | 10 +- R/toWide.R | 50 +- R/use_na.R | 65 +- R/utils-pipe.R | 2 +- man/author_classes.Rd | 4 +- man/clean.Rd | 17 +- man/contacts_classes.Rd | 2 +- man/count.Rd | 9 +- man/filter.Rd | 32 +- man/get_datasets.Rd | 41 +- man/get_documentation.Rd | 2 +- man/get_downloads.Rd | 28 +- man/get_manual.Rd | 2 +- man/get_publications.Rd | 57 +- man/get_sites.Rd | 4 +- man/get_speleothems.Rd | 2 +- man/get_stats.Rd | 13 +- man/get_table.Rd | 2 +- man/plotLeaflet-sites-method.Rd | 15 +- man/publications_classes.Rd | 25 +- man/set_collunit.Rd | 4 +- man/set_contact.Rd | 3 +- man/set_dataset.Rd | 10 +- man/set_sample.Rd | 4 +- man/set_site.Rd | 14 +- man/sub-sub.Rd | 2 +- man/toWide.Rd | 11 +- tests/testthat/setup.R | 21 +- tests/testthat/test_add_chronology.R | 58 +- tests/testthat/test_c.R | 36 +- tests/testthat/test_chroncontrols.R | 36 +- tests/testthat/test_chronologies.R | 40 +- tests/testthat/test_cite_data.R | 50 +- tests/testthat/test_clean.R | 50 +- tests/testthat/test_collunits.R | 34 +- tests/testthat/test_coordinates.R | 24 +- tests/testthat/test_datasets.R | 30 +- tests/testthat/test_doi.R | 81 ++- tests/testthat/test_examples.R | 19 +- tests/testthat/test_filter.R | 420 +++++------ tests/testthat/test_get_contacts.R | 6 +- tests/testthat/test_get_datasets.R | 51 +- tests/testthat/test_get_documentation.R | 5 +- tests/testthat/test_get_downloads.R | 75 +- tests/testthat/test_get_manual.R | 5 +- tests/testthat/test_get_publications.R | 2 +- tests/testthat/test_get_sites.R | 7 +- tests/testthat/test_get_speleothems.R | 8 +- tests/testthat/test_get_stats.R | 12 +- tests/testthat/test_get_table.R | 30 +- tests/testthat/test_get_taxa.R | 72 +- tests/testthat/test_get_taxon.R | 47 +- tests/testthat/test_getids.R | 94 +-- tests/testthat/test_group_data.R | 75 +- tests/testthat/test_length.R | 67 +- tests/testthat/test_parseURL.R | 401 +++++++---- tests/testthat/test_parse_location.R | 4 +- tests/testthat/test_parse_site.R | 44 +- tests/testthat/test_parse_speleothem.R | 47 +- tests/testthat/test_pingNeotoma.R | 14 +- tests/testthat/test_plot.R | 2 +- tests/testthat/test_samples.R | 122 ++-- tests/testthat/test_set_chronology.R | 58 +- tests/testthat/test_set_collunit.R | 45 +- tests/testthat/test_set_contact.R | 14 +- tests/testthat/test_set_dataset.R | 37 +- tests/testthat/test_set_default.R | 2 +- tests/testthat/test_set_publication.R | 30 +- tests/testthat/test_set_sample.R | 26 +- tests/testthat/test_set_server.R | 2 +- tests/testthat/test_set_site.R | 38 +- tests/testthat/test_set_speleothem.R | 44 +- tests/testthat/test_sites.R | 163 ++--- tests/testthat/test_specimens.R | 8 +- tests/testthat/test_speleothems.R | 17 +- tests/testthat/test_summary.R | 33 +- tests/testthat/test_taxa.R | 2 +- tests/testthat/test_toWide.R | 95 +-- vignettes/neotoma2-package.Rmd | 76 +- 140 files changed, 5693 insertions(+), 4292 deletions(-) create mode 100644 .lintr diff --git a/.Rbuildignore b/.Rbuildignore index a2134bbf..3054053f 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -48,3 +48,4 @@ paper.* ^vignettes/images/ ^vignettes/data/ ^data-raw/ +^\.lintr$ diff --git a/.lintr b/.lintr new file mode 100644 index 00000000..93e892a7 --- /dev/null +++ b/.lintr @@ -0,0 +1,17 @@ +exclusions: list( + "tests/testthat/fixtures", + "R/get_sites.R" = list(commented_code_linter = 80), + "R/get_datasets.R" = list(commented_code_linter = 94), + "R/get_downloads.R" = list(commented_code_linter = 76), + "R/cleanNULL.R" = list(object_name_linter = Inf), + "R/parseLocation.R" = list(object_name_linter = Inf), + "R/parseURL.R" = list(object_name_linter = Inf), + "R/pingNeotoma.r" = list(object_name_linter = Inf), + "R/pubAuthors.R" = list(object_name_linter = Inf), + "R/testNull.R" = list(object_name_linter = Inf), + "R/toWide.R" = list(object_name_linter = Inf), + "R/set_contact.R" = list(object_name_linter = Inf), + "R/site-methods.R" = list(object_usage_linter = Inf), + "R/chronology-methods.R" = list(object_usage_linter = Inf), + "data-raw/prepare_vignette_data.R" = list(object_usage_linter = Inf) + ) diff --git a/R/01_classDefinitions.R b/R/01_classDefinitions.R index 9b344215..36e2aca9 100644 --- a/R/01_classDefinitions.R +++ b/R/01_classDefinitions.R @@ -8,57 +8,64 @@ setClassUnion("id", c("character", "integer", "numeric")) #' @description An unordered list of individual S4 `contact` objects. #' @export #' @examples { -#' new("contact", familyname = "Goring", givennames = "Simon J.") +#' new("contact", familyname = "Goring", givennames = "Simon J.") #' } #' @returns object of class `contact` #' @aliases contact-class #' @md #' @export -setClass("contact", - representation(contactid = "id", - familyname = "character", - leadinginitials = "character", - givennames = "character", - contactname = "character", - suffix = "character", - ORCID = "character", - title = "character", - institution = "character", - email = "character", - phone = "character", - contactstatus = "character", - fax = "character", - url = "character", - address = "character", - notes = "character"), - prototype(contactid = NA_integer_, - familyname = NA_character_, - leadinginitials = NA_character_, - givennames = NA_character_, - contactname = NA_character_, - suffix = NA_character_, - ORCID = NA_character_, - title = NA_character_, - institution = NA_character_, - email = NA_character_, - phone = NA_character_, - contactstatus = NA_character_, - fax = NA_character_, - url = NA_character_, - address = NA_character_, - notes = NA_character_)) +setClass( + "contact", + representation( + contactid = "id", + familyname = "character", + leadinginitials = "character", + givennames = "character", + contactname = "character", + suffix = "character", + ORCID = "character", + title = "character", + institution = "character", + email = "character", + phone = "character", + contactstatus = "character", + fax = "character", + url = "character", + address = "character", + notes = "character" + ), + prototype( + contactid = NA_integer_, + familyname = NA_character_, + leadinginitials = NA_character_, + givennames = NA_character_, + contactname = NA_character_, + suffix = NA_character_, + ORCID = NA_character_, + title = NA_character_, + institution = NA_character_, + email = NA_character_, + phone = NA_character_, + contactstatus = NA_character_, + fax = NA_character_, + url = NA_character_, + address = NA_character_, + notes = NA_character_ + ) +) #' @aliases contacts-class #' @rdname contacts_classes #' @export setClass("contacts", - representation(contacts = "list"), - validity = function(object) { - all(map(object@contacts, function(x) { - class(x) == "contact" - }) %>% - unlist()) - }) + representation(contacts = "list"), + validity = function(object) { + all(map(object@contacts, function(x) { + class(x) == "contact" + }) %>% + unlist()) + } +) #' @title An S4 class for the authors of a Neotoma publication. #' @description This class combines the S4 class `contact` with a numeric @@ -67,31 +74,41 @@ setClass("contacts", #' a publication are represented by the `authors` object. #' @importFrom purrr map #' @examples { -#' simon <- new("contact", familyname = "Goring", givennames = "Simon J.") -#' firstauthor <- new("author", author = simon, order = 1) +#' simon <- new("contact", familyname = "Goring", givennames = "Simon J.") +#' firstauthor <- new("author", author = simon, order = 1) #' } #' @returns object of class `author` #' @aliases author-class #' @md #' @name author_classes #' @export -setClass("author", - representation(author = "contact", - order = "numeric"), - prototype(author = new("contact"), - order = NA_integer_)) +setClass( + "author", + representation( + author = "contact", + order = "numeric" + ), + prototype( + author = new("contact"), + order = NA_integer_ + ) +) #' @aliases authors-class #' @rdname author_classes #' @export setClass("authors", - representation(authors = "list"), - validity = function(object) { - all(map(object@authors, - function(x) { - class(x) == "author"}) %>% - unlist()) - }) + representation(authors = "list"), + validity = function(object) { + all(map( + object@authors, + function(x) { + class(x) == "author" + } + ) %>% + unlist()) + } +) #' @title An S4 class for Neotoma `publications`. #' @name publications_classes @@ -100,88 +117,98 @@ setClass("authors", #' This `publications` class allows a single dataset to have one #' or more publication classes associated with it. #' @examples { -#' simon <- new("contact", familyname = "Goring", givennames = "Simon J.") -#' socorro <- new("contact", familyname = "Dominguez", givennames = "Socorro") -#' first_author <- new("author", author = simon, order = 1) -#' second_author <- new("author", author = socorro, order = 2) -#' author_list <- new("authors", authors = list(first_author, second_author)) -#' pub <- new("publication", -#' articletitle = "Top or bottom: Best toast spreading surfaces.", -#' journal = "Peanut Butter Science", -#' year = "2022", -#' volume = "2", -#' author = author_list) -#' } +#' simon <- new("contact", familyname = "Goring", givennames = "Simon J.") +#' socorro <- new("contact", familyname = "Dominguez", givennames = "Socorro") +#' first_author <- new("author", author = simon, order = 1) +#' second_author <- new("author", author = socorro, order = 2) +#' author_list <- new("authors", authors = list(first_author, second_author)) +#' pub <- new("publication", +#' articletitle = "Top or bottom: Best toast spreading surfaces.", +#' journal = "Peanut Butter Science", +#' year = "2022", +#' volume = "2", +#' author = author_list +#' ) +#' } #' @returns object of class `publication` #' @aliases publication-class #' @md #' @export -setClass("publication", - representation(publicationid = "id", - publicationtypeid = "numeric", - publicationtype = "character", - year = "character", - citation = "character", - articletitle = "character", - journal = "character", - volume = "character", - issue = "character", - pages = "character", - citationnumber = "character", - doi = "character", - booktitle = "character", - numvolumes = "character", - edition = "character", - volumetitle = "character", - seriestitle = "character", - seriesvolume = "character", - publisher = "character", - url = "character", - city = "character", - state = "character", - country = "character", - originallanguage = "character", - notes = "character", - author = "authors"), - prototype(publicationid = NA_integer_, - publicationtypeid = NA_integer_, - publicationtype = NA_character_, - year = NA_character_, - citation = NA_character_, - articletitle = NA_character_, - journal = NA_character_, - volume = NA_character_, - issue = NA_character_, - pages = NA_character_, - citationnumber = NA_character_, - doi = NA_character_, - booktitle = NA_character_, - numvolumes = NA_character_, - edition = NA_character_, - volumetitle = NA_character_, - seriestitle = NA_character_, - seriesvolume = NA_character_, - publisher = NA_character_, - url = NA_character_, - city = NA_character_, - state = NA_character_, - country = NA_character_, - originallanguage = NA_character_, - notes = NA_character_, - author = new("authors"))) +setClass( + "publication", + representation( + publicationid = "id", + publicationtypeid = "numeric", + publicationtype = "character", + year = "character", + citation = "character", + articletitle = "character", + journal = "character", + volume = "character", + issue = "character", + pages = "character", + citationnumber = "character", + doi = "character", + booktitle = "character", + numvolumes = "character", + edition = "character", + volumetitle = "character", + seriestitle = "character", + seriesvolume = "character", + publisher = "character", + url = "character", + city = "character", + state = "character", + country = "character", + originallanguage = "character", + notes = "character", + author = "authors" + ), + prototype( + publicationid = NA_integer_, + publicationtypeid = NA_integer_, + publicationtype = NA_character_, + year = NA_character_, + citation = NA_character_, + articletitle = NA_character_, + journal = NA_character_, + volume = NA_character_, + issue = NA_character_, + pages = NA_character_, + citationnumber = NA_character_, + doi = NA_character_, + booktitle = NA_character_, + numvolumes = NA_character_, + edition = NA_character_, + volumetitle = NA_character_, + seriestitle = NA_character_, + seriesvolume = NA_character_, + publisher = NA_character_, + url = NA_character_, + city = NA_character_, + state = NA_character_, + country = NA_character_, + originallanguage = NA_character_, + notes = NA_character_, + author = new("authors") + ) +) #' @aliases publications-class #' @rdname publications_classes #' @export setClass("publications", - representation(publications = "list"), - validity = function(object) { - all(map(object@publications, - function(x) { - class(x) == "publication" - }) %>% - unlist()) - }) + representation(publications = "list"), + validity = function(object) { + all(map( + object@publications, + function(x) { + class(x) == "publication" + } + ) %>% + unlist()) + } +) #' @title S4 class for `chronologies` information #' @name chronologies_classes @@ -193,40 +220,48 @@ setClass("publications", #' @aliases chronology-class #' @md #' @export -setClass("chronology", - representation(chronologyid = "id", - notes = "character", - contact = "ANY", - agemodel = "character", - ageboundolder = "numeric", - ageboundyounger = "numeric", - isdefault = "logical", - dateprepared = "Date", - modelagetype = "character", - chronologyname = "character", - chroncontrols = "ANY"), - prototype(chronologyid = NA_integer_, - notes = NA_character_, - contact = list(), - agemodel = NA_character_, - ageboundolder = NA_integer_, - ageboundyounger = NA_integer_, - isdefault = FALSE, - dateprepared = as.Date(character(1)), - modelagetype = NA_character_, - chronologyname = NA_character_, - chroncontrols = data.frame())) +setClass( + "chronology", + representation( + chronologyid = "id", + notes = "character", + contact = "ANY", + agemodel = "character", + ageboundolder = "numeric", + ageboundyounger = "numeric", + isdefault = "logical", + dateprepared = "Date", + modelagetype = "character", + chronologyname = "character", + chroncontrols = "ANY" + ), + prototype( + chronologyid = NA_integer_, + notes = NA_character_, + contact = list(), + agemodel = NA_character_, + ageboundolder = NA_integer_, + ageboundyounger = NA_integer_, + isdefault = FALSE, + dateprepared = as.Date(character(1)), + modelagetype = NA_character_, + chronologyname = NA_character_, + chroncontrols = data.frame() + ) +) #' @aliases chronologies-class #' @rdname chronologies_classes #' @export setClass("chronologies", - representation(chronologies = "list"), - validity = function(object) { - all(object@chronologies %>% - lapply(class) %>% - unlist(recursive = FALSE) == "chronology") - }) + representation(chronologies = "list"), + validity = function(object) { + classes <- object@chronologies %>% + lapply(class) %>% + unlist(recursive = FALSE) + all(classes == "chronology") + } +) #' @title S4 class for `samples` information #' @name samples_classes @@ -236,33 +271,41 @@ setClass("chronologies", #' @aliases sample-class #' @md #' @export -setClass("sample", - representation(ages = "ANY", - igsn = "character", - datum = "ANY", - depth = "numeric", - sampleid = "id", - thickness = "numeric", - samplename = "character", - sampleanalyst = "ANY", - analysisunitid = "id", - analysisunitname = "character"), - prototype(ages = list(), - igsn = NA_character_, - datum = data.frame(), - depth = NA_integer_, - sampleid = NA_integer_, - thickness = NA_integer_, - samplename = NA_character_, - sampleanalyst = list(), - analysisunitid = NA_integer_, - analysisunitname = NA_character_)) +setClass( + "sample", + representation( + ages = "ANY", + igsn = "character", + datum = "ANY", + depth = "numeric", + sampleid = "id", + thickness = "numeric", + samplename = "character", + sampleanalyst = "ANY", + analysisunitid = "id", + analysisunitname = "character" + ), + prototype( + ages = list(), + igsn = NA_character_, + datum = data.frame(), + depth = NA_integer_, + sampleid = NA_integer_, + thickness = NA_integer_, + samplename = NA_character_, + sampleanalyst = list(), + analysisunitid = NA_integer_, + analysisunitname = NA_character_ + ) +) #' @aliases samples-class #' @rdname samples_classes #' @export -setClass("samples", - representation(samples = "list")) +setClass( + "samples", + representation(samples = "list") +) #' @title S4 class for `repository` information #' @name repositories_classes @@ -272,23 +315,31 @@ setClass("samples", #' @aliases repository-class #' @md #' @export -setClass("repository", - representation(notes = "character", - acronym = "character", - repository = "character", - repositoryid = "id", - repositorynotes = "character"), - prototype(notes = NA_character_, - acronym = NA_character_, - repository = NA_character_, - repositoryid = NA_integer_, - repositorynotes = NA_character_)) +setClass( + "repository", + representation( + notes = "character", + acronym = "character", + repository = "character", + repositoryid = "id", + repositorynotes = "character" + ), + prototype( + notes = NA_character_, + acronym = NA_character_, + repository = NA_character_, + repositoryid = NA_integer_, + repositorynotes = NA_character_ + ) +) #' @aliases repositories-class #' @rdname repositories_classes #' @export -setClass("repositories", - representation(repositories = "list")) +setClass( + "repositories", + representation(repositories = "list") +) #' @title S4 class for `specimens` information #' @name specimens_classes @@ -298,45 +349,53 @@ setClass("repositories", #' @aliases specimen-class #' @md #' @export -setClass("specimen", - representation(datasetid = "id", - sampleid = "id", - specimenid = "numeric", - repository = "repository", - taxonid = "id", - taxonname = "character", - elementtype = "character", - symmetry = "character", - portion = "character", - sex = "character", - domesticstatus = "character", - taphonomictype = "character", - nisp = "numeric", - preservative = "character", - maturity = "character", - samplenotes = "character"), - prototype(datasetid = NA_integer_, - sampleid = NA_integer_, - specimenid = NA_integer_, - repository = NULL, - taxonid = NA_integer_, - taxonname = NA_character_, - elementtype = NA_character_, - symmetry = NA_character_, - portion = NA_character_, - sex = NA_character_, - domesticstatus = NA_character_, - taphonomictype = NA_character_, - nisp = NA_integer_, - preservative = NA_character_, - maturity = NA_character_, - samplenotes = NA_character_)) +setClass( + "specimen", + representation( + datasetid = "id", + sampleid = "id", + specimenid = "numeric", + repository = "repository", + taxonid = "id", + taxonname = "character", + elementtype = "character", + symmetry = "character", + portion = "character", + sex = "character", + domesticstatus = "character", + taphonomictype = "character", + nisp = "numeric", + preservative = "character", + maturity = "character", + samplenotes = "character" + ), + prototype( + datasetid = NA_integer_, + sampleid = NA_integer_, + specimenid = NA_integer_, + repository = NULL, + taxonid = NA_integer_, + taxonname = NA_character_, + elementtype = NA_character_, + symmetry = NA_character_, + portion = NA_character_, + sex = NA_character_, + domesticstatus = NA_character_, + taphonomictype = NA_character_, + nisp = NA_integer_, + preservative = NA_character_, + maturity = NA_character_, + samplenotes = NA_character_ + ) +) #' @aliases specimens-class #' @rdname specimens_classes #' @export -setClass("specimens", - representation(specimens = "list")) +setClass( + "specimens", + representation(specimens = "list") +) setClassUnion("samplesOrNULL", c("samples", "NULL")) setClassUnion("specimensOrNULL", c("specimens", "NULL")) @@ -348,40 +407,47 @@ setClassUnion("specimensOrNULL", c("specimens", "NULL")) #' from the Neotoma Paleoecology Database. #' @export #' @returns object of class `datasets` -setClass("dataset", - representation(datasetid = "id", - database = "character", - doi = "ANY", - recdatecreated = "Date", - datasettype = "character", - datasetname = "character", - age_range_old = "numeric", - age_range_young = "numeric", - age_units = "character", - notes = "character", - pi_list = "ANY", - samples = "samplesOrNULL", - specimens = "specimensOrNULL"), - prototype(datasetid = NA_integer_, - database = NA_character_, - doi = list(), - recdatecreated = as.Date(character(1)), - datasettype = NA_character_, - 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, - specimens = NULL) +setClass( + "dataset", + representation( + datasetid = "id", + database = "character", + doi = "ANY", + recdatecreated = "Date", + datasettype = "character", + datasetname = "character", + age_range_old = "numeric", + age_range_young = "numeric", + age_units = "character", + notes = "character", + pi_list = "ANY", + samples = "samplesOrNULL", + specimens = "specimensOrNULL" + ), + prototype( + datasetid = NA_integer_, + database = NA_character_, + doi = list(), + recdatecreated = as.Date(character(1)), + datasettype = NA_character_, + 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, + specimens = NULL + ) ) #' @aliases datasets-class #' @rdname datasets_classes #' @export -setClass("datasets", - representation(datasets = "list")) +setClass( + "datasets", + representation(datasets = "list") +) #' @title S4 class for `speleothem` information #' @name speleothems_classes @@ -390,56 +456,63 @@ setClass("datasets", #' @aliases speleothem-class #' @md #' @export -setClass("speleothem", - representation(entityid = "numeric", - entityname = "character", - siteid = "numeric", - collectionunitid = "numeric", - dripheight = "numeric", - monitoring = "logical", - geology = "character", - rockage = "character", - speleothemtype = "character", - dripheightunits = "character", - entitycovertype = "character", - entrancedistance = "numeric", - entrancedistanceunits = "character", - landusecovertype = "character", - speleothemdriptype = "character", - landusecoverpercent = "numeric", - vegetationcovertype = "character", - entitycoverthickness = "numeric", - vegetationcoverpercent = "numeric"), - prototype(entityid = NA_integer_, - entityname = NA_character_, - siteid = NA_integer_, - collectionunitid = NA_integer_, - dripheight = NA_integer_, - monitoring = FALSE, - geology = NA_character_, - rockage = NA_character_, - speleothemtype = NA_character_, - dripheightunits = NA_character_, - entitycovertype = NA_character_, - entrancedistance = NA_integer_, - entrancedistanceunits = NA_character_, - landusecovertype = NA_character_, - speleothemdriptype = NA_character_, - landusecoverpercent = NA_integer_, - vegetationcovertype = NA_character_, - entitycoverthickness = NA_integer_, - vegetationcoverpercent = NA_integer_)) +setClass( + "speleothem", + representation( + entityid = "numeric", + entityname = "character", + siteid = "numeric", + collectionunitid = "numeric", + dripheight = "numeric", + monitoring = "logical", + geology = "character", + rockage = "character", + speleothemtype = "character", + dripheightunits = "character", + entitycovertype = "character", + entrancedistance = "numeric", + entrancedistanceunits = "character", + landusecovertype = "character", + speleothemdriptype = "character", + landusecoverpercent = "numeric", + vegetationcovertype = "character", + entitycoverthickness = "numeric", + vegetationcoverpercent = "numeric" + ), + prototype( + entityid = NA_integer_, + entityname = NA_character_, + siteid = NA_integer_, + collectionunitid = NA_integer_, + dripheight = NA_integer_, + monitoring = FALSE, + geology = NA_character_, + rockage = NA_character_, + speleothemtype = NA_character_, + dripheightunits = NA_character_, + entitycovertype = NA_character_, + entrancedistance = NA_integer_, + entrancedistanceunits = NA_character_, + landusecovertype = NA_character_, + speleothemdriptype = NA_character_, + landusecoverpercent = NA_integer_, + vegetationcovertype = NA_character_, + entitycoverthickness = NA_integer_, + vegetationcoverpercent = NA_integer_ + ) +) #' @aliases speleothems-class #' @rdname speleothems_classes #' @export setClass("speleothems", representation(speleothems = "list"), - validity = function(object) { - all(map(object, function(x) { - class(x) == "speleothem" - }) %>% - unlist()) - }) + validity = function(object) { + all(map(object, function(x) { + class(x) == "speleothem" + }) %>% + unlist()) + } +) setClassUnion("datasetsOrNULL", c("datasets", "NULL")) setClassUnion("speleothemsOrNULL", c("speleothems", "NULL")) @@ -453,50 +526,59 @@ setClassUnion("chronologiesOrNULL", c("chronologies", "NULL")) #' @aliases collunit-class #' @md #' @export -setClass("collunit", - representation(collectionunitid = "id", - notes = "character", - handle = "character", - colldate = "Date", - location = "character", - waterdepth = "numeric", - gpslocation = "sf", - collunittype = "character", - collectiondevice = "character", - collectionunitname = "character", - depositionalenvironment = "character", - datasets = "datasetsOrNULL", - chronologies = "chronologiesOrNULL", - defaultchronology = "integer", - speleothems = "speleothemsOrNULL"), - prototype(collectionunitid = NA_integer_, - notes = NA_character_, - handle = NA_character_, - colldate = as.Date(character(1)), - location = NA_character_, - waterdepth = NA_integer_, - gpslocation = sf::st_as_sf(sf::st_sfc()), - collunittype = NA_character_, - collectiondevice = NA_character_, - collectionunitname = NA_character_, - depositionalenvironment = NA_character_, - datasets = NULL, - chronologies = NULL, - defaultchronology = NA_integer_, - speleothems = NULL)) +setClass( + "collunit", + representation( + collectionunitid = "id", + notes = "character", + handle = "character", + colldate = "Date", + location = "character", + waterdepth = "numeric", + gpslocation = "sf", + collunittype = "character", + collectiondevice = "character", + collectionunitname = "character", + depositionalenvironment = "character", + datasets = "datasetsOrNULL", + chronologies = "chronologiesOrNULL", + defaultchronology = "integer", + speleothems = "speleothemsOrNULL" + ), + prototype( + collectionunitid = NA_integer_, + notes = NA_character_, + handle = NA_character_, + colldate = as.Date(character(1)), + location = NA_character_, + waterdepth = NA_integer_, + gpslocation = sf::st_as_sf(sf::st_sfc()), + collunittype = NA_character_, + collectiondevice = NA_character_, + collectionunitname = NA_character_, + depositionalenvironment = NA_character_, + datasets = NULL, + chronologies = NULL, + defaultchronology = NA_integer_, + speleothems = NULL + ) +) #' @aliases collunits-class #' @rdname collunits_classes #' @export setClass("collunits", - representation(collunits = "list"), - validity = function(object) { - all(map(object@collunits, - function(x) { - class(x) == "collunit" - }) %>% - unlist()) - }) + representation(collunits = "list"), + validity = function(object) { + all(map( + object@collunits, + function(x) { + class(x) == "collunit" + } + ) %>% + unlist()) + } +) setClassUnion("collunitsOrNULL", c("collunits", "NULL")) #' @title An S4 class for `sites` information @@ -506,37 +588,44 @@ setClassUnion("collunitsOrNULL", c("collunits", "NULL")) #' @aliases site-class #' @md #' @export -setClass("site", - representation(siteid = "id", - sitename = "character", - geography = "sf", - altitude = "numeric", - geopolitical = "list", - area = "numeric", - notes = "character", - description = "character", - collunits = "collunitsOrNULL"), - prototype(siteid = NA_integer_, - sitename = NA_character_, - geography = sf::st_sf(sf::st_sfc()), - geopolitical = list(), - altitude = NA_integer_, - area = NA_integer_, - notes = NA_character_, - description = NA_character_, - collunits = NULL)) +setClass( + "site", + representation( + siteid = "id", + sitename = "character", + geography = "sf", + altitude = "numeric", + geopolitical = "list", + area = "numeric", + notes = "character", + description = "character", + collunits = "collunitsOrNULL" + ), + prototype( + siteid = NA_integer_, + sitename = NA_character_, + geography = sf::st_sf(sf::st_sfc()), + geopolitical = list(), + altitude = NA_integer_, + area = NA_integer_, + notes = NA_character_, + description = NA_character_, + collunits = NULL + ) +) #' @aliases sites-class #' @rdname sites_classes #' @export setClass("sites", - representation(sites = "list"), - validity = function(object) { - all(map(object@sites, function(x) { - class(x) == "site" - }) %>% - unlist()) - }) + representation(sites = "list"), + validity = function(object) { + all(map(object@sites, function(x) { + class(x) == "site" + }) %>% + unlist()) + } +) #' @title S4 class for taxa information #' @name taxa_classes @@ -545,35 +634,42 @@ setClass("sites", #' @aliases taxon-class #' @md #' @export -setClass("taxon", - representation(taxonid = "numeric", - taxoncode = "character", - taxonname = "character", - author = "character", - ecolgroup = "character", - highertaxonid = "numeric", - status = "character", - taxagroupid = "character", - publicationid = "numeric", - publication = "character"), - prototype(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_)) +setClass( + "taxon", + representation( + taxonid = "numeric", + taxoncode = "character", + taxonname = "character", + author = "character", + ecolgroup = "character", + highertaxonid = "numeric", + status = "character", + taxagroupid = "character", + publicationid = "numeric", + publication = "character" + ), + prototype( + 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_ + ) +) #' @aliases taxa-class #' @rdname taxa_classes #' @export setClass("taxa", representation(taxa = "list"), - validity = function(object) { - all(map(object, function(x) { - class(x) == "taxon" - }) %>% - unlist()) - }) \ No newline at end of file + validity = function(object) { + all(map(object, function(x) { + class(x) == "taxon" + }) %>% + unlist()) + } +) diff --git a/R/02_genericDefinitions.R b/R/02_genericDefinitions.R index 38589773..83eac683 100644 --- a/R/02_genericDefinitions.R +++ b/R/02_genericDefinitions.R @@ -5,10 +5,12 @@ #' @param object A sites object #' @returns datasets object specific to the metadata contained in datasets #' @export -setGeneric("datasets", - function(object) { - standardGeneric(f = "datasets") - }) +setGeneric( + "datasets", + function(object) { + standardGeneric(f = "datasets") + } +) #' @title Obtain coordinates from a sites object. #' @param obj A sites object @@ -48,7 +50,7 @@ setGeneric("showMatch", function(x) { #' @export setGeneric("samples", function(x, chronname = NULL) { standardGeneric(f = "samples") - }) +}) #' @title Obtain speleothems from a record or multiple records. #' @param x sites object @@ -83,7 +85,7 @@ setGeneric("doi", function(x) { }) #' @title Generate a data citation from a Neotoma2 object. -#' @description The function, applied to a data object with a valid dataset, +#' @description The function, applied to a data object with a valid dataset, #' will return a properly formatted data citation for the record. #' @param x Object with DOIs associated to it. #' @returns data.frame with citation data @@ -142,45 +144,56 @@ setGeneric("taxa", function(object) { #' documentation online. #' @md #' @exportMethod add_chronology -setGeneric("add_chronology", - function(object, x, y) { - standardGeneric(f = "add_chronology") - }) +setGeneric( + "add_chronology", + function(object, x, y) { + standardGeneric(f = "add_chronology") + } +) #' @title Extract collection units from a sites object #' @param object A sites object #' @importFrom methods slotNames slot #' @returns collunits detail from a sites object #' @export -setGeneric("collunits", - function(object) { - standardGeneric(f = "collunits") - }) +setGeneric( + "collunits", + function(object) { + standardGeneric(f = "collunits") + } +) #' @title Set the default chronology within a collectionunit. #' @param x A chronologies object. #' @param n The particular chronology to be used as the default. #' @returns sites object with new default chronology #' @export -setGeneric("set_default", - function(x, n) { - standardGeneric(f = "set_default") - }) - -#' @title Count the number of sites, datasets, or collectionunits associated with a site object. +setGeneric( + "set_default", + function(x, n) { + standardGeneric(f = "set_default") + } +) + +#' @title Count the number of sites, datasets, or collectionunits associated +#' with a site object. #' @param x A \code{sites} or \code{site} object. -#' @param level The level at which you want to count. Can be sites, collunits, or datasets. Default is sites. +#' @param level The level at which you want to count. Can be sites, collunits, +#' or datasets. Default is sites. #' @returns A count of the specified level in the object #' @rdname count #' @export -setGeneric("count", function(x, level="sites") - standardGeneric("count")) +setGeneric("count", function(x, level = "sites") { + standardGeneric("count") +}) -#TODO +# TODO # #' @title Obtain specimens from a record or multiple records. # #' @param x sites object # #' @returns data.frame with record information regarding specimens # #' @export # setGeneric("specimens", function(x) { +# nolint start # standardGeneric(f = "specimens") -# }) \ No newline at end of file +# nolint end +# }) diff --git a/R/build_chron.R b/R/build_chron.R index 5bd9cd9f..6de06f5b 100644 --- a/R/build_chron.R +++ b/R/build_chron.R @@ -44,18 +44,24 @@ build_chron <- function(x) { if ("chroncontrolid" %in% names(chron_table)) { chron_table <- chron_table[!is.na(chron_table$chroncontrolid), ] } - chronology <- set_chronology(chronologyid = use_na(ch$chronologyid, "int"), - notes = use_na(meta$notes, "char"), - contact = use_na(meta$contact, "list"), - agemodel = use_na(meta$agemodel, "char"), - ageboundolder = older, - ageboundyounger = younger, - isdefault = use_na(meta$isdefault, "bool"), - dateprepared = use_na(as.Date(meta$dateprepared), - "date"), - modelagetype = use_na(meta$modelagetype, "char"), - chronologyname = use_na(meta$chronologyname, - "char"), - chroncontrols = chron_table) - return(chronology) + chronology <- set_chronology( + chronologyid = use_na(ch$chronologyid, "int"), + notes = use_na(meta$notes, "char"), + contact = use_na(meta$contact, "list"), + agemodel = use_na(meta$agemodel, "char"), + ageboundolder = older, + ageboundyounger = younger, + isdefault = use_na(meta$isdefault, "bool"), + dateprepared = use_na( + as.Date(meta$dateprepared), + "date" + ), + modelagetype = use_na(meta$modelagetype, "char"), + chronologyname = use_na( + meta$chronologyname, + "char" + ), + chroncontrols = chron_table + ) + chronology } diff --git a/R/build_collunit.R b/R/build_collunit.R index 0e0a3495..7df9f6bb 100644 --- a/R/build_collunit.R +++ b/R/build_collunit.R @@ -26,12 +26,16 @@ build_collunits <- function(x) { } cu <- set_collunit( collectionunitid = use_na(x$collectionunitid, "int"), - collunittype = use_na(pick(x, "collectionunittype", "unittype", - "collunittype"), "char"), + collunittype = use_na(pick( + x, "collectionunittype", "unittype", + "collunittype" + ), "char"), handle = use_na(x$handle, "char"), collectiondevice = use_na(x$collectiondevice, "char"), - collectionunitname = use_na(pick(x, "collectionunitname", - "collectionunit"), "char"), + collectionunitname = use_na(pick( + x, "collectionunitname", + "collectionunit" + ), "char"), waterdepth = use_na(x$waterdepth, "int"), colldate = use_na(as.Date(x$colldate), "date"), depositionalenvironment = use_na(x$depositionalenvironment, "char"), @@ -43,5 +47,5 @@ build_collunits <- function(x) { chronologies = testNull(x$chronologies, NULL), speleothems = testNull(x$speleothems, NULL) ) - return(cu) + cu } diff --git a/R/build_dataset.R b/R/build_dataset.R index 97e6b0c6..54403dfc 100644 --- a/R/build_dataset.R +++ b/R/build_dataset.R @@ -23,20 +23,22 @@ build_dataset <- function(x) { pi_list <- map(testNull(x$datasetpi, list()), function(y) { use_na(y$contactname, "char") }) - ds <- set_dataset(datasetid = use_na(x$datasetid, "int"), - database = use_na(x$database, "char"), - doi = list(x$doi), - recdatecreated = use_na(as.Date(x$recdatecreated), "date"), - datasettype = use_na(x$datasettype, "char"), - datasetname = use_na(x$datasetname, "char"), - age_range_old = use_na(agerange$ageold, "int"), - age_range_young = use_na(agerange$ageyoung, "int"), - age_units = use_na(agerange$units, "char"), - notes = use_na(x$datasetnotes, "char"), - pi_list = pi_list, - samples = testNull(x$samples, NULL), - specimens = testNull(x$specimens, NULL)) - return(ds) + ds <- set_dataset( + datasetid = use_na(x$datasetid, "int"), + database = use_na(x$database, "char"), + doi = list(x$doi), + recdatecreated = use_na(as.Date(x$recdatecreated), "date"), + datasettype = use_na(x$datasettype, "char"), + datasetname = use_na(x$datasetname, "char"), + age_range_old = use_na(agerange$ageold, "int"), + age_range_young = use_na(agerange$ageyoung, "int"), + age_units = use_na(agerange$units, "char"), + notes = use_na(x$datasetnotes, "char"), + pi_list = pi_list, + samples = testNull(x$samples, NULL), + specimens = testNull(x$specimens, NULL) + ) + ds } #' @title first_agerange @@ -51,8 +53,10 @@ first_agerange <- function(agerange) { if (is.null(agerange) || length(agerange) == 0) { list(ageold = NA, ageyoung = NA, units = NA) } else { - list(ageold = agerange[[1]]$ageold, - ageyoung = agerange[[1]]$ageyoung, - units = agerange[[1]]$units) + list( + ageold = agerange[[1]]$ageold, + ageyoung = agerange[[1]]$ageyoung, + units = agerange[[1]]$units + ) } } diff --git a/R/build_sample.R b/R/build_sample.R index 0f2f09ab..44342c9a 100644 --- a/R/build_sample.R +++ b/R/build_sample.R @@ -53,19 +53,20 @@ build_sample <- function(x) { df <- records_to_df(x$datum) df_age <- records_to_df(x$ages, tibble = FALSE) analyst_list_helper <- x$sampleanalyst %>% - map(function(y) { - y$contactname - }) + map(function(y) { + y$contactname + }) new_sample <- new("sample", - ages = df_age, - igsn = use_na(x$igsn, "char"), - datum = df, - depth = use_na(x$depth, "int"), - sampleid = use_na(x$sampleid, "int"), - thickness = use_na(x$thickness, "int"), - samplename = use_na(x$samplename, "char"), - sampleanalyst = analyst_list_helper, - analysisunitid = use_na(x$analysisunitid, "int"), - analysisunitname = use_na(x$analysisunitname, "char")) - return(new_sample) + ages = df_age, + igsn = use_na(x$igsn, "char"), + datum = df, + depth = use_na(x$depth, "int"), + sampleid = use_na(x$sampleid, "int"), + thickness = use_na(x$thickness, "int"), + samplename = use_na(x$samplename, "char"), + sampleanalyst = analyst_list_helper, + analysisunitid = use_na(x$analysisunitid, "int"), + analysisunitname = use_na(x$analysisunitname, "char") + ) + new_sample } diff --git a/R/build_site.R b/R/build_site.R index 2b14113d..1859bbf5 100644 --- a/R/build_site.R +++ b/R/build_site.R @@ -23,16 +23,18 @@ build_site <- function(x) { return(NULL) } geography <- use_na(read_geography(x$geography), "sf") - site <- set_site(siteid = use_na(x$siteid, "int"), - sitename = use_na(x$sitename, "char"), - geography = geography, - altitude = use_na(x$altitude, "int"), - geopolitical = use_na(x$geopolitical, "list"), - area = use_na(x$area, "int"), - notes = use_na(pick(x, "sitenotes", "notes"), "char"), - description = use_na(x$sitedescription, "char"), - collunits = x$collunits) - return(site) + site <- set_site( + siteid = use_na(x$siteid, "int"), + sitename = use_na(x$sitename, "char"), + geography = geography, + altitude = use_na(x$altitude, "int"), + geopolitical = use_na(x$geopolitical, "list"), + area = use_na(x$area, "int"), + notes = use_na(pick(x, "sitenotes", "notes"), "char"), + description = use_na(x$sitedescription, "char"), + collunits = x$collunits + ) + site } #' @title read_geography diff --git a/R/build_specimen.R b/R/build_specimen.R index 8bd745c9..55df90f6 100644 --- a/R/build_specimen.R +++ b/R/build_specimen.R @@ -18,27 +18,31 @@ build_specimen <- function(x) { } repo <- x$repository %>% cleanNULL() sp <- new("specimen", - datasetid = use_na(x$datasetid, "int"), - sampleid = use_na(x$sampleid, "int"), - specimenid = use_na(x$specimenid, "int"), - repository = new("repository", - notes = use_na(repo$notes, "char"), - acronym = use_na(repo$acronym, "char"), - repository = use_na(repo$repository, "char"), - repositoryid = use_na(repo$repositoryid, "int"), - repositorynotes = use_na(repo$repositorynotes, - "char")), - taxonid = use_na(x$taxonid, "int"), - taxonname = use_na(x$taxonname, "char"), - elementtype = use_na(x$elementtype, "char"), - symmetry = use_na(x$symmetry, "char"), - portion = use_na(x$portion, "char"), - sex = use_na(x$sex, "char"), - domesticstatus = use_na(x$domesticstatus, "char"), - taphonomictype = use_na(x$taphonomictype, "char"), - nisp = use_na(x$nisp, "int"), - preservative = use_na(x$preservative, "char"), - maturity = use_na(x$maturity, "char"), - samplenotes = use_na(x$samplenotes, "char")) - return(sp) + datasetid = use_na(x$datasetid, "int"), + sampleid = use_na(x$sampleid, "int"), + specimenid = use_na(x$specimenid, "int"), + repository = new("repository", + notes = use_na(repo$notes, "char"), + acronym = use_na(repo$acronym, "char"), + repository = use_na(repo$repository, "char"), + repositoryid = use_na(repo$repositoryid, "int"), + repositorynotes = use_na( + repo$repositorynotes, + "char" + ) + ), + taxonid = use_na(x$taxonid, "int"), + taxonname = use_na(x$taxonname, "char"), + elementtype = use_na(x$elementtype, "char"), + symmetry = use_na(x$symmetry, "char"), + portion = use_na(x$portion, "char"), + sex = use_na(x$sex, "char"), + domesticstatus = use_na(x$domesticstatus, "char"), + taphonomictype = use_na(x$taphonomictype, "char"), + nisp = use_na(x$nisp, "int"), + preservative = use_na(x$preservative, "char"), + maturity = use_na(x$maturity, "char"), + samplenotes = use_na(x$samplenotes, "char") + ) + sp } diff --git a/R/build_speleothem.R b/R/build_speleothem.R index f58f77cf..953cd7c9 100644 --- a/R/build_speleothem.R +++ b/R/build_speleothem.R @@ -16,28 +16,37 @@ build_speleothem <- function(...) { return(NULL) } speleothem <- set_speleothem( - entityid = use_na(args$entityid, "int"), - entityname = use_na(args$entityname, "char"), - siteid = use_na(args$siteid, "int"), - collectionunitid = use_na(args$collectionunitid, "int"), - dripheight = use_na(args$dripheight, "int"), - dripheightunits = use_na(args$dripheightunits, "char"), - monitoring = use_na(args$monitoring, "logic"), - geology = use_na(args$geology, "char"), - rockage = use_na(args$rockage, "char"), - speleothemtype = use_na(args$speleothemtype, "char"), - entitycovertype = use_na(args$entitycovertype, "char"), - entrancedistance = use_na(args$entrancedistance, "int"), - landusecovertype = use_na(args$landusecovertype, "char"), - speleothemdriptype = use_na(args$speleothemdriptype, "char"), - landusecoverpercent = use_na(args$landusecoverpercent, "int"), - vegetationcovertype = use_na(args$vegetationcovertype, - "char"), - entitycoverthickness = use_na(args$entitycoverthickness, - "int"), - entrancedistanceunits = use_na(args$entrancedistanceunits, - "char"), - vegetationcoverpercent = use_na(args$vegetationcoverpercent, - "int")) - return(speleothem) -} \ No newline at end of file + entityid = use_na(args$entityid, "int"), + entityname = use_na(args$entityname, "char"), + siteid = use_na(args$siteid, "int"), + collectionunitid = use_na(args$collectionunitid, "int"), + dripheight = use_na(args$dripheight, "int"), + dripheightunits = use_na(args$dripheightunits, "char"), + monitoring = use_na(args$monitoring, "logic"), + geology = use_na(args$geology, "char"), + rockage = use_na(args$rockage, "char"), + speleothemtype = use_na(args$speleothemtype, "char"), + entitycovertype = use_na(args$entitycovertype, "char"), + entrancedistance = use_na(args$entrancedistance, "int"), + landusecovertype = use_na(args$landusecovertype, "char"), + speleothemdriptype = use_na(args$speleothemdriptype, "char"), + landusecoverpercent = use_na(args$landusecoverpercent, "int"), + vegetationcovertype = use_na( + args$vegetationcovertype, + "char" + ), + entitycoverthickness = use_na( + args$entitycoverthickness, + "int" + ), + entrancedistanceunits = use_na( + args$entrancedistanceunits, + "char" + ), + vegetationcoverpercent = use_na( + args$vegetationcoverpercent, + "int" + ) + ) + speleothem +} diff --git a/R/check_contacts.R b/R/check_contacts.R index a9605718..beb5e6c9 100644 --- a/R/check_contacts.R +++ b/R/check_contacts.R @@ -25,13 +25,17 @@ check_contacts <- function(x, ...) { check_contacts.contacts <- function(x, similarity = 0.5, ...) { checked <- map(x@contacts, function(y) { if (is.na(y@contactid) | !is(y@contactid, "numeric")) { - output <- get_contacts(name = paste0(y@givennames, " ", - y@familyname), - similarity = similarity, ...) + output <- get_contacts( + name = paste0( + y@givennames, " ", + y@familyname + ), + similarity = similarity, ... + ) } else { output <- y } - return(output) + output }) return(checked) -} \ No newline at end of file +} diff --git a/R/chroncontrols.R b/R/chroncontrols.R index e5742104..25a6c67a 100644 --- a/R/chroncontrols.R +++ b/R/chroncontrols.R @@ -9,9 +9,13 @@ #' @returns The data.frame with all-NA control rows removed. #' @noRd drop_empty_controls <- function(df) { - cols <- intersect(c("depth", "thickness", "agelimityounger", "agelimitolder", - "chroncontrolid", "chroncontrolage", "chroncontroltype"), - names(df)) + cols <- intersect( + c( + "depth", "thickness", "agelimityounger", "agelimitolder", + "chroncontrolid", "chroncontrolage", "chroncontroltype" + ), + names(df) + ) if (length(cols) == 0 || nrow(df) == 0) { return(df) } @@ -28,12 +32,13 @@ drop_empty_controls <- function(df) { #' @param x sites object #' @returns data.frame with chronological controls #' @export -setMethod(f = "chroncontrols", +setMethod( + f = "chroncontrols", signature = "sites", definition = function(x) { output <- map(x@sites, function(y) chroncontrols(y)) %>% bind_rows() - return(output) + output } ) @@ -44,7 +49,8 @@ setMethod(f = "chroncontrols", #' @param x site object #' @returns data.frame with chronological controls #' @export -setMethod(f = "chroncontrols", +setMethod( + f = "chroncontrols", signature = "site", definition = function(x) { siteid <- as.data.frame(x)$siteid @@ -58,7 +64,7 @@ setMethod(f = "chroncontrols", } chronset <- chronset %>% select(siteid, everything()) - return(chronset) + chronset } ) @@ -70,21 +76,24 @@ setMethod(f = "chroncontrols", #' @param x chronologies object #' @returns data.frame with chronological controls #' @export -setMethod(f = "chroncontrols", +setMethod( + f = "chroncontrols", signature = "chronologies", definition = function(x) { # Return the full column set rather than the 0x0 frame bind_rows() would # give for an empty list: callers (chroncontrols,site) append to it. if (length(x@chronologies) == 0) { - return(data.frame(chronologyid = integer(), - chronologyname = character(), - depth = numeric(), - thickness = numeric(), - agelimityounger = numeric(), - agelimitolder = numeric(), - chroncontrolid = integer(), - chroncontrolage = numeric(), - chroncontroltype = character())) + return(data.frame( + chronologyid = integer(), + chronologyname = character(), + depth = numeric(), + thickness = numeric(), + agelimityounger = numeric(), + agelimitolder = numeric(), + chroncontrolid = integer(), + chroncontrolage = numeric(), + chroncontroltype = character() + )) } output <- map(x@chronologies, function(y) { # A controls table that has already been through chroncontrols() once -- @@ -95,12 +104,14 @@ setMethod(f = "chroncontrols", controls <- y@chroncontrols labels <- c("siteid", "chronologyid", "chronologyname") controls <- controls[, !names(controls) %in% labels, drop = FALSE] - data.frame(chronologyid = y@chronologyid, - chronologyname = y@chronologyname, - controls) + data.frame( + chronologyid = y@chronologyid, + chronologyname = y@chronologyname, + controls + ) }) %>% bind_rows() - return(drop_empty_controls(output)) + drop_empty_controls(output) } ) @@ -110,9 +121,10 @@ setMethod(f = "chroncontrols", #' @param x chronology object #' @returns data.frame with chronological controls #' @export -setMethod(f = "chroncontrols", +setMethod( + f = "chroncontrols", signature = "chronology", definition = function(x) { - return(drop_empty_controls(x@chroncontrols)) + drop_empty_controls(x@chroncontrols) } ) diff --git a/R/chronology-methods.R b/R/chronology-methods.R index 4e0b41c0..a0f0babc 100644 --- a/R/chronology-methods.R +++ b/R/chronology-methods.R @@ -7,15 +7,17 @@ #' @returns A one-row data.frame. #' @noRd chron_summary_row <- function(x) { - data.frame(chronologyid = x@chronologyid, - chronologyname = x@chronologyname, - agemodel = x@agemodel, - ageboundolder = x@ageboundolder, - ageboundyounger = x@ageboundyounger, - dateprepared = x@dateprepared, - modelagetype = x@modelagetype, - isdefault = x@isdefault, - n_controls = sum(!is.na(x@chroncontrols$chroncontrolid))) + data.frame( + chronologyid = x@chronologyid, + chronologyname = x@chronologyname, + agemodel = x@agemodel, + ageboundolder = x@ageboundolder, + ageboundyounger = x@ageboundyounger, + dateprepared = x@dateprepared, + modelagetype = x@modelagetype, + isdefault = x@isdefault, + n_controls = sum(!is.na(x@chroncontrols$chroncontrolid)) + ) } #' @title Drop chronology rows that carry no information. @@ -27,8 +29,10 @@ chron_summary_row <- function(x) { #' @returns The data.frame with uninformative rows removed. #' @noRd drop_empty_chron_rows <- function(df) { - meta <- c("chronologyname", "agemodel", "ageboundolder", "ageboundyounger", - "dateprepared", "modelagetype", "isdefault") + meta <- c( + "chronologyname", "agemodel", "ageboundolder", "ageboundyounger", + "dateprepared", "modelagetype", "isdefault" + ) empty <- Reduce(`&`, lapply(df[meta], is.na)) & df$n_controls == 0 df[!empty, , drop = FALSE] } @@ -49,120 +53,150 @@ print_chron_summary <- function(df) { #' @aliases show,chronology-method #' @rdname show -setMethod(f = "show", - signature = signature(object = "chronology"), - definition = function(object) { - print_chron_summary(chron_summary_row(object)) - }) +setMethod( + f = "show", + signature = signature(object = "chronology"), + definition = function(object) { + print_chron_summary(chron_summary_row(object)) + } +) #' @aliases show,chronologies-method #' @importFrom purrr map #' @importFrom dplyr bind_rows #' @rdname show -setMethod(f = "show", - signature = signature(object = "chronologies"), - definition = function(object) { - if (length(object@chronologies) == 0) { - cat("No chronology information available.\n") - return(invisible(NULL)) - } - object@chronologies %>% - map(chron_summary_row) %>% - bind_rows() %>% - print_chron_summary() - }) +setMethod( + f = "show", + signature = signature(object = "chronologies"), + definition = function(object) { + if (length(object@chronologies) == 0) { + cat("No chronology information available.\n") + return(invisible(NULL)) + } + object@chronologies %>% + map(chron_summary_row) %>% + bind_rows() %>% + print_chron_summary() + } +) #' @rdname sub-sub #' @aliases [[,chronologies,numeric-method [[,chronologies,numeric,ANY-method -setMethod(f = "[[", - signature = signature(x = "chronologies", i = "numeric"), - definition = function(x, i) { - if (length(i) == 1) { - out <- new("chronology", x@chronologies[[i]]) - } else { - out <- map(i, function(z) { - new("chronology", x@chronologies[[z]]) - }) - out <- new("chronology", chronologies = out) - } - return(out) - }) +setMethod( + f = "[[", + signature = signature(x = "chronologies", i = "numeric"), + definition = function(x, i) { + if (length(i) == 1) { + out <- new("chronology", x@chronologies[[i]]) + } else { + out <- map(i, function(z) { + new("chronology", x@chronologies[[z]]) + }) + out <- new("chronology", chronologies = out) + } + out + } +) #' @rdname cash -setMethod(f = "$", - signature = signature(x = "chronology"), - definition = function(x, name) { - slot(x, name) - }) +setMethod( + f = "$", + signature = signature(x = "chronology"), + definition = function(x, name) { + slot(x, name) + } +) #' @rdname cash -setMethod(f = "$", - signature = signature(x = "chronologies"), - definition = function(x, name) { - x %>% - map(function(y) { - slot(y, name) - }) %>% - unlist() - }) +setMethod( + f = "$", + signature = signature(x = "chronologies"), + definition = function(x, name) { + x %>% + map(function(y) { + slot(y, name) + }) %>% + unlist() + } +) #' @rdname cash-set -setMethod(f = "$<-", - signature = signature(x = "chronology"), - definition = function(x, name, value) { - slot(x, name) <- value - return(x) - }) +setMethod( + f = "$<-", + signature = signature(x = "chronology"), + definition = function(x, name, value) { + slot(x, name) <- value + x + } +) #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature("chronology"), - definition = function(x) { - data.frame(chronologyid = as.character(x@chronologyid), - notes = x@notes, - agemodel = x@agemodel, - ageboundolder = x@ageboundolder, - ageboundyounger = x@ageboundyounger, - isdefault = x@isdefault, - dateprepared = x@dateprepared, - modelagetype = x@modelagetype, - chronologyname = x@chronologyname) - }) +setMethod( + f = "as.data.frame", + signature = signature("chronology"), + definition = function(x) { + data.frame( + chronologyid = as.character(x@chronologyid), + notes = x@notes, + agemodel = x@agemodel, + ageboundolder = x@ageboundolder, + ageboundyounger = x@ageboundyounger, + isdefault = x@isdefault, + dateprepared = x@dateprepared, + modelagetype = x@modelagetype, + chronologyname = x@chronologyname + ) + } +) #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature("chronologies"), - definition = function(x) { - x@chronologies %>% map(as.data.frame) %>% bind_rows() - }) +setMethod( + f = "as.data.frame", + signature = signature("chronologies"), + definition = function(x) { + x@chronologies %>% + map(as.data.frame) %>% + bind_rows() + } +) #' @rdname length -setMethod(f = "length", - signature = signature(x = "chronologies"), - definition = function(x) { - length(x@chronologies) - }) +setMethod( + f = "length", + signature = signature(x = "chronologies"), + definition = function(x) { + length(x@chronologies) + } +) #' @rdname c -setMethod(f = "c", - signature = signature(x = "chronologies"), - definition = function(x, y) { - if ("chronology" %in% class(y)) { - y <- new("chronologies", chronologies = list(y)) - } - tryCatch( - new("chronologies", - chronologies = unlist(c(x@chronologies, - y@chronologies), - recursive = FALSE)), - error = function(e) { - stop("Use `get_downloads()` to fill chronologies details. +setMethod( + f = "c", + signature = signature(x = "chronologies"), + definition = function(x, y) { + if ("chronology" %in% class(y)) { + y <- new("chronologies", chronologies = list(y)) + } + tryCatch( + new("chronologies", + chronologies = unlist( + c( + x@chronologies, + y@chronologies + ), + recursive = FALSE + ) + ), + error = function(e) { + stop("Use `get_downloads()` to fill chronologies details. Current `sites` object comes from `get_sites()` or `get_datasets()` which does not have chronology detail") - }) - }) + } + ) + } +) #' @title Change the default age model for a record. #' @importFrom purrr map @@ -172,26 +206,30 @@ setMethod(f = "c", #' @returns `chronologies` object with a new defaulted `chronology` #' @md #' @export -setMethod(f = "set_default", - signature = signature(x = "chronologies"), - definition = function(x, n) { - assert_that(class(x) == "chronologies") - chron_set <- as.data.frame(x) - assert_that(n %in% chron_set$chronologyid, - msg = "The new default chronology +setMethod( + f = "set_default", + signature = signature(x = "chronologies"), + definition = function(x, n) { + assert_that(class(x) == "chronologies") + chron_set <- as.data.frame(x) + assert_that(n %in% chron_set$chronologyid, + msg = "The new default chronology must be a valid chronologyid - within the chronologies.") - which_replace <- chron_set$chronologyid == n - replacingmodel <- chron_set$modelagetype[which_replace] - chronout <- map(seq_len(length(x)), function(y) { - if (x@chronologies[[y]]$chronologyid == n) { - x@chronologies[[y]]@isdefault <- TRUE - } - if (x@chronologies[[y]]$chronologyid != n & - x@chronologies[[y]]$modelagetype == replacingmodel) { - x@chronologies[[y]]@isdefault <- FALSE - } - return(x@chronologies[[y]]) - }) - return(new("chronologies", chronologies = chronout)) - }) + within the chronologies." + ) + which_replace <- chron_set$chronologyid == n + replacingmodel <- chron_set$modelagetype[which_replace] + chronout <- map(seq_len(length(x)), function(y) { + if (x@chronologies[[y]]$chronologyid == n) { + x@chronologies[[y]]@isdefault <- TRUE + } + other_chron <- x@chronologies[[y]]$chronologyid != n + same_model <- x@chronologies[[y]]$modelagetype == replacingmodel + if (other_chron & same_model) { + x@chronologies[[y]]@isdefault <- FALSE + } + x@chronologies[[y]] + }) + new("chronologies", chronologies = chronout) + } +) diff --git a/R/clean.R b/R/clean.R index 0742dfdf..cbd01da0 100644 --- a/R/clean.R +++ b/R/clean.R @@ -17,13 +17,16 @@ #' So the site is gathered, and the datasets are now part of an #' array of datasets. #' @examples \dontrun{ -#' tryCatch({ -#' alex <- get_sites(sitename = "Alex%") -#' alex2 <- get_sites(24) -#' c <- c(alex, alex2) #uncleaned -#' }, error = function(e) { -#' message("Neotoma server not responding. Try again later.") -#' }) +#' tryCatch( +#' { +#' alex <- get_sites(sitename = "Alex%") +#' alex2 <- get_sites(24) +#' c <- c(alex, alex2) # uncleaned +#' }, +#' error = function(e) { +#' message("Neotoma server not responding. Try again later.") +#' } +#' ) #' } #' @md #' @export @@ -59,9 +62,11 @@ clean.sites <- function(x, verbose = TRUE, ...) { # de-duplicate them (this also merges their datasets). Some instances may # carry no collection units, which is handled gracefully. all_cus <- unlist(lapply(dup_sites, function(s) s@collunits@collunits), - recursive = FALSE) + recursive = FALSE + ) merged@collunits <- clean(new("collunits", collunits = all_cus), - verbose = FALSE) + verbose = FALSE + ) clean_list <- c(clean_list, merged) } return(new("sites", sites = clean_list)) @@ -73,7 +78,6 @@ clean.sites <- function(x, verbose = TRUE, ...) { clean.collunits <- function(x, verbose = TRUE, ...) { cuids <- x$collectionunitid matched <- unique(cuids[duplicated(cuids)]) - non_dupes <- cuids[!duplicated(cuids) & !duplicated(cuids, fromLast = TRUE)] if (length(matched) == 0) { return(x) } else { @@ -95,4 +99,4 @@ clean.collunits <- function(x, verbose = TRUE, ...) { clean.datasets <- function(x, verbose = TRUE, ...) { dsids <- as.data.frame(x)$datasetid return(x[which(!duplicated(dsids))]) -} \ No newline at end of file +} diff --git a/R/cleanNULL.R b/R/cleanNULL.R index 282a844a..01513764 100644 --- a/R/cleanNULL.R +++ b/R/cleanNULL.R @@ -14,4 +14,4 @@ cleanNULL <- function(x) { } else { x } -} \ No newline at end of file +} diff --git a/R/collunits-methods.R b/R/collunits-methods.R index 7d3fd190..31ed2285 100644 --- a/R/collunits-methods.R +++ b/R/collunits-methods.R @@ -3,246 +3,305 @@ setClassUnion("missingOrNULL", c("missing", "NULL")) #' @aliases add_chronology,collunit-method #' @rdname add_chronology -setMethod(f = "add_chronology", - signature = signature(object = "collunit", - x = "chronology", - y = "data.frame"), - definition <- function(object, x, y) { - existingIds <- as.data.frame(object@chronologies)$chronologyid - existinganalysisIds <- map(object@datasets@datasets, - function(x) { - map(x@samples@samples, - function(y) { - y$analysisunitid - }) %>% - unlist() - }) - if (x$chronologyid %in% existingIds) { - stop("There is already a chronology with the same ID as your +setMethod( + f = "add_chronology", + signature = signature( + object = "collunit", + x = "chronology", + y = "data.frame" + ), + definition <- function(object, x, y) { + existing_ids <- as.data.frame(object@chronologies)$chronologyid + existing_analysis_ids <- map( + object@datasets@datasets, + function(x) { + map( + x@samples@samples, + function(y) { + y$analysisunitid + } + ) %>% + unlist() + } + ) + if (x$chronologyid %in% existing_ids) { + stop("There is already a chronology with the same ID as your new chronology. Please change the new chronologyid.") - } - assert_that(all(c("analysisunitid", "age", "agetype", "ageolder", - "ageyounger") %in% colnames(y)), - msg = "The data.frame for sample ages must + } + assert_that( + all(c( + "analysisunitid", "age", "agetype", "ageolder", + "ageyounger" + ) %in% colnames(y)), + msg = "The data.frame for sample ages must contain the columns analysisunitid, - age, agetype, ageolder and ageyounger.") - if (!any(unlist(existinganalysisIds) %in% y$analysisunitid)) { - stop("There is no overlap between the existing analysis units and + age, agetype, ageolder and ageyounger." + ) + if (!any(unlist(existing_analysis_ids) %in% y$analysisunitid)) { + stop("There is no overlap between the existing analysis units and the anaysis units in your new sample ages data.frame.") - } else if (!all(unlist(existinganalysisIds) - %in% y$analysisunitid)) { - warning("Not all of the existing analysis units are - represented in the new sample ages data.frame. + } else if (!all(unlist(existing_analysis_ids) %in% y$analysisunitid)) { + warning("Not all of the existing analysis units are + represented in the new sample ages data.frame. Analysis units without ages will have NA values assigned.") - } - object@datasets@datasets <- - map(object@datasets@datasets, - function(z) { - z@samples@samples <- - map(z@samples@samples, - function(a) { - auid <- a@analysisunitid - if (auid %in% y$analysisunitid) { - sampleagerow <- y %>% - dplyr::filter(.data$analysisunitid == auid) - sample_ages <- - data.frame(age = sampleagerow$age, - agetype = sampleagerow$agetype, - ageolder = sampleagerow$ageolder, - ageyounger = sampleagerow$ageyounger, - chronologyid = x$chronologyid, - chronologyname = - x$chronologyname) - a@ages <- rbind(sample_ages, a@ages) - } - return(a) - }) - return(z) - }) - object@chronologies <- c(object@chronologies, x) - if (x@isdefault == 1) { - object@chronologies <- set_default(object@chronologies, - x$chronologyid) - } - return(object) - }) + } + object@datasets@datasets <- + map( + object@datasets@datasets, + function(z) { + z@samples@samples <- + map( + z@samples@samples, + function(a) { + auid <- a@analysisunitid + if (auid %in% y$analysisunitid) { + sampleagerow <- y %>% + dplyr::filter(.data$analysisunitid == auid) + sample_ages <- + data.frame( + age = sampleagerow$age, + agetype = sampleagerow$agetype, + ageolder = sampleagerow$ageolder, + ageyounger = sampleagerow$ageyounger, + chronologyid = x$chronologyid, + chronologyname = x$chronologyname + ) + a@ages <- rbind(sample_ages, a@ages) + } + a + } + ) + z + } + ) + object@chronologies <- c(object@chronologies, x) + if (x@isdefault == 1) { + object@chronologies <- set_default( + object@chronologies, + x$chronologyid + ) + } + object + } +) #' @aliases show,collunits-method #' @rdname show -setMethod(f = "show", - signature = signature(object = "collunits"), - definition = function(object) { - result <- map(object@collunits, function(x) { - as.data.frame(x) - }) %>% - bind_rows() %>% - print(row.names = FALSE) - }) +setMethod( + f = "show", + signature = signature(object = "collunits"), + definition = function(object) { + map(object@collunits, function(x) { + as.data.frame(x) + }) %>% + bind_rows() %>% + print(row.names = FALSE) + } +) #' @aliases show,collunit-method #' @rdname show -setMethod(f = "show", - signature = signature(object = "collunit"), - definition = function(object) { - result <- as.data.frame(object) - print(result, row.names = FALSE) - }) - -#' @aliases sub,collunits-method [,collunits,numeric-method [,collunits,numeric,ANY-method +setMethod( + f = "show", + signature = signature(object = "collunit"), + definition = function(object) { + result <- as.data.frame(object) + print(result, row.names = FALSE) + } +) + +#' @aliases sub,collunits-method [,collunits,numeric-method +#' [,collunits,numeric,ANY-method #' @rdname sub -setMethod(f = "[", - signature = signature(x = "collunits", i = "numeric"), - definition = function(x, i) { - new("collunits", collunits = x@collunits[i]) - }) +setMethod( + f = "[", + signature = signature(x = "collunits", i = "numeric"), + definition = function(x, i) { + new("collunits", collunits = x@collunits[i]) + } +) -#' @aliases sub-sub,collunits-method [[,collunits,numeric-method [[,collunits,numeric,ANY-method +#' @aliases sub-sub,collunits-method [[,collunits,numeric-method +#' [[,collunits,numeric,ANY-method #' @rdname sub-sub -setMethod(f = "[[", - signature = signature(x = "collunits", i = "numeric"), - definition = function(x, i) { - if (length(i) == 1) { - out <- new("collunit", x@collunits[[i]]) - } else { - out <- map(i, function(z) { - new("collunit", x@collunits[[z]]) - }) - out <- new("collunits", collunits = out) - } - return(out) - }) +setMethod( + f = "[[", + signature = signature(x = "collunits", i = "numeric"), + definition = function(x, i) { + if (length(i) == 1) { + out <- new("collunit", x@collunits[[i]]) + } else { + out <- map(i, function(z) { + new("collunit", x@collunits[[z]]) + }) + out <- new("collunits", collunits = out) + } + out + } +) #' @aliases names,collunit-method #' @rdname names -setMethod(f = "names", - signature = signature(x = "collunit"), - definition = function(x) { - slotNames(x) - }) +setMethod( + f = "names", + signature = signature(x = "collunit"), + definition = function(x) { + slotNames(x) + } +) -#' @aliases sub-subset,collunits-method [[<-,collunits-method [[<-,collunits,ANY,ANY-method +#' @aliases sub-subset,collunits-method [[<-,collunits-method +#' [[<-,collunits,ANY,ANY-method #' @rdname sub-subset -setMethod(f = "[[<-", - signature = signature(x = "collunits"), - definition = function(x, i, value) { - collunitset <- x@collunits - collunitset[[i]] <- value - out <- new("collunits", collunits = collunitset) - return(out) - }) - -#' @aliases subset,collunit-method [<-,collunit,character-method [<-,collunit,character,ANY-method +setMethod( + f = "[[<-", + signature = signature(x = "collunits"), + definition = function(x, i, value) { + collunitset <- x@collunits + collunitset[[i]] <- value + out <- new("collunits", collunits = collunitset) + out + } +) + +#' @aliases subset,collunit-method [<-,collunit,character-method +#' [<-,collunit,character,ANY-method #' @rdname subset -setMethod(f = "[<-", - signature = signature(x = "collunit", i = "character"), - definition = function(x, i, value) { - for (idx in 1:length(i)) { - slot(x, i[idx]) <- value[idx] - } - return(x) - }) - -#' @aliases subset,collunit-method [<-,collunit,numeric-method [<-,collunit,numeric,ANY-method +setMethod( + f = "[<-", + signature = signature(x = "collunit", i = "character"), + definition = function(x, i, value) { + for (idx in seq_along(i)) { + slot(x, i[idx]) <- value[idx] + } + x + } +) + +#' @aliases subset,collunit-method [<-,collunit,numeric-method +#' [<-,collunit,numeric,ANY-method #' @rdname subset -setMethod(f = "[<-", - signature = signature(x = "collunit", i = "numeric"), - definition = function(x, i, value) { - slots <- slotNames(x) - for (idx in seq_along()(i)) { - slot(x, slots[i[idx]]) <- value[idx] - } - return(x) - }) +setMethod( + f = "[<-", + signature = signature(x = "collunit", i = "numeric"), + definition = function(x, i, value) { + slots <- slotNames(x) + for (idx in seq_along()(i)) { + slot(x, slots[i[idx]]) <- value[idx] + } + x + } +) #' @aliases cash-set,collunit-method #' @rdname cash-set -setMethod(f = "$<-", - signature = signature(x = "collunit"), - definition = function(x, name, value) { - slot(x, name) <- value - return(x) - }) +setMethod( + f = "$<-", + signature = signature(x = "collunit"), + definition = function(x, name, value) { + slot(x, name) <- value + x + } +) #' @aliases cash,collunit-method #' @rdname cash -setMethod(f = "$", - signature = signature(x = "collunit"), - definition = function(x, name) { - slot(x, name) - }) +setMethod( + f = "$", + signature = signature(x = "collunit"), + definition = function(x, name) { + slot(x, name) + } +) #' @aliases cash,collunits-method #' @rdname cash -setMethod(f = "$", - signature = signature(x = "collunits"), - definition = function(x, name) { - x %>% - map(function(y) { - slot(y, name) - }) %>% - unlist() - }) +setMethod( + f = "$", + signature = signature(x = "collunits"), + definition = function(x, name) { + x %>% + map(function(y) { + slot(y, name) + }) %>% + unlist() + } +) #' @aliases as.data.frame,collunit-method #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature("collunit"), - definition = function(x) { - data.frame(collectionunitid = x@collectionunitid, - handle = x@handle, - colldate = x@colldate, - location = x@location, - waterdepth = x@waterdepth, - collunittype = x@collunittype, - collectiondevice = x@collectiondevice, - defaultchronology = x@defaultchronology, - collectionunitname = x@collectionunitname, - depositionalenvironment = x@depositionalenvironment) - }) +setMethod( + f = "as.data.frame", + signature = signature("collunit"), + definition = function(x) { + data.frame( + collectionunitid = x@collectionunitid, + handle = x@handle, + colldate = x@colldate, + location = x@location, + waterdepth = x@waterdepth, + collunittype = x@collunittype, + collectiondevice = x@collectiondevice, + defaultchronology = x@defaultchronology, + collectionunitname = x@collectionunitname, + depositionalenvironment = x@depositionalenvironment + ) + } +) #' @aliases as.data.frame,collunits-method #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature("collunits"), - definition = function(x) { - df <- x@collunits %>% map(as.data.frame) %>% bind_rows() - }) +setMethod( + f = "as.data.frame", + signature = signature("collunits"), + definition = function(x) { + x@collunits %>% + map(as.data.frame) %>% + bind_rows() + } +) #' @aliases length,collunits-method #' @rdname length -setMethod(f = "length", - signature = signature(x = "collunits"), - definition = function(x) { - length(x@collunits) - }) +setMethod( + f = "length", + signature = signature(x = "collunits"), + definition = function(x) { + length(x@collunits) + } +) #' @aliases c,collunits-method #' @rdname c -setMethod(f = "c", - signature = signature(x = "collunits"), - definition = function(x, y) { - if (is(y, "collunits")) { - cus_l <- c(x@collunits, - y@collunits) - if (is.null(names(cus_l)) || all(names(cus_l) == "")) { - # Case 1: Remove duplicates by content - cus_l <- cus_l[!duplicated(cus_l)] - } else { - # Case 2: Remove duplicates by name - cus_l <- cus_l[!duplicated(names(cus_l))] - } - cus_l <- unlist(cus_l, recursive = FALSE) - # `unlist()` returns NULL rather than an empty list when there is - # nothing to flatten, and the slot must hold a list. This is - # reached whenever every site in the set has no collection units. - if (is.null(cus_l)) { - cus_l <- list() - } - out <- new("collunits", collunits = cus_l) - } else if (is(y, "collunit")) { - collunitset <- c(x@collunits, y) - out <- new("collunits", collunits = collunitset) - } - return(out) - }) \ No newline at end of file +setMethod( + f = "c", + signature = signature(x = "collunits"), + definition = function(x, y) { + if (is(y, "collunits")) { + cus_l <- c( + x@collunits, + y@collunits + ) + if (is.null(names(cus_l)) || all(names(cus_l) == "")) { + # Case 1: Remove duplicates by content + cus_l <- cus_l[!duplicated(cus_l)] + } else { + # Case 2: Remove duplicates by name + cus_l <- cus_l[!duplicated(names(cus_l))] + } + cus_l <- unlist(cus_l, recursive = FALSE) + # `unlist()` returns NULL rather than an empty list when there is + # nothing to flatten, and the slot must hold a list. This is + # reached whenever every site in the set has no collection units. + if (is.null(cus_l)) { + cus_l <- list() + } + out <- new("collunits", collunits = cus_l) + } else if (is(y, "collunit")) { + collunitset <- c(x@collunits, y) + out <- new("collunits", collunits = collunitset) + } + out + } +) diff --git a/R/contact-methods.R b/R/contact-methods.R index 991b3fd8..37c0c31e 100644 --- a/R/contact-methods.R +++ b/R/contact-methods.R @@ -1,120 +1,151 @@ #' @aliases names,contact-method #' @rdname names -setMethod(f = "names", - signature = signature(x = "contact"), - definition = function(x) { - slotNames(x) - }) +setMethod( + f = "names", + signature = signature(x = "contact"), + definition = function(x) { + slotNames(x) + } +) #' @aliases show,contacts-method #' @rdname show -setMethod(f = "show", - signature = "contacts", - definition = function(object) { - as.data.frame(object) %>% - bind_rows() %>% - print(row.names = FALSE) - }) +setMethod( + f = "show", + signature = "contacts", + definition = function(object) { + as.data.frame(object) %>% + bind_rows() %>% + print(row.names = FALSE) + } +) #' @aliases show,contact-method #' @rdname show -setMethod(f = "show", - signature = "contact", - definition = function(object) { - as.data.frame(object) %>% - print(row.names = FALSE) - }) +setMethod( + f = "show", + signature = "contact", + definition = function(object) { + as.data.frame(object) %>% + print(row.names = FALSE) + } +) -#' @aliases sub-sub,contacts-method [[,contacts,numeric-method [[,contacts,numeric,ANY-method +#' @aliases sub-sub,contacts-method [[,contacts,numeric-method +#' [[,contacts,numeric,ANY-method #' @rdname sub-sub -setMethod(f = "[[", - signature = signature(x = "contacts", i = "numeric"), - definition = function(x, i) { - x@contacts[[i]] - }) +setMethod( + f = "[[", + signature = signature(x = "contacts", i = "numeric"), + definition = function(x, i) { + x@contacts[[i]] + } +) #' @aliases cash,contact-method #' @rdname cash -setMethod(f = "$", - signature = signature(x = "contact"), - definition = function(x, name) { - slot(x, name) - }) +setMethod( + f = "$", + signature = signature(x = "contact"), + definition = function(x, name) { + slot(x, name) + } +) #' @aliases cash,contacts-method #' @rdname cash -setMethod(f = "$", - signature = signature(x = "contacts"), - definition = function(x, name) { - x %>% - map(function(y) { - slot(y, name) - }) %>% - unlist() - }) +setMethod( + f = "$", + signature = signature(x = "contacts"), + definition = function(x, name) { + x %>% + map(function(y) { + slot(y, name) + }) %>% + unlist() + } +) #' @aliases as.data.frame,contact-method #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature("contact"), - definition = function(x) { - data.frame(contactid = testNull(x@contactid), - familyname = testNull(x@familyname), - givennames = testNull(x@givennames), - contactname = testNull(x@contactname), - ORCID = testNull(x@ORCID), - url = testNull(x@url), - contactstatus = testNull(x@contactstatus), - notes = testNull(x@notes)) - }) +setMethod( + f = "as.data.frame", + signature = signature("contact"), + definition = function(x) { + data.frame( + contactid = testNull(x@contactid), + familyname = testNull(x@familyname), + givennames = testNull(x@givennames), + contactname = testNull(x@contactname), + ORCID = testNull(x@ORCID), + url = testNull(x@url), + contactstatus = testNull(x@contactstatus), + notes = testNull(x@notes) + ) + } +) #' @aliases as.data.frame,contacts-method #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature("contacts"), - definition = function(x) { - x@contacts %>% - map(as.data.frame) %>% - bind_rows() - }) +setMethod( + f = "as.data.frame", + signature = signature("contacts"), + definition = function(x) { + x@contacts %>% + map(as.data.frame) %>% + bind_rows() + } +) #' @aliases length,contacts-method #' @rdname length -setMethod(f = "length", - signature = signature(x = "contacts"), - definition = function(x) { - length(x@contacts) - }) +setMethod( + f = "length", + signature = signature(x = "contacts"), + definition = function(x) { + length(x@contacts) + } +) #' @aliases c,contacts-method #' @rdname c -setMethod(f = "c", - signature = signature(x = "contacts"), - definition = function(x, y) { - if (is(y, "contacts")) { - out <- new("contacts", - contacts = unlist(c(x@contacts, - y@contacts), - recursive = FALSE)) - } else if (is(y, "contact")) { - contactset <- c(x@contacts, y) - out <- new("contacts", contacts = contactset) - } - return(out) - }) +setMethod( + f = "c", + signature = signature(x = "contacts"), + definition = function(x, y) { + if (is(y, "contacts")) { + out <- new("contacts", + contacts = unlist( + c( + x@contacts, + y@contacts + ), + recursive = FALSE + ) + ) + } else if (is(y, "contact")) { + contactset <- c(x@contacts, y) + out <- new("contacts", contacts = contactset) + } + out + } +) #' @aliases c,contact-method #' @rdname c -setMethod(f = "c", - signature = signature(x = "contact"), - definition = function(x, y) { - if (is(y, "contact")) { - out <- new("contacts", - contacts = list(x, y)) - } else if (is(y, "contacts")) { - contactset <- c(x@contacts, y) - out <- new("contacts", contacts = contactset) - } - return(out) - }) \ No newline at end of file +setMethod( + f = "c", + signature = signature(x = "contact"), + definition = function(x, y) { + if (is(y, "contact")) { + out <- new("contacts", + contacts = list(x, y) + ) + } else if (is(y, "contacts")) { + contactset <- c(x@contacts, y) + out <- new("contacts", contacts = contactset) + } + out + } +) diff --git a/R/dataset-methods.R b/R/dataset-methods.R index 8d97a9f5..95d06d55 100644 --- a/R/dataset-methods.R +++ b/R/dataset-methods.R @@ -1,169 +1,215 @@ #' @aliases show,dataset-method #' @rdname show -setMethod(f = "show", - signature = "dataset", - definition = function(object) { - print(data.frame(datasetid = object@datasetid, - database = object@database, - datasettype = object@datasettype, - age_range_old = object@age_range_old, - age_range_young = object@age_range_young, - age_units = object@age_units, - recdatecreated = object@recdatecreated, - notes = object@notes), row.names = FALSE) - }) +setMethod( + f = "show", + signature = "dataset", + definition = function(object) { + print(data.frame( + datasetid = object@datasetid, + database = object@database, + datasettype = object@datasettype, + age_range_old = object@age_range_old, + age_range_young = object@age_range_young, + age_units = object@age_units, + recdatecreated = object@recdatecreated, + notes = object@notes + ), row.names = FALSE) + } +) #' @aliases show,datasets-method #' @rdname show -setMethod(f = "show", - signature = "datasets", - definition = function(object) { - map(object@datasets, function(y) { - data.frame(datasetid = y@datasetid, - database = y@database, - datasettype = y@datasettype, - age_range_old = y@age_range_old, - age_range_young = y@age_range_young, - age_units = y@age_units, - recdatecreated = y@recdatecreated, - notes = y@notes) - }) %>% - bind_rows() %>% - print(row.names = FALSE) - }) +setMethod( + f = "show", + signature = "datasets", + definition = function(object) { + map(object@datasets, function(y) { + data.frame( + datasetid = y@datasetid, + database = y@database, + datasettype = y@datasettype, + age_range_old = y@age_range_old, + age_range_young = y@age_range_young, + age_units = y@age_units, + recdatecreated = y@recdatecreated, + notes = y@notes + ) + }) %>% + bind_rows() %>% + print(row.names = FALSE) + } +) -#' @aliases sub-sub,datasets-method [[,datasets,numeric-method [[,datasets,numeric,ANY-method +#' @aliases sub-sub,datasets-method [[,datasets,numeric-method +#' [[,datasets,numeric,ANY-method #' @rdname sub-sub -setMethod(f = "[[", - signature = signature(x = "datasets", i = "numeric"), - definition = function(x, i) { - if (length(i) == 1) { - out <- new("dataset", x@datasets[[i]]) - } else { - out <- map(i, function(z) { - new("dataset", x@datasets[[z]]) - }) - out <- new("datasets", datasets = out) - } - return(out) - }) +setMethod( + f = "[[", + signature = signature(x = "datasets", i = "numeric"), + definition = function(x, i) { + if (length(i) == 1) { + out <- new("dataset", x@datasets[[i]]) + } else { + out <- map(i, function(z) { + new("dataset", x@datasets[[z]]) + }) + out <- new("datasets", datasets = out) + } + out + } +) #' @aliases names,dataset-method #' @rdname names -setMethod(f = "names", - signature = signature(x = "dataset"), - definition = function(x) { - slotNames(x) - }) +setMethod( + f = "names", + signature = signature(x = "dataset"), + definition = function(x) { + slotNames(x) + } +) -#' @aliases sub-subset,datasets-method [[<-,datasets-method [[<-,datasets,ANY,ANY-method +#' @aliases sub-subset,datasets-method [[<-,datasets-method +#' [[<-,datasets,ANY,ANY-method #' @rdname sub-subset -setMethod(f = "[[<-", - signature = signature(x = "datasets"), - definition = function(x, i, value) { - datasetset <- x@datasets - datasetset[[i]] <- value - out <- new("datasets", datasets = datasetset) - return(out) - }) +setMethod( + f = "[[<-", + signature = signature(x = "datasets"), + definition = function(x, i, value) { + datasetset <- x@datasets + datasetset[[i]] <- value + out <- new("datasets", datasets = datasetset) + out + } +) -#' @aliases subset,dataset-method [<-,dataset,character-method [<-,dataset,character,ANY-method +#' @aliases subset,dataset-method [<-,dataset,character-method +#' [<-,dataset,character,ANY-method #' @rdname subset -setMethod(f = "[<-", - signature = signature(x = "dataset", i = "character"), - definition = function(x, i, value) { - for (idx in 1:length(i)) { - slot(x, i[idx]) <- value[idx] - } - return(x) - }) +setMethod( + f = "[<-", + signature = signature(x = "dataset", i = "character"), + definition = function(x, i, value) { + for (idx in seq_along(i)) { + slot(x, i[idx]) <- value[idx] + } + x + } +) -#' @aliases subset,dataset-method [<-,dataset,numeric-method [<-,dataset,numeric,ANY-method +#' @aliases subset,dataset-method [<-,dataset,numeric-method +#' [<-,dataset,numeric,ANY-method #' @rdname subset -setMethod(f = "[<-", - signature = signature(x = "dataset", i = "numeric"), - definition = function(x, i, value) { - slots <- slotNames(x) - for (idx in 1:length(i)) { - slot(x, slots[i[idx]]) <- value[idx] - } - return(x) - }) +setMethod( + f = "[<-", + signature = signature(x = "dataset", i = "numeric"), + definition = function(x, i, value) { + slots <- slotNames(x) + for (idx in seq_along(i)) { + slot(x, slots[i[idx]]) <- value[idx] + } + x + } +) #' @aliases cash-set,dataset-method #' @rdname cash-set -setMethod(f = "$<-", - signature = signature(x = "dataset"), - definition = function(x, name, value) { - slot(x, name) <- value - return(x) - }) +setMethod( + f = "$<-", + signature = signature(x = "dataset"), + definition = function(x, name, value) { + slot(x, name) <- value + x + } +) -#' @aliases sub,datasets-method [,datasets,numeric-method [,datasets,numeric,ANY-method +#' @aliases sub,datasets-method [,datasets,numeric-method +#' [,datasets,numeric,ANY-method #' @rdname sub -setMethod(f = "[", - signature = signature(x = "datasets", i = "numeric"), - definition = function(x, i) { - new("datasets", datasets = x@datasets[i]) - }) +setMethod( + f = "[", + signature = signature(x = "datasets", i = "numeric"), + definition = function(x, i) { + new("datasets", datasets = x@datasets[i]) + } +) #' @aliases cash,dataset-method #' @rdname cash -setMethod(f = "$", - signature = signature(x = "dataset"), - definition = function(x, name) { - slot(x, name) - }) +setMethod( + f = "$", + signature = signature(x = "dataset"), + definition = function(x, name) { + slot(x, name) + } +) #' @aliases cash,datasets-method #' @rdname cash -setMethod(f = "$", - signature = signature(x = "datasets"), - definition = function(x, name) { - x %>% - map(function(y) { - slot(y, name) - }) %>% - unlist() - }) +setMethod( + f = "$", + signature = signature(x = "datasets"), + definition = function(x, name) { + x %>% + map(function(y) { + slot(y, name) + }) %>% + unlist() + } +) #' @aliases as.data.frame,dataset-method #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature("dataset"), - definition = function(x) { - data.frame(datasetid = x@datasetid, - database = x@database, - datasettype = x@datasettype, - age_range_old = x@age_range_old, - age_range_young = x@age_range_young, - age_units = x@age_units, - recdatecreated = x@recdatecreated, - notes = x@notes) - }) +setMethod( + f = "as.data.frame", + signature = signature("dataset"), + definition = function(x) { + data.frame( + datasetid = x@datasetid, + database = x@database, + datasettype = x@datasettype, + age_range_old = x@age_range_old, + age_range_young = x@age_range_young, + age_units = x@age_units, + recdatecreated = x@recdatecreated, + notes = x@notes + ) + } +) #' @aliases as.data.frame,datasets-method #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature("datasets"), - definition = function(x) { - x@datasets %>% map(as.data.frame) %>% bind_rows() - }) +setMethod( + f = "as.data.frame", + signature = signature("datasets"), + definition = function(x) { + x@datasets %>% + map(as.data.frame) %>% + bind_rows() + } +) #' @aliases length,datasets-method #' @rdname length -setMethod(f = "length", - signature = signature(x = "datasets"), - definition = function(x) { - length(x@datasets) - }) +setMethod( + f = "length", + signature = signature(x = "datasets"), + definition = function(x) { + length(x@datasets) + } +) #' @aliases c,datasets-method #' @rdname c -setMethod(f = "c", - signature = signature(x = "datasets"), - definition = function(x, y) { - new("datasets", - datasets = unlist(c(x@datasets, - y@datasets), recursive = FALSE)) - }) \ No newline at end of file +setMethod( + f = "c", + signature = signature(x = "datasets"), + definition = function(x, y) { + new("datasets", + datasets = unlist(c( + x@datasets, + y@datasets + ), recursive = FALSE) + ) + } +) diff --git a/R/filter.R b/R/filter.R index 6c93b9a3..b76d2ed8 100644 --- a/R/filter.R +++ b/R/filter.R @@ -59,21 +59,27 @@ #' @returns filtered `sites` object #' @examples \dontrun{ #' # Download 10 sites, but only keep the sites that are close to sea level. -#' tryCatch({ -#' some_sites <- get_sites(sitename = "Lake%", limit = 3) -#' site_subset <- some_sites %>% filter(altitude < 100) -#' }, error = function(e) { -#' message("Neotoma server not responding. Try again later.") -#' }) +#' tryCatch( +#' { +#' some_sites <- get_sites(sitename = "Lake%", limit = 3) +#' site_subset <- some_sites %>% filter(altitude < 100) +#' }, +#' error = function(e) { +#' message("Neotoma server not responding. Try again later.") +#' } +#' ) #' # Download 10 sites, get all associated datasets, but keep only #' # sites/datasets that are of datasettype "pollen": -#' tryCatch({ -#' sites <- get_sites(limit = 10) %>% -#' get_datasets() -#' pollen_subset <- sites %>% filter(datasettype == "pollen") -#' }, error = function(e) { -#' message("Neotoma server not responding. Try again later.") -#' }) +#' tryCatch( +#' { +#' sites <- get_sites(limit = 10) %>% +#' get_datasets() +#' pollen_subset <- sites %>% filter(datasettype == "pollen") +#' }, +#' error = function(e) { +#' message("Neotoma server not responding. Try again later.") +#' } +#' ) #' } #' @md #' @export @@ -85,7 +91,7 @@ filter <- function(.data, ..., .by = NULL, .preserve = FALSE) { #' @exportS3Method filter NULL filter.NULL <- function(.data, ...) { warning("No sites to filter") - return(NULL) + NULL } #' @rdname filter @@ -103,9 +109,11 @@ filter.sites <- function(.data, ...) { # slot the filter actually acts on), so `filter(geography == poly)` behaves # exactly like `filter(loc == poly)`. spatial_keywords <- c("loc", "geography") - is_loc <- vapply(exprs, - function(e) any(spatial_keywords %in% all.vars(e)), - logical(1)) + is_loc <- vapply( + exprs, + function(e) any(spatial_keywords %in% all.vars(e)), + logical(1) + ) loc_quos <- quosures[is_loc] other_quos <- quosures[!is_loc] # Collect the referenced column names from ALL ordinary conditions, not just @@ -114,15 +122,19 @@ filter.sites <- function(.data, ...) { # deparsed text (which would false-match on things like "lat" in "latitude" # or "long" inside a string literal such as "LONGCORE"). referenced_vars <- unique(unlist(lapply(exprs[!is_loc], all.vars))) - sitecols <- any(c("sitename", "lat", "long", "altitude") %in% - referenced_vars) - datasetcols <- any(c("datasetid", "database", "datasettype", "age_range_old", - "age_range_young", "notes") %in% referenced_vars) - collunitcols <- any(c("collectionunitid", "handle", "colldate", - "location", "waterdepth", "collunittype", - "collectiondevice", "defaultchronology", - "collectionunitname", "depositionalenvironment") %in% - referenced_vars) + site_vars <- c("sitename", "lat", "long", "altitude") + sitecols <- any(site_vars %in% referenced_vars) + datasetcols <- any(c( + "datasetid", "database", "datasettype", "age_range_old", + "age_range_young", "notes" + ) %in% referenced_vars) + collunitcols <- any(c( + "collectionunitid", "handle", "colldate", + "location", "waterdepth", "collunittype", + "collectiondevice", "defaultchronology", + "collectionunitname", "depositionalenvironment" + ) %in% + referenced_vars) ids <- getids(x) if (length(loc_quos) > 0) { inside_ids <- loc_site_ids(x, loc_quos) @@ -131,19 +143,25 @@ filter.sites <- function(.data, ...) { if (sitecols == TRUE) { ids <- ids %>% inner_join(as.data.frame(x), by = "siteid") %>% - rename(altitude = .data$elev, - sitenotes = .data$notes) + rename( + altitude = .data$elev, + sitenotes = .data$notes + ) } if (collunitcols == TRUE) { ids <- ids %>% inner_join(as.data.frame(collunits(x)), - by = c("collunitid" = "collectionunitid")) + by = c("collunitid" = "collectionunitid") + ) } if (datasetcols == TRUE) { ids <- ids %>% - inner_join(mutate(as.data.frame(datasets(x)), - datasetid = as.numeric(.data$datasetid)), - by = "datasetid") + inner_join( + mutate(as.data.frame(datasets(x)), + datasetid = as.numeric(.data$datasetid) + ), + by = "datasetid" + ) } cleanids <- ids %>% dplyr::filter(!!!other_quos) @@ -162,12 +180,12 @@ filter.sites <- function(.data, ...) { yds <- datasets(y) yds <- yds[which(as.data.frame(yds)$datasetid %in% good_dsid)] y@datasets <- yds - return(y) + y }) x@collunits@collunits <- xcu - return(x) + x }) - return(new("sites", sites = pared_ds)) + new("sites", sites = pared_ds) } #' @title loc_region @@ -196,13 +214,19 @@ loc_region <- function(region) { if (length(stats::na.omit(region)) != 4) { stop("A numeric `loc` needs 4 values: c(xmin, ymin, xmax, ymax).") } - bbox <- sf::st_bbox(c(xmin = region[1], ymin = region[2], - xmax = region[3], ymax = region[4]), - crs = sf::st_crs(4326)) + bbox <- sf::st_bbox( + c( + xmin = region[1], ymin = region[2], + xmax = region[3], ymax = region[4] + ), + crs = sf::st_crs(4326) + ) geom <- sf::st_as_sfc(bbox) } else { - stop("`loc` must be an sf/sfc/sfg object, a GeoJSON string, or a ", - "numeric bounding box c(xmin, ymin, xmax, ymax).") + stop( + "`loc` must be an sf/sfc/sfg object, a GeoJSON string, or a ", + "numeric bounding box c(xmin, ymin, xmax, ymax)." + ) } if (is.na(sf::st_crs(geom))) { sf::st_crs(geom) <- 4326 @@ -226,12 +250,14 @@ loc_site_ids <- function(x, loc_quos) { e <- rlang::quo_get_expr(q) env <- rlang::quo_get_env(q) operands <- as.list(e)[-1L] - keep <- !vapply(operands, - function(o) { - is.name(o) && - as.character(o) %in% c("loc", "geography") - }, - logical(1)) + keep <- !vapply( + operands, + function(o) { + is.name(o) && + as.character(o) %in% c("loc", "geography") + }, + logical(1) + ) region_expr <- operands[keep][[1]] loc_region(rlang::eval_tidy(rlang::new_quosure(region_expr, env))) }) @@ -257,5 +283,6 @@ loc_site_ids <- function(x, loc_quos) { #' @rdname filter #' @exportS3Method filter data.frame filter.data.frame <- getS3method("filter", - "data.frame", - envir = asNamespace("dplyr")) \ No newline at end of file + "data.frame", + envir = asNamespace("dplyr") +) diff --git a/R/get_contacts.R b/R/get_contacts.R index d42e1f1a..d0c3ecc4 100644 --- a/R/get_contacts.R +++ b/R/get_contacts.R @@ -33,49 +33,56 @@ get_contacts.numeric <- function(x, ...) { if (length(x) > 0) { contactname <- paste0(x, collapse = ",") } - baseURL <- paste0("data/contacts/", contactname) + base_url <- paste0("data/contacts/", contactname) result <- tryCatch( - parseURL(baseURL, ...), + parseURL(base_url, ...), error = function(e) { stop("API call failed: ", e$message) NULL } ) result <- result %>% cleanNULL() - contact <- map(result$data, - function(x) { - x[is.null(x)] <- NA_character_ - new("contact", - contactid = use_na(x$contactid, "int"), - familyname = use_na(x$familyname, "char"), - leadinginitials = use_na(x$leadinginitials, - "char"), - givennames = use_na(x$givennames, "char"), - contactname = use_na(x$contactname, "char"), - suffix = use_na(x$suffix, "char"), - ORCID = use_na(x$ORCID, "char"), - title = use_na(x$title, "char"), - institution = use_na(x$institution, "char"), - email = use_na(x$email, "char"), - phone = use_na(x$phone, "char"), - contactstatus = use_na(x$contactstatus, - "char"), - fax = use_na(x$fax, "char"), - url = use_na(x$url, "char"), - address = use_na(x$address, "char"), - notes = use_na(x$notes, "char")) - }) + contact <- map( + result$data, + function(x) { + x[is.null(x)] <- NA_character_ + new("contact", + contactid = use_na(x$contactid, "int"), + familyname = use_na(x$familyname, "char"), + leadinginitials = use_na( + x$leadinginitials, + "char" + ), + givennames = use_na(x$givennames, "char"), + contactname = use_na(x$contactname, "char"), + suffix = use_na(x$suffix, "char"), + ORCID = use_na(x$ORCID, "char"), + title = use_na(x$title, "char"), + institution = use_na(x$institution, "char"), + email = use_na(x$email, "char"), + phone = use_na(x$phone, "char"), + contactstatus = use_na( + x$contactstatus, + "char" + ), + fax = use_na(x$fax, "char"), + url = use_na(x$url, "char"), + address = use_na(x$address, "char"), + notes = use_na(x$notes, "char") + ) + } + ) contacts <- new("contacts", contacts = contact) - return(contacts) + contacts } #' @rdname get_contacts #' @method get_contacts default #' @exportS3Method get_contacts default get_contacts.default <- function(x, ...) { - baseURL <- paste0("data/contacts") + base_url <- paste0("data/contacts") result <- tryCatch( - parseURL(baseURL, ...), + parseURL(base_url, ...), error = function(e) { stop("API call failed: ", e$message) NULL @@ -86,33 +93,42 @@ get_contacts.default <- function(x, ...) { cl[[1]] <- NULL cl <- lapply(cl, eval, envir = parent.frame()) if (!all(names(cl) %in% params)) { - warning("Some parameters seem invalid. + warning( + "Some parameters seem invalid. The current accepted parameters are: ", - paste(unlist(params), collapse = ", ")) + paste(unlist(params), collapse = ", ") + ) } result <- result %>% cleanNULL() - contact <- map(result$data, - function(x) { - new("contact", - contactid = use_na(x$contactid, "int"), - familyname = use_na(x$familyname, "char"), - leadinginitials = use_na(x$leadinginitials, - "char"), - givennames = use_na(x$givennames, "char"), - contactname = use_na(x$contactname, "char"), - suffix = use_na(x$suffix, "char"), - ORCID = use_na(x$ORCID, "char"), - title = use_na(x$title, "char"), - institution = use_na(x$institution, "char"), - email = use_na(x$email, "char"), - phone = use_na(x$phone, "char"), - contactstatus = use_na(x$contactstatus, - "char"), - fax = use_na(x$fax, "char"), - url = use_na(x$url, "char"), - address = use_na(x$address, "char"), - notes = use_na(x$notes, "char")) - }) + contact <- map( + result$data, + function(x) { + new("contact", + contactid = use_na(x$contactid, "int"), + familyname = use_na(x$familyname, "char"), + leadinginitials = use_na( + x$leadinginitials, + "char" + ), + givennames = use_na(x$givennames, "char"), + contactname = use_na(x$contactname, "char"), + suffix = use_na(x$suffix, "char"), + ORCID = use_na(x$ORCID, "char"), + title = use_na(x$title, "char"), + institution = use_na(x$institution, "char"), + email = use_na(x$email, "char"), + phone = use_na(x$phone, "char"), + contactstatus = use_na( + x$contactstatus, + "char" + ), + fax = use_na(x$fax, "char"), + url = use_na(x$url, "char"), + address = use_na(x$address, "char"), + notes = use_na(x$notes, "char") + ) + } + ) contacts <- new("contacts", contacts = contact) - return(contacts) -} \ No newline at end of file + contacts +} diff --git a/R/get_datasets.R b/R/get_datasets.R index 463c332e..028dcfe1 100644 --- a/R/get_datasets.R +++ b/R/get_datasets.R @@ -39,10 +39,10 @@ #' * `siteid` The unique site ID (integer) in Neotoma. Can be passed as a #' vector of site IDs. #' * `sitename` The site name, or approximate match using the % wildcard. -#' * `database` The constituent database for the record. See +#' * `database` The constituent database for the record. See #' `get_table("constituentdatabases")` -#' * `datasettype` Neotoma contains data for a number of dataset types. -#' This returns a subset of data types. For a complete list of available +#' * `datasettype` Neotoma contains data for a number of dataset types. +#' This returns a subset of data types. For a complete list of available #' dataset types, run `neotoma2::get_table('datasettypes')` #' * `altmin` The minimum altitude range for site elevation (in meters). #' * `altmax` The maximum altitude range for site elevation (in meters). @@ -63,21 +63,27 @@ #' for a site. #' * `taxa` The names of taxa which must be present within samples in a #' record. -#' * `all_data` The API only downloads the first 25 records of the query. +#' * `all_data` The API only downloads the first 25 records of the query. #' For the complete records, use `all_data=TRUE` #' @examples \dontrun{ -#' tryCatch({ -#' random_sites <- get_sites(1) -#' allds <- get_datasets(random_sites, limit=3) -#' }, error = function(e) { -#' message("Neotoma server not responding. Try again later.") -#' }) +#' tryCatch( +#' { +#' random_sites <- get_sites(1) +#' allds <- get_datasets(random_sites, limit = 3) +#' }, +#' error = function(e) { +#' message("Neotoma server not responding. Try again later.") +#' } +#' ) #' # To find all datasets with a min altitude of 12 and a max altitude of 25: -#' tryCatch({ -#' sites_12to25 <- get_datasets(altmin=12, altmax=25) -#' }, error = function(e) { -#' message("Neotoma server not responding. Try again later.") -#' }) +#' tryCatch( +#' { +#' sites_12to25 <- get_datasets(altmin = 12, altmax = 25) +#' }, +#' error = function(e) { +#' message("Neotoma server not responding. Try again later.") +#' } +#' ) #' # To find all datasets in Brazil #' brazil <- '{"type": "Polygon", #' "coordinates": [[ @@ -86,11 +92,14 @@ #' [-36.5625,-7.710991655433217], #' [-68.203125,13.923403897723347], #' [-73.125,-9.102096738726443]]]}' -#' tryCatch({ -#' brazil_datasets <- get_datasets(loc = brazil[1], limit=2) -#' }, error = function(e) { -#' message("Neotoma server not responding. Try again later.") -#' }) +#' tryCatch( +#' { +#' brazil_datasets <- get_datasets(loc = brazil[1], limit = 2) +#' }, +#' error = function(e) { +#' message("Neotoma server not responding. Try again later.") +#' } +#' ) #' } #' @md #' @export @@ -109,9 +118,9 @@ get_datasets.numeric <- function(x, ...) { if (length(x) > 0) { dataset <- paste0(x, collapse = ",") } - baseURL <- paste0("data/datasets/", dataset) + base_url <- paste0("data/datasets/", dataset) result <- tryCatch( - parseURL(baseURL, ...), + parseURL(base_url, ...), error = function(e) { stop("API call failed: ", e$message) NULL @@ -119,9 +128,9 @@ get_datasets.numeric <- function(x, ...) { ) if (length(result[2]$data) > 0) { output <- parse_site(result) - return(output) + output } else { - return(NULL) + NULL } } @@ -133,15 +142,17 @@ get_datasets.default <- function(x, ...) { oo <- options(scipen = 9999) on.exit(options(oo)) cl <- as.list(match.call()) - if ('doidata' %in% params) { - params <- append(params, 'doi') + if ("doidata" %in% params) { + params <- append(params, "doi") } cl[[1]] <- NULL cl <- lapply(cl, eval, envir = parent.frame()) if (!all(names(cl) %in% params)) { - warning("Some parameters seem invalid. + warning( + "Some parameters seem invalid. The current accepted parameters are: ", - paste(unlist(params), collapse = ", ")) + paste(unlist(params), collapse = ", ") + ) } base_url <- "data/datasets/" result <- tryCatch( @@ -152,10 +163,10 @@ get_datasets.default <- function(x, ...) { } ) if (is.null(result$data[1][[1]]) || is.null(result[1][[1]])) { - return(NULL) + NULL } else { output <- parse_site(result) - return(output) + output } } @@ -172,7 +183,7 @@ get_datasets.sites <- function(x, ...) { dots <- list(...) all_data <- if ("all_data" %in% names(dots)) dots$all_data else TRUE output <- get_datasets(x = ids, all_data = all_data) - return(output) + output } #' @rdname get_datasets @@ -181,17 +192,23 @@ get_datasets.site <- function(x, ...) { # List of datasets ids ids1 <- getids(x) ids <- ids1 %>% - filter(!is.na(suppressWarnings(as.numeric(.data$siteid))), - !is.na(suppressWarnings(as.numeric(.data$datasetid)))) - ids2 <- getids(x) %>% - filter(is.na(suppressWarnings(as.numeric(.data$siteid))) | - is.na(suppressWarnings(as.numeric(.data$datasetid)))) + filter( + !is.na(suppressWarnings(as.numeric(.data$siteid))), + !is.na(suppressWarnings(as.numeric(.data$datasetid))) + ) + ids2 <- getids(x) %>% + filter( + is.na(suppressWarnings(as.numeric(.data$siteid))) | + is.na(suppressWarnings(as.numeric(.data$datasetid))) + ) if (nrow(ids2) != 0) { - warnsite <- sprintf("SiteID %s or DatasetID %s does not exist in the - Neotoma DB yet or it has been removed. + warnsite <- sprintf( + "SiteID %s or DatasetID %s does not exist in the + Neotoma DB yet or it has been removed. It will be removed from your search.", - paste0(ids2$siteid, collapse = ", "), - paste0(ids2$datasetid, collapse = ", ")) + paste0(ids2$siteid, collapse = ", "), + paste0(ids2$datasetid, collapse = ", ") + ) warning(warnsite) } dataset_list <- ids$datasetid @@ -199,12 +216,12 @@ get_datasets.site <- function(x, ...) { dots <- list(...) all_data <- if ("all_data" %in% names(dots)) dots$all_data else TRUE output <- get_datasets(dataset_list, all_data = all_data) - return(output) + output } #' @rdname get_datasets #' @exportS3Method get_datasets NULL get_datasets.NULL <- function(x, ...) { message("Input is NULL, returning NULL") - return(NULL) -} \ No newline at end of file + NULL +} diff --git a/R/get_documentation.R b/R/get_documentation.R index 9828d356..8ff8859a 100644 --- a/R/get_documentation.R +++ b/R/get_documentation.R @@ -6,7 +6,7 @@ #' @returns NULL #' @examples \dontrun{ #' if (interactive()) { -#' get_documentation() +#' get_documentation() #' } #' } #' @md @@ -17,5 +17,5 @@ get_documentation <- function() { } else { stop("Browser window will not open if interactive() mode is FALSE.") } - return(NULL) -} \ No newline at end of file + NULL +} diff --git a/R/get_downloads.R b/R/get_downloads.R index 85eca4c7..1e4861bc 100644 --- a/R/get_downloads.R +++ b/R/get_downloads.R @@ -15,7 +15,7 @@ #' parameters: #' * `datasetid` The unique dataset ID (integer) in Neotoma. Can be passed #' as a vector of dataset IDs. -#' * `all_data` The API only downloads the first 25 records of the query. +#' * `all_data` The API only downloads the first 25 records of the query. #' For the complete records, use `all_data=TRUE` #' #' Download responses are large, and every request costs the Neotoma API real @@ -58,11 +58,14 @@ #' \item{ \code{metadata} }{dataset metadata} #' @examples \dontrun{ #' # To find the downloads object of dataset 24: -#' tryCatch({ -#' downloads24 <- get_downloads(24) -#' }, error = function(e) { -#' message("Neotoma server not responding. Try again later.") -#' }) +#' tryCatch( +#' { +#' downloads24 <- get_downloads(24) +#' }, +#' error = function(e) { +#' message("Neotoma server not responding. Try again later.") +#' } +#' ) #' # To find all downloads in Brazil #' brazil <- '{"type": "Polygon", #' "coordinates": [[ @@ -71,12 +74,15 @@ #' [-36.5625,-7.710991655433217], #' [-68.203125,13.923403897723347], #' [-73.125,-9.102096738726443]]]}' -#' tryCatch({ -#' brazil_datasets <- get_datasets(loc = brazil[1]) -#' brazil_downloads <- get_downloads(brazil_datasets) -#' }, error = function(e) { -#' message("Neotoma server not responding. Try again later.") -#' }) +#' tryCatch( +#' { +#' brazil_datasets <- get_datasets(loc = brazil[1]) +#' brazil_downloads <- get_downloads(brazil_datasets) +#' }, +#' error = function(e) { +#' message("Neotoma server not responding. Try again later.") +#' } +#' ) #' } #' @md #' @export @@ -141,16 +147,18 @@ get_downloads.numeric <- function(x, ...) { } records <- list() for (batch in batches) { - baseURL <- paste0("data/downloads?datasetid=", - paste0(batch, collapse = ",")) - key <- paste(baseURL, paste(names(dots), unlist(dots), collapse = "&")) + base_url <- paste0( + "data/downloads?datasetid=", + paste0(batch, collapse = ",") + ) + key <- paste(base_url, paste(names(dots), unlist(dots), collapse = "&")) # A failed request is raised as it is. It is not repeated with the # arguments removed: that is a different query, and it doubled the load on # a server that had just failed. Batches that succeeded stay cached, so a # second attempt only asks for the batches still missing. result <- downloads_cached(key, function() { tryCatch( - do.call(parseURL, c(list(baseURL), dots)), + do.call(parseURL, c(list(base_url), dots)), error = function(e) stop("API call failed: ", e$message, call. = FALSE) ) }) @@ -159,9 +167,9 @@ get_downloads.numeric <- function(x, ...) { result <- list(status = 200, data = records, message = "Success") if (!is.null(result[2]$data) || (length(result[2]$data) > 0)) { output <- parse_site(result) - return(output) + output } else { - return(NULL) + NULL } } @@ -179,5 +187,5 @@ get_downloads.sites <- function(x, verbose = TRUE, ...) { #' @rdname get_downloads #' @exportS3Method get_downloads NULL get_downloads.NULL <- function(x, ...) { - return(NULL) -} \ No newline at end of file + NULL +} diff --git a/R/get_manual.R b/R/get_manual.R index 95bdb4ac..9089f94d 100644 --- a/R/get_manual.R +++ b/R/get_manual.R @@ -7,7 +7,7 @@ #' # This call does not work from `source()` calls or in testing. #' # interactive() just lets us know you are interacting with the console: #' if (interactive()) { -#' get_manual() +#' get_manual() #' } #' } #' @returns NULL side effect for opening browser with the manual @@ -19,5 +19,5 @@ get_manual <- function() { } else { stop("Browser window will not open if interactive() mode is FALSE.") } - return(NULL) -} \ No newline at end of file + NULL +} diff --git a/R/get_params.R b/R/get_params.R index 0ce26a94..dc9e3251 100644 --- a/R/get_params.R +++ b/R/get_params.R @@ -36,26 +36,35 @@ get_params <- function(obj) { if (!is.null(cached)) { return(cached) } - r <- tryCatch({ - result <- get_swagger() - sw <- str_match(result, - paste0("v2.0/data/", obj, - "\"\\s*:\\s*(\\{[\\s\\S]+?\\})\\s*\\n"))[, 2] - matches <- str_match_all( - sw, "#/components/parameters/([a-zA-Z0-9_]+)Query\\\"" - )[[1]][, 2] - matches <- unique(matches) - matches - }, error = function(e) { - warning("Swagger with available parameters not available in API: ", - conditionMessage(e)) - NULL - }) + r <- tryCatch( + { + result <- get_swagger() + sw <- str_match( + result, + paste0( + "v2.0/data/", obj, + "\"\\s*:\\s*(\\{[\\s\\S]+?\\})\\s*\\n" + ) + )[, 2] + matches <- str_match_all( + sw, "#/components/parameters/([a-zA-Z0-9_]+)Query\\\"" + )[[1]][, 2] + matches <- unique(matches) + matches + }, + error = function(e) { + warning( + "Swagger with available parameters not available in API: ", + conditionMessage(e) + ) + NULL + } + ) params <- append(r, list("all_data", "limit", "offset")) params <- lapply(params, tolower) # Only a successful lookup is cached; a failed one must be retried. if (!is.null(r)) { swagger_cache[[paste0("params_", obj)]] <- params } - return(params) -} \ No newline at end of file + params +} diff --git a/R/get_publications.R b/R/get_publications.R index 0eb7ed4a..8917e57d 100644 --- a/R/get_publications.R +++ b/R/get_publications.R @@ -19,32 +19,41 @@ #' @returns `publications` object #' @examples \dontrun{ #' # How old are the papers in Neotoma that include the term "mammut"? -#' tryCatch({ -#' mammoth_papers <- get_publications(search="mammut") %>% -#' as.data.frame() -#' hist(as.numeric(mammoth_papers$year)) -#' }, error = function(e) { -#' message("Neotoma server not responding. Try again later.") -#' }) +#' tryCatch( +#' { +#' mammoth_papers <- get_publications(search = "mammut") %>% +#' as.data.frame() +#' hist(as.numeric(mammoth_papers$year)) +#' }, +#' error = function(e) { +#' message("Neotoma server not responding. Try again later.") +#' } +#' ) #' # We want the paper identified in Neotoma as 666: -#' tryCatch({ -#' get_publications(666) -#' }, error = function(e) { -#' message("Neotoma server not responding. Try again later.") -#' }) +#' tryCatch( +#' { +#' get_publications(666) +#' }, +#' error = function(e) { +#' message("Neotoma server not responding. Try again later.") +#' } +#' ) #' # Take a publication object and purposely degrade the metadata: -#' tryCatch({ -#' bad_pub <- get_publications(666) -#' # Note this only changes the reported year, not the citation string. -#' bad_pub[[1]]@year <- "1923" -#' bad_pub[[1]]@publicationid <- NA_integer_ -#' updated_pubs <- get_publications(bad_pub[[1]]) -#' attr(updated_pubs, "matches") -#' # we see the proper citation in the record: -#' updated_pubs <- attr(updated_pubs, "matches")[[3]] -#' }, error = function(e) { -#' message("Neotoma server not responding. Try again later.") -#' }) +#' tryCatch( +#' { +#' bad_pub <- get_publications(666) +#' # Note this only changes the reported year, not the citation string. +#' bad_pub[[1]]@year <- "1923" +#' bad_pub[[1]]@publicationid <- NA_integer_ +#' updated_pubs <- get_publications(bad_pub[[1]]) +#' attr(updated_pubs, "matches") +#' # we see the proper citation in the record: +#' updated_pubs <- attr(updated_pubs, "matches")[[3]] +#' }, +#' error = function(e) { +#' message("Neotoma server not responding. Try again later.") +#' } +#' ) #' } #' @md #' @export @@ -64,18 +73,20 @@ get_publications.default <- function(...) { cl[[1]] <- NULL cl <- lapply(cl, eval, envir = parent.frame()) get_params("publications") - baseURL <- paste0("data/publications") + base_url <- paste0("data/publications") result <- tryCatch( - parseURL(baseURL, ...), + parseURL(base_url, ...), error = function(e) { stop("API call failed: ", e$message) NULL } ) if (is.null(result$data)) { - return(NULL) + NULL } else { - result <- result$data %>% cleanNULL() %>% pluck("result") + result <- result$data %>% + cleanNULL() %>% + pluck("result") pubs <- map(result, function(x) { if ("match" %in% names(x)) { match <- x$match @@ -85,22 +96,23 @@ get_publications.default <- function(...) { x <- x$publication x[is.null(x)] <- NA_character_ output <- new("publication", - publicationtype = use_na(testNull(x$pubtype), "char"), - publicationid = use_na(testNull(x$publicationid), "int"), - articletitle = use_na(testNull(x$articletitle), "char"), - year = use_na(testNull(x$year), "char"), - journal = use_na(testNull(x$journal), "char"), - volume = use_na(testNull(x$volume), "char"), - issue = use_na(testNull(x$issue), "char"), - pages = use_na(testNull(x$pages), "char"), - citation = use_na(testNull(x$citation), "char"), - doi = use_na(testNull(x$doi), "char"), - author = pubAuthors(x)) + publicationtype = use_na(testNull(x$pubtype), "char"), + publicationid = use_na(testNull(x$publicationid), "int"), + articletitle = use_na(testNull(x$articletitle), "char"), + year = use_na(testNull(x$year), "char"), + journal = use_na(testNull(x$journal), "char"), + volume = use_na(testNull(x$volume), "char"), + issue = use_na(testNull(x$issue), "char"), + pages = use_na(testNull(x$pages), "char"), + citation = use_na(testNull(x$citation), "char"), + doi = use_na(testNull(x$doi), "char"), + author = pubAuthors(x) + ) attr(output, "match") <- match - return(output) + output }) %>% new("publications", publications = .) - return(pubs) + pubs } } @@ -113,41 +125,42 @@ get_publications.numeric <- function(x, ...) { } testNull <- function(val, out) { # nolint if (is.null(val)) { - return(out) + out } else { - return(val) + val } } - baseURL <- paste0("data/publications/", pubids) # nolint + base_url <- paste0("data/publications/", pubids) # nolint result <- tryCatch( - parseURL(baseURL, ...), + parseURL(base_url, ...), error = function(e) { stop("API call failed: ", e$message) NULL } ) if (is.null(result$data)) { - return(NULL) + NULL } else { result <- result %>% cleanNULL() # nolint pubs <- map(result$data, function(x) { x <- x$publication x[is.null(x)] <- NA_character_ new("publication", - publicationtype = use_na(testNull(x$pubtype), "char"), - publicationid = use_na(testNull(x$publicationid), "int"), - articletitle = use_na(testNull(x$articletitle), "char"), - year = use_na(testNull(x$year), "char"), - journal = use_na(testNull(x$journal), "char"), - volume = use_na(testNull(x$volume), "char"), - issue = use_na(testNull(x$issue), "char"), - pages = use_na(testNull(x$pages), "char"), - citation = use_na(testNull(x$citation), "char"), - doi = use_na(testNull(x$doi), "char"), - author = pubAuthors(x)) + publicationtype = use_na(testNull(x$pubtype), "char"), + publicationid = use_na(testNull(x$publicationid), "int"), + articletitle = use_na(testNull(x$articletitle), "char"), + year = use_na(testNull(x$year), "char"), + journal = use_na(testNull(x$journal), "char"), + volume = use_na(testNull(x$volume), "char"), + issue = use_na(testNull(x$issue), "char"), + pages = use_na(testNull(x$pages), "char"), + citation = use_na(testNull(x$citation), "char"), + doi = use_na(testNull(x$doi), "char"), + author = pubAuthors(x) + ) }) %>% new("publications", publications = .) - return(pubs) + pubs } } @@ -164,7 +177,7 @@ get_publications.publication <- function(x, ...) { attr(x, "matches") <- test } } - return(x) + x } #' @rdname get_publications @@ -181,7 +194,7 @@ get_publications.publications <- function(x, ...) { } } } - return(x) + x } #' @rdname get_publications @@ -193,6 +206,6 @@ get_publications.sites <- function(x, ...) { as.numeric() l <- nrow(ds_ids) ds_ids <- paste0(ds_ids, collapse = ",") - output <- get_publications(datasetid = ds_ids, limit=l) - return(output) -} \ No newline at end of file + output <- get_publications(datasetid = ds_ids, limit = l) + output +} diff --git a/R/get_sites.R b/R/get_sites.R index 9d9e2307..9f0fc71c 100644 --- a/R/get_sites.R +++ b/R/get_sites.R @@ -1,7 +1,7 @@ #' @title get_sites #' @name get_sites #' @author Socorro Dominguez \email{dominguezvid@wisc.edu} -#' @param x Use a single integer or vector of integers representing +#' @param x Use a single integer or vector of integers representing #' unique Neotoma site identifiers (siteids) to extract site information. #' @param ... accepted arguments, see details for more information. #' @description @@ -34,7 +34,7 @@ #' * `datasetid` The unique dataset ID (integer) in Neotoma. Can be passed #' as a vector of dataset IDs. #' * `datasettype` Neotoma contains data for a number of datasettypes. -#' This returns a subset of data types. For a complete list of available +#' This returns a subset of data types. For a complete list of available #' datasettypes, run `neotoma2::get_table('datasettypes')` #' * `doi` The dataset DOI for a dataset contained within a site. Can be #' passed as a vector of DOIs. @@ -51,7 +51,7 @@ #' for a site. #' * `taxa` The names of taxa which must be present within samples in a #' record. -#' * `all_data` The API only downloads the first 25 records of the query. +#' * `all_data` The API only downloads the first 25 records of the query. #' For the complete records, use `all_data=TRUE` #' This call will then return a data object that contains site metadata for one #' or more sites, along with limited metadata describing the collection units @@ -68,8 +68,8 @@ #' * `collunits` limited information on collunits #' @examples \dontrun{ #' ## Find sites with a min altitude of 12m and a max altitude of 25m -#' sites_12to25 <- get_sites(altmin=12, altmax=25) -#' sites_2500 <- get_sites(altmin=2500, all_data = TRUE) +#' sites_12to25 <- get_sites(altmin = 12, altmax = 25) +#' sites_2500 <- get_sites(altmin = 2500, all_data = TRUE) #' ## To find sites in Brazil #' brazil <- '{"type": "Polygon", #' "coordinates": [[ @@ -97,9 +97,9 @@ get_sites.numeric <- function(x, ...) { if (length(x) > 0) { siteids <- paste0(x, collapse = ",") } - baseURL <- paste0("data/sites/", siteids) + base_url <- paste0("data/sites/", siteids) result <- tryCatch( - parseURL(baseURL, ...), + parseURL(base_url, ...), error = function(e) { stop("API call failed: ", e$message) NULL @@ -107,9 +107,9 @@ get_sites.numeric <- function(x, ...) { ) if (!is.null(result) && length(result[2]$data) > 0) { output <- parse_site(result) - return(output) + output } else { - return(NULL) + NULL } } @@ -132,27 +132,29 @@ get_sites.default <- function(...) { } params <- get_params("sites") if (!all(names(cl) %in% params)) { - warning("Some parameters seem invalid. + warning( + "Some parameters seem invalid. The current accepted parameters are: ", - paste(unlist(params), collapse = ", ")) + paste(unlist(params), collapse = ", ") + ) } oo <- options(scipen = 9999) on.exit(options(oo)) - baseURL <- paste0("data/sites") + base_url <- paste0("data/sites") result <- tryCatch( - parseURL(baseURL, ...), + parseURL(base_url, ...), error = function(e) { stop("API call failed: ", e$message) NULL } ) if (is.null(result) || is.null(result$data[1][[1]])) { - return(NULL) + NULL } else { result <- result %>% cleanNULL() output <- parse_site(result) - return(output) + output } } @@ -160,5 +162,5 @@ get_sites.default <- function(...) { #' @exportS3Method get_sites NULL get_sites.NULL <- function(x, ...) { message("Input is NULL, returning NULL") - return(NULL) -} \ No newline at end of file + NULL +} diff --git a/R/get_specimens.R b/R/get_specimens.R index 8aa5819b..9400dda2 100644 --- a/R/get_specimens.R +++ b/R/get_specimens.R @@ -1,6 +1,8 @@ # #' @title get_specimens # ##' @name get_specimens +# nolint start # #' @author Socorro Dominguez \email{dominguezvid@wisc.edu} +# nolint end # #' @importFrom purrr map # #' @importFrom dplyr bind_rows select filter # #' @description @@ -11,6 +13,7 @@ # #' @keywords internal # #' @noRd # get_specimens <- function(x, ...) { +# nolint start # UseMethod("get_specimens") # } @@ -44,16 +47,21 @@ # newsp <- build_specimen(sps[[i]]) # # Attach built specimen slot to datasets -# datasets <- ds[[st]]@collunits@collunits[[cuid]]@datasets@datasets[[dsid]] +# datasets <- +# ds[[st]]@collunits@collunits[[cuid]]@datasets@datasets[[dsid]] +# nolint end # datasets@specimens@specimens <- c(datasets@specimens@specimens, # newsp) # datasets@samples@samples <- # ds[[st]]@collunits@collunits[[ # cuid]]@datasets@datasets[[dsid]]@samples@samples -# ds[[st]]@collunits@collunits[[cuid]]@datasets@datasets[[dsid]] <- datasets +# ds[[st]]@collunits@collunits[[cuid]]@datasets@datasets[[dsid]] <- +# datasets # } # } +# nolint start # return(ds) +# nolint end # } # ##' @rdname get_specimens @@ -61,21 +69,24 @@ # # remove meanwhile # get_specimens.numeric <- function(x, ...) { # if (length(x) > 0) { +# nolint start # specimenid <- paste0(x, collapse = ",") # } -# baseURL <- paste0("data/specimens/", specimenid) +# base_url <- paste0("data/specimens/", specimenid) # result <- tryCatch( -# parseURL(baseURL), +# parseURL(base_url), # error = function(e) { # message("API call failed: ", e$message) +# nolint end # NULL # } # ) # if ((is.null(result)) | (length(result$data) == 0)) { -# stop("Specimen ID not found. +# stop("Specimen ID not found. # If you meant dataset ID, use parameter datasetid") # } +# nolint start # sps <- result$data %>% # cleanNULL() # #if sps is empty list, exit and return error No Specimen ID available. @@ -85,12 +96,14 @@ # dw <- get_downloads(sp_index$datasetid) # ds <- parse_specimen(result, dw) # return(ds) +# nolint end # } # ##' @rdname get_specimens # ##' @export # get_specimens.default <- function(...) { +# nolint start # cl <- as.list(match.call()) # cl[[1]] <- NULL # cl <- lapply(cl, eval, envir = parent.frame()) @@ -98,27 +111,31 @@ # if (length(dsid) > 0) { # dsid <- paste0(dsid, collapse = ",") # } -# baseURL <- paste0("data/datasets/", as.character(dsid), "/specimens") +# base_url <- paste0("data/datasets/", as.character(dsid), "/specimens") # result <- tryCatch( # parseURL(base_url, ...), # error = function(e) { # message("API call failed: ", e$message) +# nolint end # NULL # } # ) # if(length(result$data) == 0) { +# nolint start # warning("No specimens found for the provided dataset ID.") # return(NULL) # } else { # dw <- get_downloads(cl$datasetid) # ds <- parse_specimen(result, dw) # return(ds) +# nolint end # } # } # ##' @rdname get_specimens # ##' @export # get_specimens.sites <- function(x,...) { +# nolint start # output <- getids(x) %>% # select(datasetid) %>% # stats::na.omit() %>% @@ -127,15 +144,17 @@ # if (length(output) > 0) { # output <- paste0(output, collapse = ",") # } -# baseURL <- paste0("data/datasets/", output, "/specimens/") +# base_url <- paste0("data/datasets/", output, "/specimens/") # result <- tryCatch( -# parseURL(baseURL, ...), +# parseURL(base_url, ...), # error = function(e) { # message("API call failed: ", e$message) +# nolint end # NULL # } # ) # if (length(result$data) == 0) { +# nolint start # warning("No specimens found for the provided dataset ID.") # return(NULL) # } else { @@ -145,5 +164,6 @@ # } # ds <- parse_specimen(result, x) # return(ds) +# nolint end # } -# } \ No newline at end of file +# } diff --git a/R/get_speleothems.R b/R/get_speleothems.R index d4f41818..a621b1cc 100644 --- a/R/get_speleothems.R +++ b/R/get_speleothems.R @@ -10,9 +10,9 @@ speleo_helper <- function(sites) { if (length(cuids) > 0) { cuids <- paste0(cuids, collapse = ",") } - baseURL <- paste0("data/speleothems/", cuids) + base_url <- paste0("data/speleothems/", cuids) result <- tryCatch( - parseURL(baseURL), + parseURL(base_url), error = function(e) { message("API call failed: ", e$message) NULL @@ -60,7 +60,7 @@ speleo_helper <- function(sites) { #' * `sites` A `sites` R object. #' @examples \dontrun{ #' ## Find speleothems by numeric datasetid: -#' speleo <- get_speleothems(c(2,5)) +#' speleo <- get_speleothems(c(2, 5)) #' } #' @md #' @export @@ -96,4 +96,4 @@ get_speleothems.sites <- function(x, ...) { } else { new("sites", sites = pared_ds) } -} \ No newline at end of file +} diff --git a/R/get_stats.R b/R/get_stats.R index 3c747c15..f98dcf94 100644 --- a/R/get_stats.R +++ b/R/get_stats.R @@ -22,11 +22,14 @@ #' per dataset type per month). Default is \code{dsdbmonth}. #' @returns `data.frame` with summary statistics #' @examples \dontrun{ -#' tryCatch({ -#' last_month <- get_stats(start = 0, end = 1, type = "dsdbmonth") -#' }, error = function(e) { -#' message("Neotoma server not responding. Try again later.") -#' }) +#' tryCatch( +#' { +#' last_month <- get_stats(start = 0, end = 1, type = "dsdbmonth") +#' }, +#' error = function(e) { +#' message("Neotoma server not responding. Try again later.") +#' } +#' ) #' } #' @md #' @export @@ -35,14 +38,14 @@ get_stats <- function(start = 0, end = 1, type = "dsdbmonth") { stop("type must be either 'dsdbmonth', 'dstypemonth' or 'rawbymonth'.") } if (type == "dsdbmonth") { - baseURL <- paste0("data/summary/dsdbmonth?start=", start, "&end=", end) + base_url <- paste0("data/summary/dsdbmonth?start=", start, "&end=", end) } else if (type == "rawbymonth") { - baseURL <- paste0("data/summary/rawbymonth?start=", start, "&end=", end) + base_url <- paste0("data/summary/rawbymonth?start=", start, "&end=", end) } else if (type == "dstypemonth") { - baseURL <- paste0("data/summary/dstypemonth?start=", start, "&end=", end) + base_url <- paste0("data/summary/dstypemonth?start=", start, "&end=", end) } result <- tryCatch( - parseURL(baseURL), + parseURL(base_url), error = function(e) { message("API call failed: ", e$message) NULL @@ -78,4 +81,4 @@ get_stats <- function(start = 0, end = 1, type = "dsdbmonth") { )) return(df) } -} \ No newline at end of file +} diff --git a/R/get_table.R b/R/get_table.R index 9f70afe0..d8bcec47 100644 --- a/R/get_table.R +++ b/R/get_table.R @@ -13,7 +13,7 @@ #' @returns selected `table` values from the Database. #' @examples \dontrun{ #' # Returns only the first 25 specimen records. -#' someSpec <- get_table('specimens') +#' someSpec <- get_table("specimens") #' } #' @importFrom dplyr bind_rows #' @importFrom purrr map diff --git a/R/get_taxa.R b/R/get_taxa.R index c14f2151..8012d2f3 100644 --- a/R/get_taxa.R +++ b/R/get_taxa.R @@ -71,16 +71,19 @@ taxon_names <- function(taxa_data) { datasets_with_taxa <- function(taxon, dots) { taxon <- unique(taxon) if (length(taxon) == 0) { - message("No taxon found with the provided information. ", - "No datasets were requested.") + message( + "No taxon found with the provided information. ", + "No datasets were requested." + ) return(NULL) } if (length(taxon) > taxa_name_warn_limit) { warning(length(taxon), " taxon names will be sent to the API in one ", - "request. Broad `taxa` queries can take a minute or more to ", - "answer. Consider a narrower taxon name or ID, or add other ", - "filters such as `datasettype`, `loc`, or `limit`.", - call. = FALSE) + "request. Broad `taxa` queries can take a minute or more to ", + "answer. Consider a narrower taxon name or ID, or add other ", + "filters such as `datasettype`, `loc`, or `limit`.", + call. = FALSE + ) } do.call(get_datasets, c(list(taxa = taxon), dots)) } @@ -108,8 +111,10 @@ get_taxa.default <- function(...) { } else if ("taxonname" %in% names(dots)) { taxon <- taxon_names(get_taxon(taxonname = dots$taxonname)) } else { - stop("Please provide a taxon ID, a taxon name (`taxonname`), ", - "or exact taxon names (`taxa`) to extract site information.") + stop( + "Please provide a taxon ID, a taxon name (`taxonname`), ", + "or exact taxon names (`taxa`) to extract site information." + ) } dots$taxa <- NULL dots$taxonname <- NULL diff --git a/R/get_taxon.R b/R/get_taxon.R index eb672863..05fc0470 100644 --- a/R/get_taxon.R +++ b/R/get_taxon.R @@ -6,21 +6,22 @@ parse_taxon <- function(data) { data <- data$data %>% cleanNULL() - newTaxa <- map(data, function(x) { + new_taxa <- map(data, function(x) { 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), "char"), - publicationid = use_na(testNull(x$publicationid, NA), "int"), - publication = use_na(testNull(x$publication, NA), "char")) + 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), "char"), + publicationid = use_na(testNull(x$publicationid, NA), "int"), + publication = use_na(testNull(x$publication, NA), "char") + ) }) - taxa <- new("taxa", taxa = newTaxa) - return(taxa) + taxa <- new("taxa", taxa = new_taxa) + taxa } #' @title get_taxon @@ -44,7 +45,7 @@ parse_taxon <- function(data) { #' taxagrouptypes table. #' * `ecolgroup` The ecological group of interest for the Neotoma taxon (from #' the Neotoma ecolgrouptypes table) -#' * `status` The taxonomic extinction status of the taxon, either extinct +#' * `status` The taxonomic extinction status of the taxon, either extinct #' (1, True) or extant (0, False). #' @md #' @export @@ -75,30 +76,30 @@ get_taxon.default <- function(...) { warning("Some parameters seem invalid. The current accepted parameters are: ", paste(unlist(params), collapse = ", ")) } - baseURL <- paste0("data/taxa") + base_url <- paste0("data/taxa") # `all_data` is handed to parseURL() explicitly, and taken out of `...` so it # is not passed twice. Without this a wildcard such as `taxonname = "Pinus%"` # came back as the API's first page only, with no warning. dots <- list(...) dots$all_data <- NULL result <- tryCatch( - do.call(parseURL, c(list(baseURL, all_data = all_data), dots)), + do.call(parseURL, c(list(base_url, all_data = all_data), dots)), error = function(e) { stop("API call failed: ", e$message) NULL } ) if (is.null(result)) { - return(NULL) + NULL } else { result <- result %>% cleanNULL() if (is.null(result$data[1][[1]]) || is.null(result[1][[1]])) { message("No taxon data found with the provided parameters.") - return(NULL) + NULL } else { output <- parse_taxon(result) - return(output) + output } } } @@ -120,9 +121,9 @@ get_taxon.numeric <- function(x, ...) { # A long vector of ids makes a URL the API will not take. parseURL() then # sends the ids in several short GET requests (there is no POST route for # taxa), so it is safe to pass any number of ids here. - baseURL <- paste0("data/taxa/", taxa_id) + base_url <- paste0("data/taxa/", taxa_id) result <- tryCatch( - parseURL(baseURL, ...), + parseURL(base_url, ...), error = function(e) { stop("API call failed: ", e$message) NULL @@ -131,10 +132,12 @@ get_taxon.numeric <- function(x, ...) { result_length <- length(result$data) if (result_length > 0) { output <- parse_taxon(result) - return(output) + output } else { - message("No taxon data found for taxon ID: ", - substr(taxa_id, 1, 60), if (nchar(taxa_id) > 60) "...") - return(NULL) + message( + "No taxon data found for taxon ID: ", + substr(taxa_id, 1, 60), if (nchar(taxa_id) > 60) "..." + ) + NULL } } diff --git a/R/getids.r b/R/getids.r index 05a33270..a99c42c8 100644 --- a/R/getids.r +++ b/R/getids.r @@ -36,14 +36,16 @@ getids.sites <- function(x, order = TRUE) { } else { datasetids <- NA } - return(data.frame(collunitid = collunitid, - datasetid = unlist(datasetids))) + data.frame( + collunitid = collunitid, + datasetid = unlist(datasetids) + ) }) %>% bind_rows() } else { cuids <- data.frame(collunitid = NA, datasetid = NA) } - return(data.frame(siteid = siteid, cuids)) + data.frame(siteid = siteid, cuids) }) siteids <- do.call("rbind.data.frame", args = siteids) rownames(siteids) <- seq_len(nrow(siteids)) @@ -53,9 +55,11 @@ getids.sites <- function(x, order = TRUE) { } # Guaranteeing that future joins all work out siteids <- siteids %>% - mutate(siteid = .data$siteid, - collunitid = .data$collunitid, - datasetid = .data$datasetid) + mutate( + siteid = .data$siteid, + collunitid = .data$collunitid, + datasetid = .data$datasetid + ) siteids <- siteids[!is.na(siteids$datasetid), ] siteids <- unique(siteids) return(siteids) @@ -76,8 +80,10 @@ getids.site <- function(x, order = TRUE) { } else { datasetids <- NA } - return(data.frame(collunitid = (collunitid), - datasetid = (unlist(datasetids)))) + data.frame( + collunitid = (collunitid), + datasetid = (unlist(datasetids)) + ) }) %>% bind_rows() } else { @@ -101,8 +107,10 @@ getids.collunits <- function(x, order = TRUE) { } else { datasetids <- NA } - return(data.frame(collunitid = (collunitid), - datasetid = (unlist(datasetids)))) + data.frame( + collunitid = (collunitid), + datasetid = (unlist(datasetids)) + ) }) %>% bind_rows() } else { @@ -124,9 +132,11 @@ getids.collunit <- function(x, order = TRUE) { } else { datasetids <- NA } - df <- data.frame(siteid = siteid, - collunitid = collunitid, - datasetid = datasetids) + df <- data.frame( + siteid = siteid, + collunitid = collunitid, + datasetid = datasetids + ) df <- df[!is.na(df$datasetid), ] return(df) -} \ No newline at end of file +} diff --git a/R/group_data.R b/R/group_data.R index d1ec7f34..763e65cd 100644 --- a/R/group_data.R +++ b/R/group_data.R @@ -28,7 +28,7 @@ group_response <- function(data) { return(list()) } # Detect endpoint - is_dataset <- all(map_lgl(data, ~ !is.null(.x$site$datasets))) + is_dataset <- all(map_lgl(data, ~ !is.null(.x$site$datasets))) is_download <- all(map_lgl(data, function(x) { tryCatch(!is.null(x$site$collectionunit$dataset), error = function(e) FALSE) })) diff --git a/R/parseLocation.R b/R/parseLocation.R index 8e9b7c5e..811627aa 100644 --- a/R/parseLocation.R +++ b/R/parseLocation.R @@ -15,11 +15,16 @@ parseLocation <- function(x) { if (is.numeric(x)) { assert_that(length(na.omit(x)) == 4, - msg = "Numeric coordinates need to be an array of - 4 units, c(xmin, xmax, ymax, ymin)") - bbox <- st_bbox(c(xmin = x[1], xmax = x[3], - ymax = x[4], ymin = x[2]), - crs = st_crs(4326)) + msg = "Numeric coordinates need to be an array of + 4 units, c(xmin, xmax, ymax, ymin)" + ) + bbox <- st_bbox( + c( + xmin = x[1], xmax = x[3], + ymax = x[4], ymin = x[2] + ), + crs = st_crs(4326) + ) sfc <- st_as_sfc(bbox) geojson <- sfc_geojson(sfc) geojson <- fromJSON(geojson, simplifyVector = FALSE) @@ -37,21 +42,24 @@ parseLocation <- function(x) { geojson <- sfc_geojson(sfc) geojson <- fromJSON(geojson, simplifyVector = FALSE) } else { - geojson <- tryCatch({ - parsed <- geojson_sf(x) - if (inherits(parsed, "sf")) { - gj <- sf_geojson(parsed) - fromJSON(gj, simplifyVector = FALSE) - } else { - stop("Input string is not valid GeoJSON.") + geojson <- tryCatch( + { + parsed <- geojson_sf(x) + if (inherits(parsed, "sf")) { + gj <- sf_geojson(parsed) + fromJSON(gj, simplifyVector = FALSE) + } else { + stop("Input string is not valid GeoJSON.") + } + }, + error = function(e) { + stop("Error parsing GeoJSON string: ", e$message) } - }, error = function(e) { - stop("Error parsing GeoJSON string: ", e$message) - }) + ) } } body <- list(toJSON(geojson, auto_unbox = TRUE)) - return(body) + body } #' @title is_wkt @@ -66,8 +74,13 @@ parseLocation <- function(x) { #' @noRd is_wkt <- function(x) { is.character(x) && length(x) == 1L && - grepl(paste0("^\\s*(SRID=\\d+;)?\\s*", - "(POINT|LINESTRING|POLYGON|MULTIPOINT|", - "MULTILINESTRING|MULTIPOLYGON|GEOMETRYCOLLECTION)"), - x, ignore.case = TRUE) + grepl( + paste0( + "^\\s*(SRID=\\d+;)?\\s*", + "(POINT|LINESTRING|POLYGON|MULTIPOINT|", + "MULTILINESTRING|MULTIPOLYGON|GEOMETRYCOLLECTION)" + ), + x, + ignore.case = TRUE + ) } diff --git a/R/parseURL.R b/R/parseURL.R index f7f8e365..efc0a617 100644 --- a/R/parseURL.R +++ b/R/parseURL.R @@ -13,10 +13,11 @@ neotoma_baseurl <- function(use = "neotoma") { use <- apipoint } switch(use, - "dev" = "https://api-dev.neotomadb.org/v2.0/", - "neotoma" = "https://api.neotomadb.org/v2.0/", - "local" = "http://localhost:3001/v2.0/", - use) + "dev" = "https://api-dev.neotomadb.org/v2.0/", + "neotoma" = "https://api.neotomadb.org/v2.0/", + "local" = "http://localhost:3001/v2.0/", + use + ) } #' @title neotoma_cache @@ -59,13 +60,17 @@ neotoma_cache_clear <- function() { neotoma_user_agent <- function() { if (is.null(neotoma_cache$user_agent)) { version <- tryCatch(as.character(utils::packageVersion("neotoma2")), - error = function(e) "unknown") - neotoma_cache$user_agent <- paste0("neotoma2/", version, " (R ", - getRversion()) + error = function(e) "unknown" + ) + neotoma_cache$user_agent <- paste0( + "neotoma2/", version, " (R ", + getRversion() + ) } contact <- getOption("neotoma2.contact", Sys.getenv("NEOTOMA_CONTACT", "")) - if (is.character(contact) && length(contact) == 1 && !is.na(contact) && - nzchar(contact)) { + has_contact <- is.character(contact) && length(contact) == 1 && + !is.na(contact) && nzchar(contact) + if (has_contact) { paste0(neotoma_cache$user_agent, "; contact: ", contact, ")") } else { paste0(neotoma_cache$user_agent, ")") @@ -81,8 +86,10 @@ neotoma_user_agent <- function() { #' @noRd neotoma_headers <- function(json = FALSE) { if (json) { - add_headers("User-Agent" = neotoma_user_agent(), - "Content-Type" = "application/json") + add_headers( + "User-Agent" = neotoma_user_agent(), + "Content-Type" = "application/json" + ) } else { add_headers("User-Agent" = neotoma_user_agent()) } @@ -237,8 +244,10 @@ neotoma_wait <- function(response, attempt) { } } if (neotoma_is_busy(response) || seconds >= 10) { - message("The Neotoma API is busy; waiting ", round(seconds), - " s before trying again.") + message( + "The Neotoma API is busy; waiting ", round(seconds), + " s before trying again." + ) } neotoma_sleep(seconds) invisible(seconds) @@ -313,7 +322,8 @@ neotoma_retry <- function(verb, url, ..., attempt <- 1 repeat { response <- tryCatch(VERB(verb, url, ..., timeout(seconds)), - error = function(e) e) + error = function(e) e + ) if (neotoma_is_timeout(response) || neotoma_is_busy(response)) { budget <- min(budget, 2) } @@ -324,10 +334,12 @@ neotoma_retry <- function(verb, url, ..., attempt <- attempt + 1 } if (neotoma_is_timeout(response)) { - stop("The Neotoma API did not respond within ", seconds, " seconds for ", - url, " (", attempt, " attempt(s)).\nSpatial (loc) queries are slow ", - "server-side; try a smaller area, or raise the wait with ", - "Sys.setenv(NEOTOMA_TIMEOUT = ", seconds * 2, ").") + stop( + "The Neotoma API did not respond within ", seconds, " seconds for ", + url, " (", attempt, " attempt(s)).\nSpatial (loc) queries are slow ", + "server-side; try a smaller area, or raise the wait with ", + "Sys.setenv(NEOTOMA_TIMEOUT = ", seconds * 2, ")." + ) } if (inherits(response, "condition")) { stop(response) @@ -347,12 +359,16 @@ neotoma_request <- function(expr) { expr(), error = function(e) { if (grepl("SSL certificate", conditionMessage(e), ignore.case = TRUE)) { - stop("SSL certificate error: ", conditionMessage(e), - "\nPlease contact the Neotoma team.") + stop( + "SSL certificate error: ", conditionMessage(e), + "\nPlease contact the Neotoma team." + ) } else { - stop("API request failed: ", conditionMessage(e), - "\nCheck that the API path is valid or visit: - http://data.neotomadb.org") + stop( + "API request failed: ", conditionMessage(e), + "\nCheck that the API path is valid or visit: + http://data.neotomadb.org" + ) } } ) @@ -376,22 +392,25 @@ neotoma_status_check <- function(response) { stop("Error 429: Too many requests. Please wait and retry.") } else if (neotoma_is_busy(response)) { stop("Error ", response$status_code, ": the Neotoma API is busy or ", - "restarting. Try again later, or reduce the size of the query ", - "(fewer ids, a smaller area, a narrower taxon or name filter).", - call. = FALSE) + "restarting. Try again later, or reduce the size of the query ", + "(fewer ids, a smaller area, a narrower taxon or name filter).", + call. = FALSE + ) } else { detail <- neotoma_api_message(response) tryCatch( stop_for_status(response, - task = "Could not connect to the Neotoma API. + task = "Could not connect to the Neotoma API. Check that the path is valid, and check the current status of the Neotoma API services at - http://data.neotomadb.org"), + http://data.neotomadb.org" + ), error = function(e) { stop(conditionMessage(e), - if (!is.na(detail)) paste0("\nThe API said: ", detail), - call. = FALSE) + if (!is.na(detail)) paste0("\nThe API said: ", detail), + call. = FALSE + ) } ) } @@ -412,7 +431,8 @@ neotoma_status_check <- function(response) { neotoma_api_message <- function(response) { parsed <- tryCatch( fromJSON(content(response, as = "text", encoding = "UTF-8"), - simplifyVector = FALSE), + simplifyVector = FALSE + ), error = function(e) NULL ) if (!is.list(parsed)) { @@ -444,9 +464,11 @@ neotoma_content <- function(response) { text <- content(response, as = "text", encoding = "UTF-8") if (grepl("^\\s*<", text)) { stop("The Neotoma API returned a web page instead of data, which usually ", - "means the request was redirected (for example to the API ", - "documentation). Check that the endpoint accepts this kind of ", - "request: ", response$url, call. = FALSE) + "means the request was redirected (for example to the API ", + "documentation). Check that the endpoint accepts this kind of ", + "request: ", response$url, + call. = FALSE + ) } fromJSON(text, flatten = FALSE, simplifyVector = FALSE) } @@ -463,7 +485,8 @@ neotoma_content <- function(response) { neotoma_get <- function(baseurl, x, query) { response <- neotoma_request(function() { neotoma_retry("GET", paste0(baseurl, x), neotoma_headers(), - query = query) + query = query + ) }) neotoma_status_check(response) neotoma_content(response) @@ -503,8 +526,10 @@ neotoma_post_route <- function(x) { neotoma_post <- function(url, query) { body <- neotoma_body(query) response <- neotoma_request(function() { - neotoma_retry("POST", url, body = body, encode = "raw", - neotoma_headers(json = TRUE), config(postredir = 7)) + neotoma_retry("POST", url, + body = body, encode = "raw", + neotoma_headers(json = TRUE), config(postredir = 7) + ) }) neotoma_status_check(response) neotoma_content(response) @@ -566,12 +591,16 @@ neotoma_get_ids <- function(baseurl, x, query, chunk = 100) { r <- neotoma_post(paste0(baseurl, endpoint), query) if (!neotoma_ids_applied(r$data, id_key, batch)) { stop("The Neotoma API returned records that do not match the ", - length(batch), " ids requested from ", endpoint, ". The ids ", - "were not applied to the query.", call. = FALSE) + length(batch), " ids requested from ", endpoint, ". The ids ", + "were not applied to the query.", + call. = FALSE + ) } } else { - r <- neotoma_get(baseurl, paste0(prefix, paste(batch, collapse = ",")), - query) + r <- neotoma_get( + baseurl, paste0(prefix, paste(batch, collapse = ",")), + query + ) } if (!is.null(r$data)) { results <- c(results, r$data) @@ -596,13 +625,15 @@ neotoma_get_ids <- function(baseurl, x, query, chunk = 100) { #' @noRd neotoma_fetch <- function(baseurl, x, query) { full_url <- modify_url(baseurl, - path = file.path("v2.0", x), - query = query[setdiff(names(query), "loc")]) + path = file.path("v2.0", x), + query = query[setdiff(names(query), "loc")] + ) if ("loc" %in% names(query)) { parts <- strsplit(x, "/")[[1]] url <- paste0(baseurl, paste(parts[seq_len(min(2, length(parts)))], - collapse = "/")) + collapse = "/" + )) return(neotoma_post(url, query)) } @@ -653,8 +684,10 @@ neotoma_paginate <- function(baseurl, x, query, page = 2000) { repeat { pages <- pages + 1 if (pages > 1 && interactive()) { - message("Fetching page ", pages, " (records ", query$offset + 1, - "+) ...") + message( + "Fetching page ", pages, " (records ", query$offset + 1, + "+) ..." + ) } r <- neotoma_fetch(baseurl, x, query) r <- cleanNULL(r) diff --git a/R/parse_speleothem.R b/R/parse_speleothem.R index cf98faf4..c62b2813 100644 --- a/R/parse_speleothem.R +++ b/R/parse_speleothem.R @@ -22,32 +22,36 @@ parse_speleothem <- function(data) { # so an absent `dripheight` or `entrancedistance` would silently return the # matching `...units` string and write it into a numeric slot. sp <- - list(entityid = x[["entityid"]], - entityname = x[["entityname"]], - siteid = x[["siteid"]], - collectionunitid = x[["collectionunitid"]], - datasetid = x[["datasetid"]], - dripheight = use_na(x[["dripheight"]], "int"), - monitoring = use_na(x[["monitoring"]], "bool"), - geology = use_na(x[["geology"]], "char"), - rockage = use_na(x[["rockage"]], "char"), - speleothemtype = use_na(x[["speleothemtype"]], "char"), - dripheightunits = use_na(x[["dripheightunits"]], "char"), - entitycovertype = use_na(x[["entitycovertype"]], "char"), - entrancedistance = use_na(x[["entrancedistance"]], "int"), - entrancedistanceunits = use_na(x[["entrancedistanceunits"]], "char"), - landusecovertype = use_na(x[["landusecovertype"]], "char"), - speleothemdriptype = use_na(x[["speleothemdriptype"]], "char"), - landusecoverpercent = use_na(x[["landusecoverpercent"]], "int"), - vegetationcovertype = use_na(x[["vegetationcovertype"]], "char"), - entitycoverthickness = use_na(x[["entitycoverthickness"]], "int"), - vegetationcoverpercent = use_na(x[["vegetationcoverpercent"]], - "int")) + list( + entityid = x[["entityid"]], + entityname = x[["entityname"]], + siteid = x[["siteid"]], + collectionunitid = x[["collectionunitid"]], + datasetid = x[["datasetid"]], + dripheight = use_na(x[["dripheight"]], "int"), + monitoring = use_na(x[["monitoring"]], "bool"), + geology = use_na(x[["geology"]], "char"), + rockage = use_na(x[["rockage"]], "char"), + speleothemtype = use_na(x[["speleothemtype"]], "char"), + dripheightunits = use_na(x[["dripheightunits"]], "char"), + entitycovertype = use_na(x[["entitycovertype"]], "char"), + entrancedistance = use_na(x[["entrancedistance"]], "int"), + entrancedistanceunits = use_na(x[["entrancedistanceunits"]], "char"), + landusecovertype = use_na(x[["landusecovertype"]], "char"), + speleothemdriptype = use_na(x[["speleothemdriptype"]], "char"), + landusecoverpercent = use_na(x[["landusecoverpercent"]], "int"), + vegetationcovertype = use_na(x[["vegetationcovertype"]], "char"), + entitycoverthickness = use_na(x[["entitycoverthickness"]], "int"), + vegetationcoverpercent = use_na( + x[["vegetationcoverpercent"]], + "int" + ) + ) do.call(build_speleothem, sp) }) # Drop malformed/empty speleothems (build_speleothem() returns NULL for them) # individually, so a partially-malformed list keeps its valid entries. speleothems <- speleothems[!map_lgl(speleothems, is.null)] speleo <- new("speleothems", speleothems = speleothems) - return(speleo) -} \ No newline at end of file + speleo +} diff --git a/R/pingNeotoma.r b/R/pingNeotoma.r index 9cada986..c9341c05 100644 --- a/R/pingNeotoma.r +++ b/R/pingNeotoma.r @@ -13,15 +13,19 @@ #' } #' @export pingNeotoma <- function(server = "neotoma") { - valid_local <- str_detect(server, - "(http?:////){0,1}localhost:\\d{1,5}$") + valid_local <- str_detect( + server, + "(http?:////){0,1}localhost:\\d{1,5}$" + ) assert_that(valid_local | (server %in% c("neotoma", "dev")), - msg = "The parameter `server` must be a valid - localhost (e.g., localhost:3005), or `neotoma` or `dev`.") + msg = "The parameter `server` must be a valid + localhost (e.g., localhost:3005), or `neotoma` or `dev`." + ) server <- switch(server, - neotoma = "https://api.neotomadb.org", - dev = "https://api-dev.neotomadb.org", - server) + neotoma = "https://api.neotomadb.org", + dev = "https://api-dev.neotomadb.org", + server + ) status <- HEAD(server) return(status) -} \ No newline at end of file +} diff --git a/R/plotLeaflet.R b/R/plotLeaflet.R index 2b180a7e..77218074 100644 --- a/R/plotLeaflet.R +++ b/R/plotLeaflet.R @@ -1,69 +1,86 @@ #' @title plotLeaflet #' @description Plot sites on a leaflet map #' @importFrom purrr map -#' @importFrom leaflet leaflet addTiles addCircleMarkers +#' @importFrom leaflet leaflet addTiles addCircleMarkers #' @importFrom leaflet markerOptions markerClusterOptions #' @param object Sites object to plot #' @examples \dontrun{ #' # Note that by default the limit for queries is 25 records: -#' tryCatch({ -#' modernSites <- get_sites(keyword = "Modern") -#' plotLeaflet(modernSites) -#' }, error = function(e) { -#' message("Neotoma server not responding. Try again later.") -#' }) +#' tryCatch( +#' { +#' modernSites <- get_sites(keyword = "Modern") +#' plotLeaflet(modernSites) +#' }, +#' error = function(e) { +#' message("Neotoma server not responding. Try again later.") +#' } +#' ) #' } #' @returns `leaflet` map #' @export -setMethod(f = "plotLeaflet", - signature = "sites", - definition = function(object) { - explorerURL <- "http://apps.neotomadb.org/explorer/" - df1 <- as.data.frame(object) - map1 <- leaflet(df1) %>% - addTiles() %>% - addCircleMarkers(lng = df1$long, - lat = df1$lat, - popup = paste0("", df1$sitename, - "
Description: ", - df1$description, - "
Explorer Link"), - clusterOptions = markerClusterOptions(), - options = markerOptions(riseOnHover = TRUE)) - return(map1) - }) +setMethod( + f = "plotLeaflet", + signature = "sites", + definition = function(object) { + explorer_url <- "http://apps.neotomadb.org/explorer/" + df1 <- as.data.frame(object) + map1 <- leaflet(df1) %>% + addTiles() %>% + addCircleMarkers( + lng = df1$long, + lat = df1$lat, + popup = paste0( + "", df1$sitename, + "
Description: ", + df1$description, + "
Explorer Link" + ), + clusterOptions = markerClusterOptions(), + options = markerOptions(riseOnHover = TRUE) + ) + map1 + } +) #' @rdname plotLeaflet -setMethod(f = "plotLeaflet", - signature = "site", - definition = function(object) { - explorerURL <- "http://apps.neotomadb.org/explorer/" - df1 <- as.data.frame(object) - map1 <- leaflet(df1) %>% - addTiles() %>% - addCircleMarkers(lng = df1$long, - lat = df1$lat, - popup = paste0("", df1$sitename, - "
Description: ", - df1$description, - "
Explorer Link"), - clusterOptions = markerClusterOptions(), - options = markerOptions(riseOnHover = TRUE)) - return(map1) - }) +setMethod( + f = "plotLeaflet", + signature = "site", + definition = function(object) { + explorer_url <- "http://apps.neotomadb.org/explorer/" + df1 <- as.data.frame(object) + map1 <- leaflet(df1) %>% + addTiles() %>% + addCircleMarkers( + lng = df1$long, + lat = df1$lat, + popup = paste0( + "", df1$sitename, + "
Description: ", + df1$description, + "
Explorer Link" + ), + clusterOptions = markerClusterOptions(), + options = markerOptions(riseOnHover = TRUE) + ) + map1 + } +) #' @rdname plotLeaflet -setMethod(f = "plotLeaflet", - signature = "ANY", - definition = function(object) { - if (is.null(object)) { - warning("No sites to plot") - return(NULL) - } - }) \ No newline at end of file +setMethod( + f = "plotLeaflet", + signature = "ANY", + definition = function(object) { + if (is.null(object)) { + warning("No sites to plot") + NULL + } + } +) diff --git a/R/pubAuthors.R b/R/pubAuthors.R index 81dbee0d..9629ee88 100644 --- a/R/pubAuthors.R +++ b/R/pubAuthors.R @@ -9,12 +9,15 @@ pubAuthors <- function(x) { x <- cleanNULL(x) result <- new("authors", - authors = map(x$author, function(y) { - new("author", - author = new("contact", - familyname = use_na(y$familyname, "char"), - givennames = use_na(y$givennames, "char")), - order = y$order) - })) - return(result) + authors = map(x$author, function(y) { + new("author", + author = new("contact", + familyname = use_na(y$familyname, "char"), + givennames = use_na(y$givennames, "char") + ), + order = y$order + ) + }) + ) + result } diff --git a/R/publication-methods.R b/R/publication-methods.R index 9f03751f..2a6fea87 100644 --- a/R/publication-methods.R +++ b/R/publication-methods.R @@ -1,164 +1,206 @@ #' @aliases names,publication-method #' @rdname names -setMethod(f = "names", - signature = signature(x = "publication"), - definition = function(x) { - slotNames("publication") - }) +setMethod( + f = "names", + signature = signature(x = "publication"), + definition = function(x) { + slotNames("publication") + } +) #' @aliases names,publications-method #' @rdname names -setMethod(f = "names", - signature = signature(x = "publications"), - definition = function(x) { - slotNames("publication") - }) +setMethod( + f = "names", + signature = signature(x = "publications"), + definition = function(x) { + slotNames("publication") + } +) #' @aliases show,publications-method #' @rdname show -setMethod(f = "show", - signature = signature(object = "publications"), - definition = function(object) { - map(object@publications, function(x) { - data.frame(publicationid = x@publicationid, - citation = x@citation, - doi = x@doi) - }) %>% - bind_rows() %>% - print() - }) +setMethod( + f = "show", + signature = signature(object = "publications"), + definition = function(object) { + map(object@publications, function(x) { + data.frame( + publicationid = x@publicationid, + citation = x@citation, + doi = x@doi + ) + }) %>% + bind_rows() %>% + print() + } +) #' @aliases cash,publication-method #' @rdname cash -setMethod(f = "$", - signature = signature(x = "publication"), - definition = function(x, name) { - slot(x, name) - }) +setMethod( + f = "$", + signature = signature(x = "publication"), + definition = function(x, name) { + slot(x, name) + } +) -#' @aliases sub-sub,publications-method [[,publications,numeric-method [[,publications,numeric,ANY-method +#' @aliases sub-sub,publications-method [[,publications,numeric-method +#' [[,publications,numeric,ANY-method #' @rdname sub-sub -setMethod(f = "[[", - signature = signature(x = "publications", i = "numeric"), - definition = function(x, i) { - if (length(i) == 1) { - out <- new("publication", x@publications[[i]]) - } else { - out <- map(i, function(z) { - new("publication", x@publications[[z]]) - }) - out <- new("publications", publications = out) - } - return(out) - }) +setMethod( + f = "[[", + signature = signature(x = "publications", i = "numeric"), + definition = function(x, i) { + if (length(i) == 1) { + out <- new("publication", x@publications[[i]]) + } else { + out <- map(i, function(z) { + new("publication", x@publications[[z]]) + }) + out <- new("publications", publications = out) + } + out + } +) -#' @aliases sub-subset,publications-method [[<-,publications-method [[<-,publications,ANY,ANY-method +#' @aliases sub-subset,publications-method [[<-,publications-method +#' [[<-,publications,ANY,ANY-method #' @rdname sub-subset -setMethod(f = "[[<-", - signature = signature(x = "publications"), - definition = function(x, i, value) { - if (length(i) == 1) { - x@publications[[i]] <- new("publication", value) - out <- x - return(out) - } else { - warning("You can only reassign one publication at a time.") - } - }) +setMethod( + f = "[[<-", + signature = signature(x = "publications"), + definition = function(x, i, value) { + if (length(i) == 1) { + x@publications[[i]] <- new("publication", value) + out <- x + out + } else { + warning("You can only reassign one publication at a time.") + } + } +) #' @aliases length,publications-method #' @rdname length -setMethod(f = "length", - signature = signature(x = "publications"), - definition = function(x) { - length(x@publications) - }) +setMethod( + f = "length", + signature = signature(x = "publications"), + definition = function(x) { + length(x@publications) + } +) #' @aliases c,publications-method #' @rdname c -setMethod(f = "c", - signature = signature(x = "publications"), - definition = function(x, y) { - new("publications", - publications = unlist(c(x@publications, - y@publications), - recursive = FALSE)) - }) +setMethod( + f = "c", + signature = signature(x = "publications"), + definition = function(x, y) { + new("publications", + publications = unlist( + c( + x@publications, + y@publications + ), + recursive = FALSE + ) + ) + } +) #' @aliases show,publication-method #' @rdname show -setMethod(f = "show", - signature = signature(object = "publication"), - definition = function(object) { - print(data.frame(publicationid = object@publicationid, - citation = object@citation, - doi = object@doi)) - }) +setMethod( + f = "show", + signature = signature(object = "publication"), + definition = function(object) { + print(data.frame( + publicationid = object@publicationid, + citation = object@citation, + doi = object@doi + )) + } +) #' @title Show matched publication objects. #' @param x A \code{publication} object. #' @returns NULL #' @noRd #' @keywords internal -setMethod(f = "showMatch", - signature = signature(x = "publication"), - definition = function(x) { - if (!is.null(attr(x, "matches"))) { - print(attr(x, "matches")) - } - }) +setMethod( + f = "showMatch", + signature = signature(x = "publication"), + definition = function(x) { + if (!is.null(attr(x, "matches"))) { + print(attr(x, "matches")) + } + } +) #' @aliases doi,publication-method #' @rdname doi -setMethod(f = "doi", - signature = signature(x = "publication"), - definition = function(x) { - x@doi - }) +setMethod( + f = "doi", + signature = signature(x = "publication"), + definition = function(x) { + x@doi + } +) #' @aliases as.data.frame,publication-method #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature(x = "authors"), - definition = function(x) { - authors <- x@authors %>% - map(function(y) { - paste0(y@author@familyname, ", ", - y@author@givennames) - }) %>% - paste0(collapse = "; ") - return(authors) - }) +setMethod( + f = "as.data.frame", + signature = signature(x = "authors"), + definition = function(x) { + authors <- x@authors %>% + map(function(y) { + paste0( + y@author@familyname, ", ", + y@author@givennames + ) + }) %>% + paste0(collapse = "; ") + authors + } +) #' @aliases as.data.frame,publication-method #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature(x = "publication"), - definition = function(x) { - slots <- slotNames(x) - slots <- slots[!slots == "author"] - table <- slots %>% - map(function(s) { - out <- data.frame(slot(x, s), - stringsAsFactors = FALSE) - colnames(out) <- s - return(out) - }) %>% - bind_cols() - table$authors <- as.data.frame(x@author) - return(table) - }) +setMethod( + f = "as.data.frame", + signature = signature(x = "publication"), + definition = function(x) { + slots <- slotNames(x) + slots <- slots[!slots == "author"] + table <- slots %>% + map(function(s) { + out <- data.frame(slot(x, s), + stringsAsFactors = FALSE + ) + colnames(out) <- s + out + }) %>% + bind_cols() + table$authors <- as.data.frame(x@author) + table + } +) #' @aliases as.data.frame,publication-method #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature(x = "publications"), - definition = function(x) { - full <- x@publications %>% - map(function(y) as.data.frame(y)) %>% - bind_rows() - return(full) - }) +setMethod( + f = "as.data.frame", + signature = signature(x = "publications"), + definition = function(x) { + full <- x@publications %>% + map(function(y) as.data.frame(y)) %>% + bind_rows() + full + } +) #' @title Select the best match (between a local record and a Neotoma match) #' @param x A \code{publication} object @@ -166,23 +208,27 @@ setMethod(f = "as.data.frame", #' @returns the best match to the selected publication. #' @noRd #' @keywords internal -setMethod(f = "selectMatch", - signature = signature(x = "publication", n = "numeric"), - definition = function(x, n) { - if (is.null(attr(x, "matches"))) { - stop("There are no existing matches.") - } else if (n > length(attr(x, "matches"))) { - stop("The requested match is not in the current list.") - } else if (n <= length(attr(x, "matches"))) { - return(attr(x, "matches")[[n]]) - } - }) +setMethod( + f = "selectMatch", + signature = signature(x = "publication", n = "numeric"), + definition = function(x, n) { + if (is.null(attr(x, "matches"))) { + stop("There are no existing matches.") + } else if (n > length(attr(x, "matches"))) { + stop("The requested match is not in the current list.") + } else if (n <= length(attr(x, "matches"))) { + attr(x, "matches")[[n]] + } + } +) #' @noRd #' @keywords internal -setMethod(f = "selectMatch", - signature = signature(x = "publication", n = "logical"), - definition = function(x, n) { - attr(x, "matches") <- NULL - return(x) - }) +setMethod( + f = "selectMatch", + signature = signature(x = "publication", n = "logical"), + definition = function(x, n) { + attr(x, "matches") <- NULL + x + } +) diff --git a/R/samples-methods.R b/R/samples-methods.R index 7b1145c8..19c21d27 100644 --- a/R/samples-methods.R +++ b/R/samples-methods.R @@ -1,77 +1,99 @@ -#' @aliases sub-sub,samples-method [[,samples,numeric-method [[,samples,numeric,ANY-method +#' @aliases sub-sub,samples-method [[,samples,numeric-method +#' [[,samples,numeric,ANY-method #' @rdname sub-sub -setMethod(f = "[[", - signature = signature(x = "samples", i = "numeric"), - definition = function(x, i) { - if (length(i) == 1) { - out <- new("sample", x@samples[[i]]) - } else { - out <- map(i, function(z) { - new("sample", x@samples[[z]]) - }) - out <- new("samples", samples = out) - } - return(out) - }) +setMethod( + f = "[[", + signature = signature(x = "samples", i = "numeric"), + definition = function(x, i) { + if (length(i) == 1) { + out <- new("sample", x@samples[[i]]) + } else { + out <- map(i, function(z) { + new("sample", x@samples[[z]]) + }) + out <- new("samples", samples = out) + } + out + } +) #' @aliases cash,samples-method #' @rdname cash -setMethod(f = "$", - signature = signature(x = "samples"), - definition = function(x, name) { - x %>% - map(function(y) { - slot(y, name) - }) %>% - unlist() - }) +setMethod( + f = "$", + signature = signature(x = "samples"), + definition = function(x, name) { + x %>% + map(function(y) { + slot(y, name) + }) %>% + unlist() + } +) #' @aliases cash,sample-method #' @rdname cash -setMethod(f = "$", - signature = signature(x = "sample"), - definition = function(x, name) { - slot(x, name) - }) +setMethod( + f = "$", + signature = signature(x = "sample"), + definition = function(x, name) { + slot(x, name) + } +) #' @aliases length,samples-method #' @rdname length -setMethod(f = "length", - signature = signature(x = "samples"), - definition = function(x) { - length(x@samples) - }) +setMethod( + f = "length", + signature = signature(x = "samples"), + definition = function(x) { + length(x@samples) + } +) #' @aliases c,samples-method #' @rdname c -setMethod(f = "c", - signature = signature(x = "samples"), - definition = function(x, y) { - samp <- new("samples", - samples = unlist(c(x@samples, - y@samples), - recursive = FALSE)) - return(samp) - }) +setMethod( + f = "c", + signature = signature(x = "samples"), + definition = function(x, y) { + samp <- new("samples", + samples = unlist( + c( + x@samples, + y@samples + ), + recursive = FALSE + ) + ) + samp + } +) -#' @aliases sub-subset,samples-method [[<-,samples-method [[<-,samples,ANY,ANY-method +#' @aliases sub-subset,samples-method [[<-,samples-method +#' [[<-,samples,ANY,ANY-method #' @rdname sub-subset -setMethod(f = "[[<-", - signature = signature(x = "samples"), - definition = function(x, i, value) { - samples <- x@samples - samples[[i]] <- value - out <- new("samples", sites = samples) - return(out) - }) +setMethod( + f = "[[<-", + signature = signature(x = "samples"), + definition = function(x, i, value) { + samples <- x@samples + samples[[i]] <- value + out <- new("samples", sites = samples) + out + } +) -#' @aliases subset,sample-method [<-,sample,character-method [<-,sample,character,ANY-method +#' @aliases subset,sample-method [<-,sample,character-method +#' [<-,sample,character,ANY-method #' @rdname subset -setMethod(f = "[<-", - signature = signature(x = "sample", i = "character"), - definition = function(x, i, value) { - for (idx in seq_along(length(i))) { - slot(x, i[idx]) <- value[idx] - } - return(x) - }) \ No newline at end of file +setMethod( + f = "[<-", + signature = signature(x = "sample", i = "character"), + definition = function(x, i, value) { + for (idx in seq_along(length(i))) { + slot(x, i[idx]) <- value[idx] + } + x + } +) diff --git a/R/samples.R b/R/samples.R index b118c0aa..6d87ae0f 100644 --- a/R/samples.R +++ b/R/samples.R @@ -17,13 +17,16 @@ #' @returns `data.frame` with sample records #' @md #' @export -setMethod(f = "samples", +setMethod( + f = "samples", signature = "sites", definition = function(x, chronname = NULL) { output <- map(x@sites, function(y) samples(y, chronname = chronname)) %>% + # nolint start bind_rows() # %>% - # Handle NAs to allow distinct to work properly - #distinct(.data$sampleid, .keep_all = TRUE) + # Handle NAs to allow distinct to work properly + # distinct(.data$sampleid, .keep_all = TRUE) + # nolint end if (nrow(output) == 0) { warnsite <- sprintf("No assigned samples. Did you run get_downloads()?") warning(warnsite) @@ -34,14 +37,17 @@ setMethod(f = "samples", #' @rdname samples #' @export -setMethod(f = "samples", +setMethod( + f = "samples", signature = "site", definition = function(x, chronname = NULL) { allids <- getids(x) siteinfo <- as.data.frame(x) %>% left_join(allids, by = "siteid") - sampset <- map(x@collunits@collunits, - function(y) samples(y, chronname = chronname)) %>% + sampset <- map( + x@collunits@collunits, + function(y) samples(y, chronname = chronname) + ) %>% bind_rows() %>% bind_rows() %>% left_join(siteinfo, by = "datasetid") %>% @@ -52,7 +58,8 @@ setMethod(f = "samples", #' @rdname samples #' @export -setMethod(f = "samples", +setMethod( + f = "samples", signature = "collunits", definition = function(x, chronname = NULL) { map(x@collunits, function(x) samples(x, chronname = chronname)) %>% @@ -62,7 +69,8 @@ setMethod(f = "samples", #' @rdname samples #' @export -setMethod(f = "samples", +setMethod( + f = "samples", signature = "collunit", definition = function(x, chronname = NULL) { # A collection unit with no datasets (e.g. its datasets were deleted @@ -73,9 +81,11 @@ setMethod(f = "samples", return(data.frame()) } chron_exists <- FALSE - precedence <- c("Calendar years BP", - "Calibrated radiocarbon years BP", - "Radiocarbon years BP", "Varve years BP") + precedence <- c( + "Calendar years BP", + "Calibrated radiocarbon years BP", + "Radiocarbon years BP", "Varve years BP" + ) ids <- getids(x) # Check the chronologies to make sure everything is okay: if (length(chronologies(x)) > 0) { @@ -83,18 +93,26 @@ setMethod(f = "samples", # age model precedence (see get_table('agetypes')). # It returns a value that is larger when your age reporting is # better. - defaultchron <- map(chronologies(x)@chronologies, - function(y) { - data.frame(chronologyid = y@chronologyid, - isdefault = y@isdefault, - modelagetype = y@modelagetype, - chronologyname = y@chronologyname, - dateprepared = y@dateprepared) - }) %>% + defaultchron <- map( + chronologies(x)@chronologies, + function(y) { + data.frame( + chronologyid = y@chronologyid, + isdefault = y@isdefault, + modelagetype = y@modelagetype, + chronologyname = y@chronologyname, + dateprepared = y@dateprepared + ) + } + ) %>% bind_rows() %>% - mutate(modelrank = match(.data$modelagetype, rev(precedence)), - order = .data$isdefault * match(.data$modelagetype, - rev(precedence))) + mutate( + modelrank = match(.data$modelagetype, rev(precedence)), + order = .data$isdefault * match( + .data$modelagetype, + rev(precedence) + ) + ) # Validation of default chrons, we want to check whether there # exists either multiple default chronologies for the same # time-frame or, alternately, no default chronology. @@ -107,103 +125,120 @@ setMethod(f = "samples", defaultchron$order[high_chron][newmax_order] <- max_order + 1 } else { newmax_order <- which.max(defaultchron$dateprepared[ - defaultchron$order == max_order]) + defaultchron$order == max_order + ]) defaultchron$order[defaultchron$order == max_order][ - newmax_order] <- max_order + 1 + newmax_order + ] <- max_order + 1 } } # Did the user request a chronology by name that actually exists here? chron_exists <- !is.null(chronname) && chronname %in% defaultchron$chronologyname if (all_na == TRUE) { - warnsite <- sprintf("The dataset %s has no default chronologies.", - ids$datasetid[1]) + warnsite <- sprintf( + "The dataset %s has no default chronologies.", + ids$datasetid[1] + ) warning(warnsite) } else if (chron_exists) { # The user explicitly requested a chronology and it is present. matches <- defaultchron$chronologyname == chronname if (sum(matches, na.rm = TRUE) > 1) { defaultchron <- defaultchron[matches, ][1, ] - warnsite <- sprintf("The dataset %s has multiple chronologies matching + warnsite <- sprintf( + "The dataset %s has multiple chronologies matching chronname %s. Chronology %s has been used.", - ids$datasetid[1], chronname, - defaultchron$chronologyid) + ids$datasetid[1], chronname, + defaultchron$chronologyid + ) warning(warnsite) } else { defaultchron <- defaultchron[matches, ] } } else if (sum(defaultchron$order == max_order, na.rm = TRUE) > 1) { - warnsite <- sprintf("The dataset %s has multiple default chronologies. + warnsite <- sprintf( + "The dataset %s has multiple default chronologies. Chronology %s has been used.", ids$datasetid[1], - defaultchron$chronologyid[ - which.max(defaultchron$order)]) + defaultchron$chronologyid[ + which.max(defaultchron$order) + ] + ) warning(warnsite) defaultchron <- defaultchron[which.max(defaultchron$order), ] } else { defaultchron <- defaultchron[which.max(defaultchron$order), ] if (!is.null(chronname)) { - warnsite <- sprintf("The dataset %s has no chronology matching + warnsite <- sprintf( + "The dataset %s has no chronology matching chronname %s. Default chronology %s has been used.", ids$datasetid[1], chronname, - defaultchron$chronologyid) + defaultchron$chronologyid + ) warning(warnsite) } } } else { defaultchron <- data.frame(chronologyid = NULL) } - sampset <- map(datasets(x)@datasets, - function(y) { - dsid <- y$datasetid - allsamp <- - map(y@samples@samples, - function(z) { - whichage <- - which(z@ages$chronologyid == - defaultchron$chronologyid) - if (length(whichage) == 0) { - # When a specific chronology was requested but is - # absent for this sample, report NA so the sample - # is dropped downstream; otherwise fall back to - # the first age row. - if (chron_exists) { - whichage <- NA - } else { - whichage <- 1 - } - } - if (dim(z@datum)[1] > 0) { - df <- - data.frame(z@ages[whichage,], - z@datum, - analysisunitid = z@analysisunitid, - sampleanalyst = - toString(unique(unlist( - z@sampleanalyst, - use.names = FALSE))), - sampleid = z@sampleid, - depth = z@depth, - thickness = z@thickness, - samplename = z@samplename, - row.names = NULL) - } else { - df <- data.frame() - } - return(df) - }) %>% - bind_rows() %>% - mutate(datasetid = dsid) - return(allsamp) - }) %>% + sampset <- map( + datasets(x)@datasets, + function(y) { + dsid <- y$datasetid + allsamp <- + map( + y@samples@samples, + function(z) { + whichage <- which( + z@ages$chronologyid == defaultchron$chronologyid + ) + if (length(whichage) == 0) { + # When a specific chronology was requested but is + # absent for this sample, report NA so the sample + # is dropped downstream; otherwise fall back to + # the first age row. + if (chron_exists) { + whichage <- NA + } else { + whichage <- 1 + } + } + if (dim(z@datum)[1] > 0) { + df <- + data.frame(z@ages[whichage, ], + z@datum, + analysisunitid = z@analysisunitid, + sampleanalyst = toString(unique(unlist( + z@sampleanalyst, + use.names = FALSE + ))), + sampleid = z@sampleid, + depth = z@depth, + thickness = z@thickness, + samplename = z@samplename, + row.names = NULL + ) + } else { + df <- data.frame() + } + df + } + ) %>% + bind_rows() %>% + mutate(datasetid = dsid) + allsamp + } + ) %>% bind_rows() %>% left_join(as.data.frame(datasets(x)), by = "datasetid") %>% rename(datasetnotes = .data$notes) # If a valid chronology was requested by name, drop samples that do not # carry that chronology (their ages were set to NA above). - if (!is.null(chronname) && - sum(defaultchron$chronologyname == chronname, na.rm = TRUE) != 0) { + named_chron <- !is.null(chronname) && + sum(defaultchron$chronologyname == chronname, na.rm = TRUE) != 0 + if (named_chron) { sampset <- sampset %>% dplyr::filter(!is.na(.data$chronologyid)) } return(sampset) } -) \ No newline at end of file +) diff --git a/R/set_chronology.R b/R/set_chronology.R index f0955066..6103dcc7 100644 --- a/R/set_chronology.R +++ b/R/set_chronology.R @@ -3,9 +3,9 @@ #' @author Simon Goring \email{goring@wisc.edu} #' @description Create a new chronology for a record. #' Within Neotoma all chronologies have unique numeric -#' identifiers. Within R, because of the need to use the +#' identifiers. Within R, because of the need to use the #' identifiers across objects, and because we want to avoid -#' conflicts between naming systems, a universally unique +#' conflicts between naming systems, a universally unique #' identifier (UUID) is created for the object ID. #' @importFrom methods is new slot<- #' @importFrom digest digest @@ -33,7 +33,7 @@ #' @param chroncontrols A data.frame containing the chronological controls #' for the age model. #' @description Function to create new chronology objects for -#' personal analysis. +#' personal analysis. #' The new object will not be uploaded to the database. #' @returns `chronology` object #' @md @@ -86,4 +86,4 @@ set_chronology <- function(x = NA, } return(x) } -} \ No newline at end of file +} diff --git a/R/set_collunit.R b/R/set_collunit.R index acd4a252..a06d5a5f 100644 --- a/R/set_collunit.R +++ b/R/set_collunit.R @@ -29,8 +29,8 @@ #' @export #' @md #' @examples { -#' # Create a collunit -#' my_collunit <- set_collunit(notes = "my lake") +#' # Create a collunit +#' my_collunit <- set_collunit(notes = "my lake") #' } set_collunit <- function(x = NA, collectionunitid = NA_integer_, @@ -86,4 +86,4 @@ set_collunit <- function(x = NA, } } return(x) -} \ No newline at end of file +} diff --git a/R/set_contact.R b/R/set_contact.R index 1ae8ed9c..c3a0ebd6 100644 --- a/R/set_contact.R +++ b/R/set_contact.R @@ -1,8 +1,8 @@ #' @title Set contact information for a new record. #' @description Create a new contact for a record. -#' Within Neotoma all chronologies have unique numeric identifiers. +#' Within Neotoma all chronologies have unique numeric identifiers. #' Within R, because of the need to use the indentifiers across objects, -#' and because we want to avoid conflicts between naming systems, a +#' and because we want to avoid conflicts between naming systems, a #' universally unique identifier (UUID) is created for the object ID.This is not #' to be updated to the database. #' @importFrom methods is new slot<- @@ -16,7 +16,8 @@ #' @param givennames Given or forenames of a person (e.g. #' \code{George Gaylord}). Initials with spaces are used if full #' given names are not known (e.g. \code{G. G}). -#' @param contactname Full name of a person (e.g. \code{George Gaylord Simpson}). +#' @param contactname Full name of a person (e.g. \code{George Gaylord +#' Simpson}). #' @param suffix Suffix of a person’s name (e.g. \code{Jr.}, \code{III}). #' @param ORCID A unique ORCID (see \url{https://orcid.org}). #' @param title A person’s title (e.g. \code{Dr.}, \code{Prof.}, @@ -88,4 +89,4 @@ set_contact <- function(x = NA, } } return(x) -} \ No newline at end of file +} diff --git a/R/set_dataset.R b/R/set_dataset.R index cb017c09..a79efcbe 100644 --- a/R/set_dataset.R +++ b/R/set_dataset.R @@ -18,14 +18,16 @@ #' @param pi_list pi list #' @param samples taxa objects #' @export -#' @description Function to create new `dataset` objects for personal analysis. +#' @description Function to create new `dataset` objects for personal analysis. #' The new object will not be uploaded to the database. #' @returns `dataset` object #' @examples { -#' # Create a dataset -#' my_dataset <- set_dataset(database = "EPD", -#' datasettype = "pollen", -#' notes = "my lake") +#' # Create a dataset +#' my_dataset <- set_dataset( +#' database = "EPD", +#' datasettype = "pollen", +#' notes = "my lake" +#' ) #' } set_dataset <- function(x = NA, datasetid = NA_integer_, @@ -63,7 +65,7 @@ set_dataset <- function(x = NA, x@samples <- samples } else { if (is(x, "dataset")) { - if(length(function_call)>2){ + if (length(function_call) > 2) { for (i in 3:length(function_call)) { slot(x, names(function_call)[[i]]) <- eval(function_call[[i]]) } @@ -76,4 +78,4 @@ set_dataset <- function(x = NA, } } return(x) -} \ No newline at end of file +} diff --git a/R/set_publication.R b/R/set_publication.R index c2ed7eca..012f5454 100644 --- a/R/set_publication.R +++ b/R/set_publication.R @@ -34,33 +34,34 @@ #' @md #' @export set_publication <- function( - x = NA, - publicationid = NA_integer_, - publicationtypeid = NA_integer_, - publicationtype = NA_character_, - year = NA_character_, - citation = NA_character_, - articletitle = NA_character_, - journal = NA_character_, - volume = NA_character_, - issue = NA_character_, - pages = NA_character_, - citationnumber = NA_character_, - doi = NA_character_, - booktitle = NA_character_, - numvolumes = NA_character_, - edition = NA_character_, - volumetitle = NA_character_, - seriestitle = NA_character_, - seriesvolume = NA_character_, - publisher = NA_character_, - url = NA_character_, - city = NA_character_, - state = NA_character_, - country = NA_character_, - originallanguage = NA_character_, - notes = NA_character_, - author = NULL) { + x = NA, + publicationid = NA_integer_, + publicationtypeid = NA_integer_, + publicationtype = NA_character_, + year = NA_character_, + citation = NA_character_, + articletitle = NA_character_, + journal = NA_character_, + volume = NA_character_, + issue = NA_character_, + pages = NA_character_, + citationnumber = NA_character_, + doi = NA_character_, + booktitle = NA_character_, + numvolumes = NA_character_, + edition = NA_character_, + volumetitle = NA_character_, + seriestitle = NA_character_, + seriesvolume = NA_character_, + publisher = NA_character_, + url = NA_character_, + city = NA_character_, + state = NA_character_, + country = NA_character_, + originallanguage = NA_character_, + notes = NA_character_, + author = NULL +) { if (suppressWarnings(is.na(x))) { x <- new("publication") if (is.na(publicationid)) { @@ -102,4 +103,4 @@ set_publication <- function( x@notes <- as.character(notes) x@author <- author return(x) -} \ No newline at end of file +} diff --git a/R/set_sample.R b/R/set_sample.R index 6264f1d8..e4089cb7 100644 --- a/R/set_sample.R +++ b/R/set_sample.R @@ -15,13 +15,13 @@ #' @param analysisunitid Which analysis unit it is #' @param analysisunitname Analysis Unit's name #' @returns `sample` object -#' @description Function to create new samples objects for analysis. +#' @description Function to create new samples objects for analysis. #' The new object will not be uploaded to the database. #' @export #' @md #' @examples { -#' # Set an empty sample -#' my_sample <- set_sample() +#' # Set an empty sample +#' my_sample <- set_sample() #' } set_sample <- function(x = NA, ages = list(), @@ -33,7 +33,7 @@ set_sample <- function(x = NA, samplename = NA_character_, sampleanalyst = list(), analysisunitid = NA_integer_, - analysisunitname = NA_character_){ + analysisunitname = NA_character_) { function_call <- match.call() if (suppressWarnings(is.na(x))) { x <- new("sample") @@ -67,4 +67,4 @@ set_sample <- function(x = NA, } } return(x) -} \ No newline at end of file +} diff --git a/R/set_server.R b/R/set_server.R index ff0e2a1f..3e3c2cfa 100644 --- a/R/set_server.R +++ b/R/set_server.R @@ -17,12 +17,14 @@ #' @export set_server <- function(server = "neotoma") { assert_that(server %in% c("neotoma", "dev", "local"), - msg = "The parameter `server` must be `local`, - `neotoma` or `dev`.") + msg = "The parameter `server` must be `local`, + `neotoma` or `dev`." + ) server <- switch(server, - neotoma = "neotoma", - dev = "dev", - local = "local") + neotoma = "neotoma", + dev = "dev", + local = "local" + ) Sys.setenv("APIPOINT" = server) } diff --git a/R/set_site.R b/R/set_site.R index 08c02239..d9902430 100644 --- a/R/set_site.R +++ b/R/set_site.R @@ -20,12 +20,14 @@ #' @param collunits Collection units in the site #' @returns `site` object #' @examples { -#' # Create a site called "My Lake", to -#' x <- sf::st_as_sf(sf::st_sfc(sf::st_point(c(5,5)))) -#' my_site <- set_site(sitename = "My Lake", -#' geography = x, -#' description = "my lake", -#' altitude = 30) +#' # Create a site called "My Lake", to +#' x <- sf::st_as_sf(sf::st_sfc(sf::st_point(c(5, 5)))) +#' my_site <- set_site( +#' sitename = "My Lake", +#' geography = x, +#' description = "my lake", +#' altitude = 30 +#' ) #' } #' @md #' @export @@ -70,4 +72,4 @@ set_site <- function(x = NA, } } return(x) -} \ No newline at end of file +} diff --git a/R/set_speleothem.R b/R/set_speleothem.R index 8aa918a8..c6a186bb 100644 --- a/R/set_speleothem.R +++ b/R/set_speleothem.R @@ -44,7 +44,7 @@ set_speleothem <- function(x = NA, vegetationcovertype = NA_character_, entitycoverthickness = NA_integer_, entrancedistanceunits = NA_character_, - vegetationcoverpercent = NA_integer_){ + vegetationcoverpercent = NA_integer_) { function_call <- match.call() if (suppressWarnings(is.na(x))) { x <- new("speleothem") @@ -87,4 +87,4 @@ set_speleothem <- function(x = NA, } } return(x) -} \ No newline at end of file +} diff --git a/R/site-methods.R b/R/site-methods.R index 316b68fe..54c8de2d 100644 --- a/R/site-methods.R +++ b/R/site-methods.R @@ -10,35 +10,41 @@ setClassUnion("sitesOrsite", c("site", "sites")) #' @returns NULL #' @aliases show,site-method #' @importMethodsFrom methods show -setMethod(f = "show", - signature = "site", - definition = function(object) { - print(data.frame(siteid = object@siteid, - sitename = object@sitename, - lat = mean(st_coordinates(object@geography)[, 2]), - long = mean(st_coordinates(object@geography)[, 1]), - altitude = object@altitude), row.names = FALSE) %>% - unique() - }) +setMethod( + f = "show", + signature = "site", + definition = function(object) { + print(data.frame( + siteid = object@siteid, + sitename = object@sitename, + lat = mean(st_coordinates(object@geography)[, 2]), + long = mean(st_coordinates(object@geography)[, 1]), + altitude = object@altitude + ), row.names = FALSE) %>% + unique() + } +) #' @aliases show,sites-method #' @rdname show -setMethod(f = "show", - signature = "sites", - definition = function(object) { - map(object@sites, function(x) { - data.frame( - siteid = x@siteid, - sitename = x@sitename, - lat = mean(st_coordinates(x@geography)[, 2]), - long = mean(st_coordinates(x@geography)[, 1]), - altitude = x@altitude - ) - }) %>% - bind_rows() %>% - unique() %>% - print(row.names = FALSE) - }) +setMethod( + f = "show", + signature = "sites", + definition = function(object) { + map(object@sites, function(x) { + data.frame( + siteid = x@siteid, + sitename = x@sitename, + lat = mean(st_coordinates(x@geography)[, 2]), + long = mean(st_coordinates(x@geography)[, 1]), + altitude = x@altitude + ) + }) %>% + bind_rows() %>% + unique() %>% + print(row.names = FALSE) + } +) #' @title sub-sub #' @name sub-sub @@ -49,24 +55,26 @@ setMethod(f = "show", #' `collectionunits`, `datasets`, etc... Neotoma objects. #' @returns sliced `site` object #' @examples \dontrun{ -#' some_site <- get_sites(sitename = "Site%", limit=3) +#' some_site <- get_sites(sitename = "Site%", limit = 3) #' some_site[[2]] #' } #' @aliases [[,sites,numeric-method [[,sites,numeric,ANY-method #' @exportMethod [[ -setMethod(f = "[[", - signature = signature(x = "sites", i = "numeric"), - definition = function(x, i) { - if (length(i) == 1) { - out <- new("site", x@sites[[i]]) - } else { - out <- map(i, function(z) { - new("site", x@sites[[z]]) - }) - out <- new("sites", sites = out) - } - return(out) - }) +setMethod( + f = "[[", + signature = signature(x = "sites", i = "numeric"), + definition = function(x, i) { + if (length(i) == 1) { + out <- new("site", x@sites[[i]]) + } else { + out <- map(i, function(z) { + new("site", x@sites[[z]]) + }) + out <- new("sites", sites = out) + } + out + } +) #' @title sub #' @name [ @@ -76,30 +84,36 @@ setMethod(f = "[[", #' @md #' @aliases [,sites,numeric-method [,sites,numeric,ANY-method #' @exportMethod [ -setMethod(f = "[", - signature = signature(x = "sites", i = "numeric"), - definition = function(x, i) { - new("sites", sites = x@sites[i]) - }) +setMethod( + f = "[", + signature = signature(x = "sites", i = "numeric"), + definition = function(x, i) { + new("sites", sites = x@sites[i]) + } +) #' @aliases [,site,numeric-method [,site,numeric,ANY-method #' @rdname sub -setMethod(f = "[", - signature = signature(x = "site", i = "numeric"), - definition = function(x, i) { - slots <- slotNames(x)[i] - as.data.frame(sapply(slots, function(y) slot(x, y))) - }) +setMethod( + f = "[", + signature = signature(x = "site", i = "numeric"), + definition = function(x, i) { + slots <- slotNames(x)[i] + as.data.frame(sapply(slots, function(y) slot(x, y))) + } +) #' @aliases [,site,character-method [,site,character,ANY-method #' @rdname sub -setMethod(f = "[", - signature = signature(x = "site", i = "character"), - definition = function(x, i) { - out <- as.data.frame(lapply(i, function(y) slot(x, y))) - colnames(out) <- i - return(out) - }) +setMethod( + f = "[", + signature = signature(x = "site", i = "character"), + definition = function(x, i) { + out <- as.data.frame(lapply(i, function(y) slot(x, y))) + colnames(out) <- i + out + } +) #' @title Get a `neotoma2` object's slot names #' @name names @@ -109,19 +123,23 @@ setMethod(f = "[", #' @md #' @aliases names,site-method #' @exportMethod names -setMethod(f = "names", - signature = signature(x = "site"), - definition = function(x) { - slotNames(x) - }) +setMethod( + f = "names", + signature = signature(x = "site"), + definition = function(x) { + slotNames(x) + } +) #' @aliases names,sites-method #' @rdname names -setMethod(f = "names", - signature = signature(x = "sites"), - definition = function(x) { - slotNames("site") - }) +setMethod( + f = "names", + signature = signature(x = "sites"), + definition = function(x) { + slotNames("site") + } +) #' @title sub-subset #' @name sub-subset @@ -133,14 +151,16 @@ setMethod(f = "names", #' @md #' @aliases [[<-,sites-method [[<-,sites,ANY,ANY-method #' @exportMethod [[<- -setMethod(f = "[[<-", - signature = signature(x = "sites"), - definition = function(x, i, value) { - siteset <- x@sites - siteset[[i]] <- value - out <- new("sites", sites = siteset) - return(out) - }) +setMethod( + f = "[[<-", + signature = signature(x = "sites"), + definition = function(x, i, value) { + siteset <- x@sites + siteset[[i]] <- value + out <- new("sites", sites = siteset) + out + } +) #' @title subset #' @name subset @@ -151,26 +171,30 @@ setMethod(f = "[[<-", #' @md #' @aliases [<-,site,character-method [<-,site,character,ANY-method #' @exportMethod [<- -setMethod(f = "[<-", - signature = signature(x = "site", i = "character"), - definition = function(x, i, value) { - for (idx in seq_along(length(i))) { - slot(x, i[idx]) <- value[idx] - } - return(x) - }) +setMethod( + f = "[<-", + signature = signature(x = "site", i = "character"), + definition = function(x, i, value) { + for (idx in seq_along(length(i))) { + slot(x, i[idx]) <- value[idx] + } + x + } +) #' @aliases [<-,site,numeric-method [<-,site,numeric,ANY-method #' @rdname subset -setMethod(f = "[<-", - signature = signature(x = "site", i = "numeric"), - definition = function(x, i, value) { - slots <- slotNames(x) - for (idx in seq_along(length(i))) { - slot(x, slots[i[idx]]) <- value[idx] - } - return(x) - }) +setMethod( + f = "[<-", + signature = signature(x = "site", i = "numeric"), + definition = function(x, i, value) { + slots <- slotNames(x) + for (idx in seq_along(length(i))) { + slot(x, slots[i[idx]]) <- value[idx] + } + x + } +) #' @title cash-set #' @name cash-set @@ -181,12 +205,14 @@ setMethod(f = "[<-", #' @md #' @aliases $<-,site-method #' @exportMethod $<- -setMethod(f = "$<-", - signature = signature(x = "site"), - definition = function(x, name, value) { - slot(x, name) <- value - return(x) - }) +setMethod( + f = "$<-", + signature = signature(x = "site"), + definition = function(x, name, value) { + slot(x, name) <- value + x + } +) #' @title cash #' @name cash @@ -197,21 +223,25 @@ setMethod(f = "$<-", #' @md #' @aliases $,site-method #' @exportMethod $ -setMethod(f = "$", - signature = signature(x = "site"), - definition = function(x, name) { - slot(x, name) - }) +setMethod( + f = "$", + signature = signature(x = "site"), + definition = function(x, name) { + slot(x, name) + } +) #' @aliases $,sites-method #' @rdname cash -setMethod(f = "$", - signature = signature(x = "sites"), - definition = function(x, name) { - vals <- lapply(x@sites, function(y) slot(y, name)) - out <- unlist(vals, recursive = FALSE) - return(out) - }) +setMethod( + f = "$", + signature = signature(x = "sites"), + definition = function(x, name) { + vals <- lapply(x@sites, function(y) slot(y, name)) + out <- unlist(vals, recursive = FALSE) + out + } +) #' @title as.data.frame #' @name as.data.frame @@ -223,36 +253,46 @@ setMethod(f = "$", #' @md #' @aliases as.data.frame,site-method #' @exportMethod as.data.frame -setMethod(f = "as.data.frame", - signature = signature("site"), - definition = function(x) { - data.frame(siteid = x@siteid, - sitename = x@sitename, - lat = mean(st_coordinates(x@geography)[, 2]), - long = mean(st_coordinates(x@geography)[, 1]), - area = x@area, - notes = x@notes, - description = x@description, - elev = x@altitude) - }) +setMethod( + f = "as.data.frame", + signature = signature("site"), + definition = function(x) { + data.frame( + siteid = x@siteid, + sitename = x@sitename, + lat = mean(st_coordinates(x@geography)[, 2]), + long = mean(st_coordinates(x@geography)[, 1]), + area = x@area, + notes = x@notes, + description = x@description, + elev = x@altitude + ) + } +) #' @aliases as.data.frame,sites-method #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature("sites"), - definition = function(x) { - x@sites %>% map(as.data.frame) %>% bind_rows() #%>% unique() - }) +setMethod( + f = "as.data.frame", + signature = signature("sites"), + definition = function(x) { + x@sites %>% + map(as.data.frame) %>% + bind_rows() # %>% unique() + } +) #' @title as.list sites #' @param x sites object #' @returns `list` object with sites #' @noRd -setMethod(f = "as.list", - signature = signature("sites"), - definition = function(x) { - as.list(x@sites) - }) +setMethod( + f = "as.list", + signature = signature("sites"), + definition = function(x) { + as.list(x@sites) + } +) #' @title length #' @name length @@ -261,11 +301,13 @@ setMethod(f = "as.list", #' @md #' @aliases length,sites-method #' @exportMethod length -setMethod(f = "length", - signature = signature(x = "sites"), - definition = function(x) { - length(x@sites) - }) +setMethod( + f = "length", + signature = signature(x = "sites"), + definition = function(x) { + length(x@sites) + } +) #' @title c - Combine `neotoma2` objects #' @name c @@ -277,30 +319,33 @@ setMethod(f = "length", #' @rdname c #' @aliases c,sites-method #' @exportMethod c -setMethod(f = "c", - signature = "sites", - definition = function(x, y) { - if (is(y, "sites")) { - x@sites <- unlist(c(x@sites, y@sites), recursive = FALSE) - } else if (is(y, "site")) { - x@sites <- c(x@sites, y) - } - x <- clean(x) - if (length(x) == 0){ - x <- NULL - } else { - x <- new("sites", sites = x@sites) - } - return(x) - } +setMethod( + f = "c", + signature = "sites", + definition = function(x, y) { + if (is(y, "sites")) { + x@sites <- unlist(c(x@sites, y@sites), recursive = FALSE) + } else if (is(y, "site")) { + x@sites <- c(x@sites, y) + } + x <- clean(x) + if (length(x) == 0) { + x <- NULL + } else { + x <- new("sites", sites = x@sites) + } + x + } ) #' @rdname c -setMethod(f = "c", - signature = "missingOrNULL", - definition = function(x = "missingORNULL", y) { - y - }) +setMethod( + f = "c", + signature = "missingOrNULL", + definition = function(x = "missingORNULL", y) { + y + } +) #' @title Return the latitude and longitude of sites #' @param obj A sites object @@ -308,12 +353,14 @@ setMethod(f = "c", #' @returns `data.frame` object with site coordinates. #' @aliases coordinates,sites-method #' @exportMethod coordinates -setMethod(f = "coordinates", - signature = "sites", - definition = function(obj, ...) { - coords <- as.data.frame(obj)[, c("siteid", "long", "lat")] - return(coords) - }) +setMethod( + f = "coordinates", + signature = "sites", + definition = function(obj, ...) { + coords <- as.data.frame(obj)[, c("siteid", "long", "lat")] + coords + } +) #' @title Plot site coordinates using a basic plot. #' @name plot @@ -323,21 +370,25 @@ setMethod(f = "coordinates", #' @returns `plot` object with site coordinates. #' @aliases plot,sites-method plot,sites,ANY-method #' @exportMethod plot -setMethod(f = "plot", - signature = "sites", - definition = function(x, y, ...) { - coords <- as.data.frame(x)[, c("long", "lat")] - plot(coords, ...) - }) +setMethod( + f = "plot", + signature = "sites", + definition = function(x, y, ...) { + coords <- as.data.frame(x)[, c("long", "lat")] + plot(coords, ...) + } +) #' @aliases plot,site-method plot,site,ANY-method #' @rdname plot -setMethod(f = "plot", - signature = "site", - definition = function(x, y, ...) { - coords <- as.data.frame(x)[, c("long", "lat")] - plot(coords, ...) - }) +setMethod( + f = "plot", + signature = "site", + definition = function(x, y, ...) { + coords <- as.data.frame(x)[, c("long", "lat")] + plot(coords, ...) + } +) #' @title Summary of objects within a sites object. #' @param object sites object @@ -350,58 +401,72 @@ setMethod(f = "plot", #' @returns `data.frame` object with site summary information #' @aliases summary,sites-method #' @exportMethod summary -setMethod(f = "summary", - signature = "sites", - definition = function(object, ...) { - datasettype <- lapply(object@sites, function(x) { - # `collunits` is an optional slot, and a site returned by - # get_sites() may hold collection units that carry no datasets - # yet. Either way the site still gets one row, so that summary() - # always accounts for every site it was given. - units <- if (is.null(x@collunits)) { - list() - } else { - x@collunits@collunits - } - collunits <- lapply(units, - function(y) { - chrons <- length(y@chronologies) - datasets <- length(y@datasets) - if (datasets > 0) { - types <- sapply(y@datasets@datasets, - function(r) { - r@datasettype - }) %>% - paste0(collapse = ",") - } else { - types <- NA - } - data.frame(collectionunit = y@handle, - chronologies = chrons, - datasets = datasets, - types = types) - }) %>% - bind_rows() - if (nrow(collunits) > 0) { - collunits <- na.omit(collunits) - } - if (nrow(collunits) == 0) { - collunits <- data.frame(collectionunit = NA_character_, - chronologies = 0, - datasets = 0, - types = NA_character_) +setMethod( + f = "summary", + signature = "sites", + definition = function(object, ...) { + datasettype <- lapply(object@sites, function(x) { + # `collunits` is an optional slot, and a site returned by + # get_sites() may hold collection units that carry no datasets + # yet. Either way the site still gets one row, so that summary() + # always accounts for every site it was given. + units <- if (is.null(x@collunits)) { + list() + } else { + x@collunits@collunits + } + collunits <- lapply( + units, + function(y) { + chrons <- length(y@chronologies) + datasets <- length(y@datasets) + if (datasets > 0) { + types <- sapply( + y@datasets@datasets, + function(r) { + r@datasettype } - data.frame(siteid = x$siteid, - sitename = x$sitename, - collunits = collunits) - }) %>% - bind_rows() %>% - rename(collunit_name = .data$collunits.collectionunit, - n_chronologies = .data$collunits.chronologies, - n_datasets = .data$collunits.datasets, - dataset_types = .data$collunits.types) - return(datasettype) - }) + ) %>% + paste0(collapse = ",") + } else { + types <- NA + } + data.frame( + collectionunit = y@handle, + chronologies = chrons, + datasets = datasets, + types = types + ) + } + ) %>% + bind_rows() + if (nrow(collunits) > 0) { + collunits <- na.omit(collunits) + } + if (nrow(collunits) == 0) { + collunits <- data.frame( + collectionunit = NA_character_, + chronologies = 0, + datasets = 0, + types = NA_character_ + ) + } + data.frame( + siteid = x$siteid, + sitename = x$sitename, + collunits = collunits + ) + }) %>% + bind_rows() %>% + rename( + collunit_name = .data$collunits.collectionunit, + n_chronologies = .data$collunits.chronologies, + n_datasets = .data$collunits.datasets, + dataset_types = .data$collunits.types + ) + datasettype + } +) #' @title Obtain dataset DOIs from records. #' @description Given complete dataset objects in Neotoma (must have used @@ -409,7 +474,7 @@ setMethod(f = "summary", #' DOI for the record. #' @param x a Neotoma2 \code{site} object #' @importFrom purrr map -#' @importFrom dplyr bind_rows full_join select arrange filter +#' @importFrom dplyr bind_rows full_join select arrange filter #' @importFrom dplyr mutate group_by row_number #' @returns `data.frame` object with DOIs information. #' @examples \dontrun{ @@ -419,40 +484,50 @@ setMethod(f = "summary", #' } #' @aliases doi,sites-method #' @exportMethod doi -setMethod(f = "doi", - signature = "sites", - definition = function(x) { - map(x@sites, function(y) { - doi(y) - }) %>% - bind_rows() - }) +setMethod( + f = "doi", + signature = "sites", + definition = function(x) { + map(x@sites, function(y) { + doi(y) + }) %>% + bind_rows() + } +) #' @aliases doi,site-method #' @rdname doi -setMethod(f = "doi", - signature = "site", - definition = function(x) { - ids <- getids(x) - ds <- get_datasets(x) - dois <- - map(datasets(ds)@datasets, - function(x) { - doi <- x@doi - doi <- unlist(doi, recursive = TRUE, use.names = FALSE) - doi <- use_na(testNull(doi), "char") - data.frame(datasetid = rep(x$datasetid, length(doi)), - doi = doi) - }) %>% - bind_rows() - - dois <- dois %>% - full_join(ids, by = "datasetid") %>% - select(.data$siteid, .data$collunitid, - .data$datasetid, .data$doi) %>% - arrange(.data$siteid, .data$collunitid, .data$datasetid) - return(dois) - }) +setMethod( + f = "doi", + signature = "site", + definition = function(x) { + ids <- getids(x) + ds <- get_datasets(x) + dois <- + map( + datasets(ds)@datasets, + function(x) { + doi <- x@doi + doi <- unlist(doi, recursive = TRUE, use.names = FALSE) + doi <- use_na(testNull(doi), "char") + data.frame( + datasetid = rep(x$datasetid, length(doi)), + doi = doi + ) + } + ) %>% + bind_rows() + + dois <- dois %>% + full_join(ids, by = "datasetid") %>% + select( + .data$siteid, .data$collunitid, + .data$datasetid, .data$doi + ) %>% + arrange(.data$siteid, .data$collunitid, .data$datasetid) + dois + } +) #' @title Obtain data citations from multiple records. #' @description Given complete dataset objects in Neotoma (must have used @@ -468,89 +543,110 @@ setMethod(f = "doi", #' } #' @aliases cite_data,sites-method #' @exportMethod cite_data -setMethod(f = "cite_data", - signature = "sites", - definition = function(x) { - map(x@sites, - function(y) { - cite_data(y) - }) %>% - bind_rows() - }) +setMethod( + f = "cite_data", + signature = "sites", + definition = function(x) { + map( + x@sites, + function(y) { + cite_data(y) + } + ) %>% + bind_rows() + } +) #' @aliases cite_data,site-method #' @rdname cite_data -setMethod(f = "cite_data", - signature = "site", - definition = function(x) { - if (is.null(x)) { - warning("No sites to filter") - return(NULL) - } - strn <- paste0("%s. %s; %s dataset. ", - "In %s. Neotoma Paleoecology Database. doi:%s") - ids <- getids(x) - sitenames <- as.data.frame(x) %>% - select(.data$siteid, .data$sitename) - ds <- get_datasets(x) - ds_df <- as.data.frame(datasets(ds)) %>% - select(.data$datasetid, - .data$datasettype, - .data$database) - dois <- - map(datasets(ds)@datasets, - function(x) { - doi <- x@doi - doi <- unlist(doi, recursive = TRUE, use.names = FALSE) - doi <- use_na(testNull(doi), "char") - pi_list <- testNull(unlist(x@pi_list)) - data.frame(datasetid = rep(x$datasetid, length(doi)), - doi = doi, - pi_list = rep(paste0(sort(pi_list), - collapse = "; "), - length(doi))) - }) %>% - bind_rows() - - citations <- dois %>% - full_join(ids, by = "datasetid") %>% - full_join(sitenames, by = "siteid") %>% - full_join(ds_df, by = "datasetid") %>% - select(.data$siteid, .data$sitename, .data$collunitid, - .data$datasetid, .data$datasettype, .data$database, - .data$doi, .data$pi_list) %>% - group_by(.data$siteid, .data$collunitid, .data$datasetid) %>% - arrange(.data$doi) %>% - dplyr::filter(row_number() == 1) %>% - as.data.frame() %>% - mutate(citation = sprintf(strn, .data$pi_list, - .data$sitename, .data$datasettype, - .data$database, .data$doi)) %>% - select(.data$datasetid, .data$citation) - return(citations) - }) +setMethod( + f = "cite_data", + signature = "site", + definition = function(x) { + if (is.null(x)) { + warning("No sites to filter") + return(NULL) + } + strn <- paste0( + "%s. %s; %s dataset. ", + "In %s. Neotoma Paleoecology Database. doi:%s" + ) + ids <- getids(x) + sitenames <- as.data.frame(x) %>% + select(.data$siteid, .data$sitename) + ds <- get_datasets(x) + ds_df <- as.data.frame(datasets(ds)) %>% + select( + .data$datasetid, + .data$datasettype, + .data$database + ) + dois <- + map( + datasets(ds)@datasets, + function(x) { + doi <- x@doi + doi <- unlist(doi, recursive = TRUE, use.names = FALSE) + doi <- use_na(testNull(doi), "char") + pi_list <- testNull(unlist(x@pi_list)) + data.frame( + datasetid = rep(x$datasetid, length(doi)), + doi = doi, + pi_list = rep( + paste0(sort(pi_list), + collapse = "; " + ), + length(doi) + ) + ) + } + ) %>% + bind_rows() + + citations <- dois %>% + full_join(ids, by = "datasetid") %>% + full_join(sitenames, by = "siteid") %>% + full_join(ds_df, by = "datasetid") %>% + select( + .data$siteid, .data$sitename, .data$collunitid, + .data$datasetid, .data$datasettype, .data$database, + .data$doi, .data$pi_list + ) %>% + group_by(.data$siteid, .data$collunitid, .data$datasetid) %>% + arrange(.data$doi) %>% + dplyr::filter(row_number() == 1) %>% + as.data.frame() %>% + mutate(citation = sprintf( + strn, .data$pi_list, + .data$sitename, .data$datasettype, + .data$database, .data$doi + )) %>% + select(.data$datasetid, .data$citation) + citations + } +) #' @aliases cite_data,NULL-method #' @rdname cite_data -setMethod(f = "cite_data", - signature = "NULL", - definition = function(x) { - if (is.null(x)) { - warning("No sites to cite.") - return(NULL) - } - }) +setMethod( + f = "cite_data", + signature = "NULL", + definition = function(x) { + if (is.null(x)) { + warning("No sites to cite.") + NULL + } + } +) #' @rdname count setMethod( "count", "sites", function(x, level = c("sites", "collunits", "datasets")) { - level <- match.arg(level) - - switch( - level, + + switch(level, sites = length(x@sites), collunits = { ids <- unlist( @@ -561,21 +657,31 @@ setMethod( site@collunits@collunits, function(cu) cu@collectionunitid, integer(1) - )})) - length(unique(ids))}, + ) + } + ) + ) + length(unique(ids)) + }, datasets = { ids <- unlist( - lapply(x@sites,function(site) { - unlist(lapply( - site@collunits@collunits, - function(cu) { - vapply(cu@datasets@datasets, - function(ds) ds@datasetid, - integer(1) - )}))})) + lapply(x@sites, function(site) { + unlist(lapply( + site@collunits@collunits, + function(cu) { + vapply( + cu@datasets@datasets, + function(ds) ds@datasetid, + integer(1) + ) + } + )) + }) + ) length(unique(ids)) } - )} + ) + } ) #' @rdname count @@ -583,24 +689,19 @@ setMethod( "count", "site", function(x, level = c("sites", "collunits", "datasets")) { - level <- match.arg(level) - - switch( - level, - + + switch(level, sites = 1L, - collunits = { ids <- vapply( x@collunits@collunits, function(cu) cu@collectionunitid, integer(1) ) - + length(unique(ids)) }, - datasets = { ids <- unlist( lapply( @@ -614,9 +715,9 @@ setMethod( } ) ) - + length(unique(ids)) } ) } -) \ No newline at end of file +) diff --git a/R/speleothem-methods.R b/R/speleothem-methods.R index 8ff7a5e4..32d3017f 100644 --- a/R/speleothem-methods.R +++ b/R/speleothem-methods.R @@ -1,204 +1,251 @@ #' @aliases show,speleothem-method #' @rdname show -setMethod(f = "show", - signature = "speleothem", - definition = function(object) { - print(data.frame(entityid = object@entityid, - entityname = object@entityname, - siteid = object@siteid, - collectionunitid = object@collectionunitid, - speleothemdriptype = object@speleothemdriptype, - dripheight = object@dripheight, - dripheightunits = object@dripheightunits, - monitoring = object@monitoring, - geology = object@geology, - rockage = object@rockage, - speleothemtype = object@speleothemtype, - entrancedistance = object@entrancedistance, - entrancedistanceunits = object@entrancedistanceunits, - landusecovertype = object@landusecovertype, - landusecoverpercent = object@landusecoverpercent, - vegetationcovertype = object@vegetationcovertype, - vegetationcoverpercent = object@vegetationcoverpercent, - entitycovertype = object@entitycovertype, - entitycoverthickness = object@entitycoverthickness - ), row.names = FALSE) - }) +setMethod( + f = "show", + signature = "speleothem", + definition = function(object) { + print(data.frame( + entityid = object@entityid, + entityname = object@entityname, + siteid = object@siteid, + collectionunitid = object@collectionunitid, + speleothemdriptype = object@speleothemdriptype, + dripheight = object@dripheight, + dripheightunits = object@dripheightunits, + monitoring = object@monitoring, + geology = object@geology, + rockage = object@rockage, + speleothemtype = object@speleothemtype, + entrancedistance = object@entrancedistance, + entrancedistanceunits = object@entrancedistanceunits, + landusecovertype = object@landusecovertype, + landusecoverpercent = object@landusecoverpercent, + vegetationcovertype = object@vegetationcovertype, + vegetationcoverpercent = object@vegetationcoverpercent, + entitycovertype = object@entitycovertype, + entitycoverthickness = object@entitycoverthickness + ), row.names = FALSE) + } +) #' @aliases show,speleothems-method #' @rdname show -setMethod(f = "show", - signature = "speleothems", - definition = function(object) { - map(object, function(y) { - data.frame(entityid = y@entityid, - entityname = y@entityname, - siteid = y@siteid, - collectionunitid = y@collectionunitid, - speleothemdriptype = y@speleothemdriptype, - dripheight = y@dripheight, - dripheightunits = y@dripheightunits, - monitoring = y@monitoring, - geology = y@geology, - rockage = y@rockage, - speleothemtype = y@speleothemtype, - entrancedistance = y@entrancedistance, - entrancedistanceunits = y@entrancedistanceunits, - landusecovertype = y@landusecovertype, - landusecoverpercent = y@landusecoverpercent, - vegetationcovertype = y@vegetationcovertype, - vegetationcoverpercent = y@vegetationcoverpercent, - entitycovertype = y@entitycovertype, - entitycoverthickness = y@entitycoverthickness) - }) %>% - bind_rows() %>% - print(row.names = FALSE) - }) +setMethod( + f = "show", + signature = "speleothems", + definition = function(object) { + map(object, function(y) { + data.frame( + entityid = y@entityid, + entityname = y@entityname, + siteid = y@siteid, + collectionunitid = y@collectionunitid, + speleothemdriptype = y@speleothemdriptype, + dripheight = y@dripheight, + dripheightunits = y@dripheightunits, + monitoring = y@monitoring, + geology = y@geology, + rockage = y@rockage, + speleothemtype = y@speleothemtype, + entrancedistance = y@entrancedistance, + entrancedistanceunits = y@entrancedistanceunits, + landusecovertype = y@landusecovertype, + landusecoverpercent = y@landusecoverpercent, + vegetationcovertype = y@vegetationcovertype, + vegetationcoverpercent = y@vegetationcoverpercent, + entitycovertype = y@entitycovertype, + entitycoverthickness = y@entitycoverthickness + ) + }) %>% + bind_rows() %>% + print(row.names = FALSE) + } +) -#' @aliases sub-sub,speleothems-method [[,speleothems,numeric-method [[,speleothems,numeric,ANY-method +#' @aliases sub-sub,speleothems-method [[,speleothems,numeric-method +#' [[,speleothems,numeric,ANY-method #' @rdname sub-sub -setMethod(f = "[[", - signature = signature(x = "speleothems", i = "numeric"), - definition = function(x, i) { - if (length(i) == 1) { - out <- new("speleothem", x@speleothems[[i]]) - } else { - out <- map(i, function(z) { - new("dataset", x@speleothems[[z]]) - }) - out <- new("speleothems", speleothems = out) - } - return(out) - }) +setMethod( + f = "[[", + signature = signature(x = "speleothems", i = "numeric"), + definition = function(x, i) { + if (length(i) == 1) { + out <- new("speleothem", x@speleothems[[i]]) + } else { + out <- map(i, function(z) { + new("dataset", x@speleothems[[z]]) + }) + out <- new("speleothems", speleothems = out) + } + out + } +) #' @aliases names,speleothem-method #' @rdname names -setMethod(f = "names", - signature = signature(x = "speleothem"), - definition = function(x) { - slotNames(x) - }) +setMethod( + f = "names", + signature = signature(x = "speleothem"), + definition = function(x) { + slotNames(x) + } +) -#' @aliases sub-subset,speleothems-method [[<-,speleothems-method [[<-,speleothems,ANY,ANY-method +#' @aliases sub-subset,speleothems-method [[<-,speleothems-method +#' [[<-,speleothems,ANY,ANY-method #' @rdname sub-subset -setMethod(f = "[[<-", - signature = signature(x = "speleothems"), - definition = function(x, i, value) { - speleothemset <- x@speleothems - speleothemset[[i]] <- value - out <- new("speleothems", speleothems = speleothemset) - return(out) - }) +setMethod( + f = "[[<-", + signature = signature(x = "speleothems"), + definition = function(x, i, value) { + speleothemset <- x@speleothems + speleothemset[[i]] <- value + out <- new("speleothems", speleothems = speleothemset) + out + } +) -#' @aliases subset,speleothem-method [<-,speleothem,character-method [<-,speleothem,character,ANY-method +#' @aliases subset,speleothem-method [<-,speleothem,character-method +#' [<-,speleothem,character,ANY-method #' @rdname subset -setMethod(f = "[<-", - signature = signature(x = "speleothem", i = "character"), - definition = function(x, i, value) { - for (idx in seq_along(i)) { - slot(x, i[idx]) <- value[idx] - } - return(x) - }) +setMethod( + f = "[<-", + signature = signature(x = "speleothem", i = "character"), + definition = function(x, i, value) { + for (idx in seq_along(i)) { + slot(x, i[idx]) <- value[idx] + } + x + } +) -#' @aliases subset,speleothem-method [<-,speleothem,numeric-method [<-,speleothem,numeric,ANY-method +#' @aliases subset,speleothem-method [<-,speleothem,numeric-method +#' [<-,speleothem,numeric,ANY-method #' @rdname subset -setMethod(f = "[<-", - signature = signature(x = "speleothem", i = "numeric"), - definition = function(x, i, value) { - slots <- slotNames(x) - for (idx in seq_along(i)) { - slot(x, slots[i[idx]]) <- value[idx] - } - return(x) - }) +setMethod( + f = "[<-", + signature = signature(x = "speleothem", i = "numeric"), + definition = function(x, i, value) { + slots <- slotNames(x) + for (idx in seq_along(i)) { + slot(x, slots[i[idx]]) <- value[idx] + } + x + } +) #' @aliases cash-set,speleothem-method #' @rdname cash-set -setMethod(f = "$<-", - signature = signature(x = "speleothem"), - definition = function(x, name, value) { - slot(x, name) <- value - return(x) - }) +setMethod( + f = "$<-", + signature = signature(x = "speleothem"), + definition = function(x, name, value) { + slot(x, name) <- value + x + } +) -#' @aliases sub,speleothems-method [,speleothems,numeric-method [,speleothems,numeric,ANY-method +#' @aliases sub,speleothems-method [,speleothems,numeric-method +#' [,speleothems,numeric,ANY-method #' @rdname sub -setMethod(f = "[", - signature = signature(x = "speleothems", i = "numeric"), - definition = function(x, i) { - new("speleothems", speleothems = x@speleothems[i]) - }) +setMethod( + f = "[", + signature = signature(x = "speleothems", i = "numeric"), + definition = function(x, i) { + new("speleothems", speleothems = x@speleothems[i]) + } +) #' @aliases cash,speleothem-method #' @rdname cash -setMethod(f = "$", - signature = signature(x = "speleothem"), - definition = function(x, name) { - slot(x, name) - }) +setMethod( + f = "$", + signature = signature(x = "speleothem"), + definition = function(x, name) { + slot(x, name) + } +) #' @aliases cash,speleothems-method #' @rdname cash -setMethod(f = "$", - signature = signature(x = "speleothems"), - definition = function(x, name) { - x %>% - map(function(y) { - slot(y, name) - }) %>% - unlist() - }) +setMethod( + f = "$", + signature = signature(x = "speleothems"), + definition = function(x, name) { + x %>% + map(function(y) { + slot(y, name) + }) %>% + unlist() + } +) #' @aliases as.data.frame,speleothem-method #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature("speleothem"), - definition = function(x) { - data.frame(entityid = x@entityid, - entityname = x@entityname, - siteid = x@siteid, - collectionunitid = x@collectionunitid, - speleothemdriptype = x@speleothemdriptype, - dripheight = x@dripheight, - dripheightunits = x@dripheightunits, - monitoring = x@monitoring, - geology = x@geology, - rockage = x@rockage, - speleothemtype = x@speleothemtype, - entrancedistance = x@entrancedistance, - entrancedistanceunits = x@entrancedistanceunits, - landusecovertype = x@landusecovertype, - landusecoverpercent = x@landusecoverpercent, - vegetationcovertype = x@vegetationcovertype, - vegetationcoverpercent = x@vegetationcoverpercent, - entitycoverthickness = x@entitycoverthickness, - entitycovertype = x@entitycovertype) - }) +setMethod( + f = "as.data.frame", + signature = signature("speleothem"), + definition = function(x) { + data.frame( + entityid = x@entityid, + entityname = x@entityname, + siteid = x@siteid, + collectionunitid = x@collectionunitid, + speleothemdriptype = x@speleothemdriptype, + dripheight = x@dripheight, + dripheightunits = x@dripheightunits, + monitoring = x@monitoring, + geology = x@geology, + rockage = x@rockage, + speleothemtype = x@speleothemtype, + entrancedistance = x@entrancedistance, + entrancedistanceunits = x@entrancedistanceunits, + landusecovertype = x@landusecovertype, + landusecoverpercent = x@landusecoverpercent, + vegetationcovertype = x@vegetationcovertype, + vegetationcoverpercent = x@vegetationcoverpercent, + entitycoverthickness = x@entitycoverthickness, + entitycovertype = x@entitycovertype + ) + } +) #' @aliases as.data.frame,speleothems-method #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature("speleothems"), - definition = function(x) { - x@speleothems %>% map(as.data.frame) %>% bind_rows() - }) +setMethod( + f = "as.data.frame", + signature = signature("speleothems"), + definition = function(x) { + x@speleothems %>% + map(as.data.frame) %>% + bind_rows() + } +) #' @aliases length,speleothems-method #' @rdname length -setMethod(f = "length", - signature = signature(x = "speleothems"), - definition = function(x) { - length(x@speleothems) - }) +setMethod( + f = "length", + signature = signature(x = "speleothems"), + definition = function(x) { + length(x@speleothems) + } +) #' @aliases c,speleothems-method #' @rdname c -setMethod(f = "c", - signature = signature(x = "speleothems"), - definition = function(x, y) { - new("speleothems", - speleothems = unlist(c(x@speleothems, - y@speleothems), - recursive = FALSE)) - }) \ No newline at end of file +setMethod( + f = "c", + signature = signature(x = "speleothems"), + definition = function(x, y) { + new("speleothems", + speleothems = unlist( + c( + x@speleothems, + y@speleothems + ), + recursive = FALSE + ) + ) + } +) diff --git a/R/speleothemdetails.R b/R/speleothemdetails.R index 24027c79..d1e47649 100644 --- a/R/speleothemdetails.R +++ b/R/speleothemdetails.R @@ -1,6 +1,6 @@ #' @title speleothemdetails #' @author Socorro Dominguez \email{dominguezvid@wisc.edu} -#' @importFrom dplyr bind_rows distinct mutate rename +#' @importFrom dplyr bind_rows distinct mutate rename #' @importFrom dplyr left_join select arrange #' @importFrom purrr map #' @param x site object @@ -16,82 +16,94 @@ #' } #' @md #' @export -setMethod(f = "speleothemdetails", +setMethod( + f = "speleothemdetails", signature = "sites", definition = function(x) { - output <- map(x@sites, - function(y) speleothemdetails(y)) %>% + output <- map( + x@sites, + function(y) speleothemdetails(y) + ) %>% bind_rows() %>% distinct() %>% - select(.data$siteid, .data$sitename, .data$collectionunitid, - .data$datasetid, .data$entityid, .data$entityname, - .data$depth, .data$thickness, .data$chronologyid, - .data$chronologyname, .data$agetype, .data$ageolder, - .data$age, .data$ageyounger, .data$age_units, .data$sampleid, - .data$samplename, .data$taxongroup, .data$ecologicalgroup, - .data$taxonid, .data$variablename, .data$value, .data$units, - # speleothem details - .data$speleothemtype, .data$geology, - .data$rockage, .data$monitoring, - .data$speleothemdriptype, .data$dripheight, .data$dripheightunits, - .data$covertype, .data$entitycoverthickness, - .data$entrancedistance, .data$entrancedistanceunits, - .data$landusecovertype, .data$landusecoverpercent, - .data$vegetationcovertype, .data$vegetationcoverpercent) %>% + select( + .data$siteid, .data$sitename, .data$collectionunitid, + .data$datasetid, .data$entityid, .data$entityname, + .data$depth, .data$thickness, .data$chronologyid, + .data$chronologyname, .data$agetype, .data$ageolder, + .data$age, .data$ageyounger, .data$age_units, .data$sampleid, + .data$samplename, .data$taxongroup, .data$ecologicalgroup, + .data$taxonid, .data$variablename, .data$value, .data$units, + # speleothem details + .data$speleothemtype, .data$geology, + .data$rockage, .data$monitoring, + .data$speleothemdriptype, .data$dripheight, .data$dripheightunits, + .data$covertype, .data$entitycoverthickness, + .data$entrancedistance, .data$entrancedistanceunits, + .data$landusecovertype, .data$landusecoverpercent, + .data$vegetationcovertype, .data$vegetationcoverpercent + ) %>% arrange(.data$entityid, .data$taxonid, .data$depth, .data$age) if (nrow(output) == 0) { - warnsite <- sprintf("No assigned speleothems. Is it a speleothem + warnsite <- sprintf("No assigned speleothems. Is it a speleothem dataset? \nDid you run get_speleothems()?") warning(warnsite) } - return(output) + output } ) #' @rdname speleothemdetails #' @export -setMethod(f = "speleothemdetails", +setMethod( + f = "speleothemdetails", signature = "site", definition = function(x) { - map(x@collunits@collunits, - function(y) { - speleothemdetails(y) %>% - bind_rows() - }) + map( + x@collunits@collunits, + function(y) { + speleothemdetails(y) %>% + bind_rows() + } + ) } ) #' @rdname speleothemdetails #' @export -setMethod(f = "speleothemdetails", +setMethod( + f = "speleothemdetails", signature = "collunits", definition = function(x) { df <- map(x@collunits, function(x) speleothemdetails(x)) %>% bind_rows() - return(df) + df } ) #' @rdname speleothemdetails #' @export -setMethod(f = "speleothemdetails", - signature = "collunit", - definition = function(x) { - speleothemset <- speleothems(x) - if (nrow(speleothemset) == 0) { - msg <- "No assigned speleothems. Is it a speleothem dataset? \n +setMethod( + f = "speleothemdetails", + signature = "collunit", + definition = function(x) { + speleothemset <- speleothems(x) + if (nrow(speleothemset) == 0) { + msg <- "No assigned speleothems. Is it a speleothem dataset? \n Did you run get_speleothems()?" - warnsite <- sprintf(msg) - warning(warnsite) - return(data.frame()) - } else { - x <- get_downloads(speleothemset$datasetid) - sp_samples <- samples(x) %>% distinct() - # join speleothemset and sp_samples on datasetid - df <- speleothemset %>% - left_join(sp_samples, - by = "datasetid") %>% - distinct() - return(df) - } - }) \ No newline at end of file + warnsite <- sprintf(msg) + warning(warnsite) + data.frame() + } else { + x <- get_downloads(speleothemset$datasetid) + sp_samples <- samples(x) %>% distinct() + # join speleothemset and sp_samples on datasetid + df <- speleothemset %>% + left_join(sp_samples, + by = "datasetid" + ) %>% + distinct() + df + } + } +) diff --git a/R/speleothems.R b/R/speleothems.R index 84f35afc..a732261d 100644 --- a/R/speleothems.R +++ b/R/speleothems.R @@ -13,25 +13,30 @@ #' } #' @md #' @export -setMethod(f = "speleothems", +setMethod( + f = "speleothems", signature = "sites", definition = function(x) { - output <- map(x@sites, - function(y) speleothems(y)) %>% + output <- map( + x@sites, + function(y) speleothems(y) + ) %>% bind_rows() if (output$datasetid %>% is.null()) { return(data.frame()) } else { output <- output %>% - select(.data$siteid, .data$sitename, .data$collectionunitid, - .data$datasetid, .data$entityid, .data$entityname, - .data$speleothemtype, .data$geology, .data$rockage, - .data$monitoring, .data$speleothemdriptype, .data$dripheight, - .data$dripheightunits, .data$covertype, - .data$entitycoverthickness, .data$entrancedistance, - .data$entrancedistanceunits, .data$landusecovertype, - .data$landusecoverpercent, .data$vegetationcovertype, - .data$vegetationcoverpercent) %>% + select( + .data$siteid, .data$sitename, .data$collectionunitid, + .data$datasetid, .data$entityid, .data$entityname, + .data$speleothemtype, .data$geology, .data$rockage, + .data$monitoring, .data$speleothemdriptype, .data$dripheight, + .data$dripheightunits, .data$covertype, + .data$entitycoverthickness, .data$entrancedistance, + .data$entrancedistanceunits, .data$landusecovertype, + .data$landusecoverpercent, .data$vegetationcovertype, + .data$vegetationcoverpercent + ) %>% distinct() %>% arrange(.data$entityid, .data$siteid, .data$collectionunitid) } @@ -41,13 +46,14 @@ setMethod(f = "speleothems", warnsite <- sprintf(msg) warning(warnsite) } - return(output) + output } ) #' @rdname speleothems #' @export -setMethod(f = "speleothems", +setMethod( + f = "speleothems", signature = "site", definition = function(x) { allids <- getids(x) %>% @@ -58,37 +64,41 @@ setMethod(f = "speleothems", dsids <- dsids$datasetid if (length(dsids) == 0) { warning(sprintf("No speleothem datasets for siteid %s", x@siteid)) - return(data.frame()) + data.frame() } else { allids <- allids %>% filter(.data$datasetid %in% dsids) siteinfo <- as.data.frame(x) %>% distinct() %>% left_join(allids, by = "siteid") - sampset <- map(x@collunits@collunits, - function(y) speleothems(y)) %>% + sampset <- map( + x@collunits@collunits, + function(y) speleothems(y) + ) %>% bind_rows() %>% left_join(siteinfo, by = "datasetid") %>% rename(sitenotes = .data$notes) - return(sampset) + sampset } } ) #' @rdname speleothems #' @export -setMethod(f = "speleothems", +setMethod( + f = "speleothems", signature = "collunits", definition = function(x) { df <- map(x@collunits, function(x) speleothems(x)) %>% bind_rows() - return(df) + df } ) #' @rdname speleothems #' @export -setMethod(f = "speleothems", +setMethod( + f = "speleothems", signature = "collunit", definition = function(x) { dsids <- as.data.frame(datasets(x)) %>% @@ -98,43 +108,45 @@ setMethod(f = "speleothems", if (length(x@speleothems@speleothems) == 0) { warning(sprintf("No assigned speleothems. Is it a speleothems dataset? Did you run `get_speleothems()`?")) - return(data.frame()) + data.frame() } else { speleothemset <- - map(x@speleothems@speleothems, - function(y) { - y <- as.data.frame(y) - if (!is.null(y) && nrow(y) > 0) { - df <- data.frame( - collectionunitid = y$collectionunitid, - entityid = y$entityid, - entityname = y$entityname, - speleothemtype = y$speleothemtype, - speleothemdriptype = y$speleothemdriptype, - dripheight = y$dripheight, - dripheightunits = y$dripheightunits, - monitoring = y$monitoring, - geology = y$geology, - rockage = y$rockage, - covertype = y$entitycovertype, - entitycoverthickness = y$entitycoverthickness, - entrancedistance = y$entrancedistance, - entrancedistanceunits = y$entrancedistanceunits, - landusecovertype = y$landusecovertype, - landusecoverpercent = y$landusecoverpercent, - vegetationcovertype = y$vegetationcovertype, - vegetationcoverpercent = y$vegetationcoverpercent - ) %>% - left_join(dsids, by = "collectionunitid") - } else { - df <- data.frame() - } - return(df) - }) %>% + map( + x@speleothems@speleothems, + function(y) { + y <- as.data.frame(y) + if (!is.null(y) && nrow(y) > 0) { + df <- data.frame( + collectionunitid = y$collectionunitid, + entityid = y$entityid, + entityname = y$entityname, + speleothemtype = y$speleothemtype, + speleothemdriptype = y$speleothemdriptype, + dripheight = y$dripheight, + dripheightunits = y$dripheightunits, + monitoring = y$monitoring, + geology = y$geology, + rockage = y$rockage, + covertype = y$entitycovertype, + entitycoverthickness = y$entitycoverthickness, + entrancedistance = y$entrancedistance, + entrancedistanceunits = y$entrancedistanceunits, + landusecovertype = y$landusecovertype, + landusecoverpercent = y$landusecoverpercent, + vegetationcovertype = y$vegetationcovertype, + vegetationcoverpercent = y$vegetationcoverpercent + ) %>% + left_join(dsids, by = "collectionunitid") + } else { + df <- data.frame() + } + df + } + ) %>% bind_rows() - speleothemset <- speleothemset %>% + speleothemset <- speleothemset %>% distinct() - return(speleothemset) + speleothemset } } -) \ No newline at end of file +) diff --git a/R/subset-methods.R b/R/subset-methods.R index b90bf4dc..2787f467 100644 --- a/R/subset-methods.R +++ b/R/subset-methods.R @@ -4,90 +4,106 @@ #' @returns `collunits` from a `sites` object #' @md #' @export -setMethod(f = "collunits", - signature = "sites", - definition = function(object) { - output <- map(object@sites, function(x) { - x@collunits - }) - if (length(output) == 0) { - return(new("collunits", collunits = list())) - } - final <- reduce(output, c) - final <- clean(final) - return(final) - }) +setMethod( + f = "collunits", + signature = "sites", + definition = function(object) { + output <- map(object@sites, function(x) { + x@collunits + }) + if (length(output) == 0) { + return(new("collunits", collunits = list())) + } + final <- reduce(output, c) + final <- clean(final) + final + } +) #' @rdname collunits #' @export -setMethod(f = "collunits", - signature = "site", - definition = function(object) { - output <- object@collunits - attr(output, "siteid") <- object$siteid - return(output) - }) +setMethod( + f = "collunits", + signature = "site", + definition = function(object) { + output <- object@collunits + attr(output, "siteid") <- object$siteid + output + } +) #' @title Extract `datasets` from a `sites` or `collunits` object. #' @importFrom purrr map map_lgl reduce #' @param object A `sites` or`collunits` object #' @returns `datasets` object #' @export -setMethod(f = "datasets", - signature = "collunits", - definition = function(object) { - result <- map(object@collunits, - function(x) x@datasets) - # Drop collection units with no datasets so reduce()/c() never - # dereferences a NULL slot or runs on an empty list. - result <- result[!map_lgl(result, is.null)] - if (length(result) == 0) { - out <- new("datasets", datasets = list()) - } else if (length(result) == 1) { - out <- result[[1]] - } else { - out <- reduce(result, c) - } - return(out) - }) +setMethod( + f = "datasets", + signature = "collunits", + definition = function(object) { + result <- map( + object@collunits, + function(x) x@datasets + ) + # Drop collection units with no datasets so reduce()/c() never + # dereferences a NULL slot or runs on an empty list. + result <- result[!map_lgl(result, is.null)] + if (length(result) == 0) { + out <- new("datasets", datasets = list()) + } else if (length(result) == 1) { + out <- result[[1]] + } else { + out <- reduce(result, c) + } + out + } +) #' @rdname datasets #' @export -setMethod(f = "datasets", - signature = "collunit", - definition = function(object) { - result <- object@datasets - return(result) - }) +setMethod( + f = "datasets", + signature = "collunit", + definition = function(object) { + result <- object@datasets + result + } +) #' @rdname datasets #' @export -setMethod(f = "datasets", - signature = "sites", - definition = function(object) { - clean(datasets(collunits(object))) - }) +setMethod( + f = "datasets", + signature = "sites", + definition = function(object) { + clean(datasets(collunits(object))) + } +) #' @rdname datasets #' @export -setMethod(f = "datasets", - signature = "site", - definition = function(object) { - cunits <- collunits(object) - result <- map(cunits@collunits, - function(x) x@datasets) - # Drop collection units with no datasets so reduce()/c() never - # dereferences a NULL slot or runs on an empty list. - result <- result[!map_lgl(result, is.null)] - if (length(result) == 0) { - out <- new("datasets", datasets = list()) - } else if (length(result) == 1) { - out <- result[[1]] - } else { - out <- reduce(result, c) - } - return(out) - }) +setMethod( + f = "datasets", + signature = "site", + definition = function(object) { + cunits <- collunits(object) + result <- map( + cunits@collunits, + function(x) x@datasets + ) + # Drop collection units with no datasets so reduce()/c() never + # dereferences a NULL slot or runs on an empty list. + result <- result[!map_lgl(result, is.null)] + if (length(result) == 0) { + out <- new("datasets", datasets = list()) + } else if (length(result) == 1) { + out <- result[[1]] + } else { + out <- reduce(result, c) + } + out + } +) #' @title Extract `chronologies` from a `site`s or `collunits` object. #' @importFrom purrr map @@ -95,70 +111,79 @@ setMethod(f = "datasets", #' @returns `chronologies` from a `collunit` object #' @md #' @export -setMethod(f = "chronologies", - signature = "collunit", - definition = function(x) { - # A collection unit with no chronologies (NULL or empty slot) - # contributes none; return an empty container instead of - # dereferencing a NULL slot. - if (is.null(x@chronologies) || - length(x@chronologies@chronologies) == 0) { - return(new("chronologies", chronologies = list())) - } - output <- map(x@chronologies@chronologies, function(y) { - attr(y, "collunitid") <- x$collectionunitid - return(y) - }) - try( - returner <- new("chronologies", chronologies = output) - ) - if ("try-error" %in% class(returner)) { - stop("Cannot create chronology for this colleciton unit.") - } - return(returner) - }) +setMethod( + f = "chronologies", + signature = "collunit", + definition = function(x) { + # A collection unit with no chronologies (NULL or empty slot) + # contributes none; return an empty container instead of + # dereferencing a NULL slot. + no_chronologies <- is.null(x@chronologies) || + length(x@chronologies@chronologies) == 0 + if (no_chronologies) { + return(new("chronologies", chronologies = list())) + } + output <- map(x@chronologies@chronologies, function(y) { + attr(y, "collunitid") <- x$collectionunitid + y + }) + try( + returner <- new("chronologies", chronologies = output) + ) + if ("try-error" %in% class(returner)) { + stop("Cannot create chronology for this colleciton unit.") + } + returner + } +) #' @rdname chronologies #' @export -setMethod(f = "chronologies", - signature = "collunits", - definition = function(x) { - output <- map(x@collunits, function(y) { - chronologies(y) - }) - if (length(output) == 0) { - return(new("chronologies", chronologies = list())) - } - output <- reduce(output, c) - return(output) - }) +setMethod( + f = "chronologies", + signature = "collunits", + definition = function(x) { + output <- map(x@collunits, function(y) { + chronologies(y) + }) + if (length(output) == 0) { + return(new("chronologies", chronologies = list())) + } + output <- reduce(output, c) + output + } +) #' @rdname chronologies #' @export -setMethod(f = "chronologies", - signature = "site", - definition = function(x) { - output <- map(x@collunits@collunits, function(y) { - chronologies(y) - }) - if (length(output) == 0) { - return(new("chronologies", chronologies = list())) - } - output <- purrr::reduce(output, c) - return(output) - }) +setMethod( + f = "chronologies", + signature = "site", + definition = function(x) { + output <- map(x@collunits@collunits, function(y) { + chronologies(y) + }) + if (length(output) == 0) { + return(new("chronologies", chronologies = list())) + } + output <- purrr::reduce(output, c) + output + } +) #' @rdname chronologies #' @export -setMethod(f = "chronologies", - signature = "sites", - definition = function(x) { - output <- map(x@sites, function(y) { - chronologies(y) - }) - if (length(output) == 0) { - return(new("chronologies", chronologies = list())) - } - output <- reduce(output, c) - return(output) - }) \ No newline at end of file +setMethod( + f = "chronologies", + signature = "sites", + definition = function(x) { + output <- map(x@sites, function(y) { + chronologies(y) + }) + if (length(output) == 0) { + return(new("chronologies", chronologies = list())) + } + output <- reduce(output, c) + output + } +) diff --git a/R/taxa.R b/R/taxa.R index 12d803ff..5ac73d4c 100644 --- a/R/taxa.R +++ b/R/taxa.R @@ -13,118 +13,141 @@ #' } #' @md #' @export -setMethod(f = "taxa", +setMethod( + f = "taxa", signature = "sites", definition = function(object) { output <- map(object@sites, function(y) taxa(y)) %>% bind_rows() %>% - group_by(.data$units, - .data$context, - .data$element, - .data$taxonid, - .data$symmetry, - .data$taxongroup, - .data$elementtype, - .data$variablename, - .data$ecologicalgroup) %>% - summarise(samples = sum(samples), - sites = sum(.data$sites), .groups = "keep") + group_by( + .data$units, + .data$context, + .data$element, + .data$taxonid, + .data$symmetry, + .data$taxongroup, + .data$elementtype, + .data$variablename, + .data$ecologicalgroup + ) %>% + summarise( + samples = sum(samples), + sites = sum(.data$sites), .groups = "keep" + ) if (nrow(output) == 0) { warnsite <- sprintf("No assigned samples. Did you run get_downloads()?") warning(warnsite) } - return(output) + output } ) #' @rdname taxa #' @export -setMethod(f = "taxa", - signature = "site", - definition = function(object) { - samples <- samples(object) - tx_table <- samples %>% - group_by(.data$units, - .data$context, - .data$element, - .data$taxonid, - .data$symmetry, - .data$taxongroup, - .data$elementtype, - .data$variablename, - .data$ecologicalgroup, - .data$siteid) %>% - summarise(samples = n(), .groups = "keep") %>% - group_by(.data$units, - .data$context, - .data$element, - .data$taxonid, - .data$symmetry, - .data$taxongroup, - .data$elementtype, - .data$variablename, - .data$ecologicalgroup) %>% - summarise(sites = n(), samples = sum(samples), .groups = "keep") - return(tx_table) - }) +setMethod( + f = "taxa", + signature = "site", + definition = function(object) { + samples <- samples(object) + tx_table <- samples %>% + group_by( + .data$units, + .data$context, + .data$element, + .data$taxonid, + .data$symmetry, + .data$taxongroup, + .data$elementtype, + .data$variablename, + .data$ecologicalgroup, + .data$siteid + ) %>% + summarise(samples = n(), .groups = "keep") %>% + group_by( + .data$units, + .data$context, + .data$element, + .data$taxonid, + .data$symmetry, + .data$taxongroup, + .data$elementtype, + .data$variablename, + .data$ecologicalgroup + ) %>% + summarise(sites = n(), samples = sum(samples), .groups = "keep") + tx_table + } +) #' @rdname taxa #' @export -setMethod(f = "taxa", - signature = "collunits", - definition = function(object) { - samples <- samples(object) - tx_table <- samples %>% - group_by(.data$units, - .data$context, - .data$element, - .data$taxonid, - .data$symmetry, - .data$taxongroup, - .data$elementtype, - .data$variablename, - .data$ecologicalgroup, - .data$siteid) %>% - summarise(samples = n(), .groups = "keep") %>% - group_by(.data$units, - .data$context, - .data$element, - .data$taxonid, - .data$symmetry, - .data$taxongroup, - .data$elementtype, - .data$variablename, - .data$ecologicalgroup) %>% - summarise(sites = n(), samples = sum(samples), .groups = "keep") - return(tx_table) - }) +setMethod( + f = "taxa", + signature = "collunits", + definition = function(object) { + samples <- samples(object) + tx_table <- samples %>% + group_by( + .data$units, + .data$context, + .data$element, + .data$taxonid, + .data$symmetry, + .data$taxongroup, + .data$elementtype, + .data$variablename, + .data$ecologicalgroup, + .data$siteid + ) %>% + summarise(samples = n(), .groups = "keep") %>% + group_by( + .data$units, + .data$context, + .data$element, + .data$taxonid, + .data$symmetry, + .data$taxongroup, + .data$elementtype, + .data$variablename, + .data$ecologicalgroup + ) %>% + summarise(sites = n(), samples = sum(samples), .groups = "keep") + tx_table + } +) #' @rdname taxa #' @export -setMethod(f = "taxa", - signature = "collunit", - definition = function(object) { - samples <- samples(object) - tx_table <- samples %>% - group_by(.data$units, - .data$context, - .data$element, - .data$taxonid, - .data$symmetry, - .data$taxongroup, - .data$elementtype, - .data$variablename, - .data$ecologicalgroup) %>% - summarise(samples = n(), .groups = "keep") %>% - group_by(.data$units, - .data$context, - .data$element, - .data$taxonid, - .data$symmetry, - .data$taxongroup, - .data$elementtype, - .data$variablename, - .data$ecologicalgroup) %>% - summarise(sites = n(), samples = sum(samples), .groups = "keep") - return(tx_table) - }) \ No newline at end of file +setMethod( + f = "taxa", + signature = "collunit", + definition = function(object) { + samples <- samples(object) + tx_table <- samples %>% + group_by( + .data$units, + .data$context, + .data$element, + .data$taxonid, + .data$symmetry, + .data$taxongroup, + .data$elementtype, + .data$variablename, + .data$ecologicalgroup + ) %>% + summarise(samples = n(), .groups = "keep") %>% + group_by( + .data$units, + .data$context, + .data$element, + .data$taxonid, + .data$symmetry, + .data$taxongroup, + .data$elementtype, + .data$variablename, + .data$ecologicalgroup + ) %>% + summarise(sites = n(), samples = sum(samples), .groups = "keep") + tx_table + } +) diff --git a/R/taxon-methods.R b/R/taxon-methods.R index 8134e110..6e31e850 100644 --- a/R/taxon-methods.R +++ b/R/taxon-methods.R @@ -1,157 +1,193 @@ #' @aliases show,taxon-method #' @rdname show -setMethod(f = "show", - signature = "taxon", - definition = function(object) { - print(data.frame(taxonid = as.character(object@taxonid), - taxoncode = object@taxoncode, - taxonname = object@taxonname, - author = object@author, - ecolgroup = object@ecolgroup, - highertaxonid = object@highertaxonid, - status = object@status, - taxagroupid = object@taxagroupid, - publicationid = object@publicationid, - publication = object@publication), - row.names = FALSE) - }) +setMethod( + f = "show", + signature = "taxon", + definition = function(object) { + print( + data.frame( + taxonid = as.character(object@taxonid), + taxoncode = object@taxoncode, + taxonname = object@taxonname, + author = object@author, + ecolgroup = object@ecolgroup, + highertaxonid = object@highertaxonid, + status = object@status, + taxagroupid = object@taxagroupid, + publicationid = object@publicationid, + publication = object@publication + ), + row.names = FALSE + ) + } +) #' @aliases show,taxa-method #' @rdname show -setMethod(f = "show", - signature = "taxa", - definition = function(object) { - map(object@taxa, function(y) { - data.frame(taxonid = as.character(y@taxonid), - taxoncode = y@taxoncode, - taxonname = y@taxonname, - author = y@author, - ecolgroup = y@ecolgroup, - highertaxonid = y@highertaxonid, - status = y@status, - taxagroupid = y@taxagroupid, - publicationid = y@publicationid, - publication = y@publication) - }) %>% - bind_rows() %>% - print(row.names = FALSE) - }) +setMethod( + f = "show", + signature = "taxa", + definition = function(object) { + map(object@taxa, function(y) { + data.frame( + taxonid = as.character(y@taxonid), + taxoncode = y@taxoncode, + taxonname = y@taxonname, + author = y@author, + ecolgroup = y@ecolgroup, + highertaxonid = y@highertaxonid, + status = y@status, + taxagroupid = y@taxagroupid, + publicationid = y@publicationid, + publication = y@publication + ) + }) %>% + bind_rows() %>% + print(row.names = FALSE) + } +) -#' @aliases sub-sub,taxa-method [[,taxa,numeric-method [[,taxa,numeric,ANY-method +#' @aliases sub-sub,taxa-method [[,taxa,numeric-method +#' [[,taxa,numeric,ANY-method #' @rdname sub-sub -setMethod(f = "[[", - signature = signature(x = "taxa", i = "numeric"), - definition = function(x, i) { - if (length(i) == 1) { - out <- new("taxon", x@taxa[[i]]) - } else { - out <- purrr::map(i, function(z) { - new("taxon", x@taxa[[z]]) - }) - out <- new("taxa", taxa = out) - } - return(out) - }) +setMethod( + f = "[[", + signature = signature(x = "taxa", i = "numeric"), + definition = function(x, i) { + if (length(i) == 1) { + out <- new("taxon", x@taxa[[i]]) + } else { + out <- purrr::map(i, function(z) { + new("taxon", x@taxa[[z]]) + }) + out <- new("taxa", taxa = out) + } + out + } +) #' @aliases names,taxon-method #' @rdname names -setMethod(f = "names", - signature = signature(x = "taxon"), - definition = function(x) { - slotNames(x) - }) +setMethod( + f = "names", + signature = signature(x = "taxon"), + definition = function(x) { + slotNames(x) + } +) #' @aliases sub-subset,taxa-method [[<-,taxa-method [[<-,taxa,ANY,ANY-method #' @rdname sub-subset -setMethod(f = "[[<-", - signature = signature(x = "taxa"), - definition = function(x, i, value) { - taxaset <- x@taxa - taxaset[[i]] <- value - out <- new("taxa", taxa = taxaset) - return(out) - }) +setMethod( + f = "[[<-", + signature = signature(x = "taxa"), + definition = function(x, i, value) { + taxaset <- x@taxa + taxaset[[i]] <- value + out <- new("taxa", taxa = taxaset) + out + } +) -#' @aliases subset,taxon-method [<-,taxon,character-method [<-,taxon,character,ANY-method +#' @aliases subset,taxon-method [<-,taxon,character-method +#' [<-,taxon,character,ANY-method #' @rdname subset -setMethod(f = "[<-", - signature = signature(x = "taxon", i = "character"), - definition = function(x, i, value) { - for (idx in seq_along(i)) { - slot(x, i[idx]) <- value[idx] - } - return(x) - }) +setMethod( + f = "[<-", + signature = signature(x = "taxon", i = "character"), + definition = function(x, i, value) { + for (idx in seq_along(i)) { + slot(x, i[idx]) <- value[idx] + } + x + } +) -#' @aliases subset,taxon-method [<-,taxon,numeric-method [<-,taxon,numeric,ANY-method +#' @aliases subset,taxon-method [<-,taxon,numeric-method +#' [<-,taxon,numeric,ANY-method #' @rdname subset -setMethod(f = "[<-", - signature = signature(x = "taxon", i = "numeric"), - definition = function(x, i, value) { - slots <- slotNames(x) - for (idx in seq_along(i)) { - slot(x, slots[i[idx]]) <- value[idx] - } - return(x) - }) +setMethod( + f = "[<-", + signature = signature(x = "taxon", i = "numeric"), + definition = function(x, i, value) { + slots <- slotNames(x) + for (idx in seq_along(i)) { + slot(x, slots[i[idx]]) <- value[idx] + } + x + } +) #' @aliases cash-set,taxon-method #' @rdname cash-set -setMethod(f = "$<-", - signature = signature(x = "taxon"), - definition = function(x, name, value) { - slot(x, name) <- value - return(x) - }) +setMethod( + f = "$<-", + signature = signature(x = "taxon"), + definition = function(x, name, value) { + slot(x, name) <- value + x + } +) #' @aliases sub,taxa-method [,taxa,numeric-method [,taxa,numeric,ANY-method #' @rdname sub -setMethod(f = "[", - signature = signature(x = "taxa", i = "numeric"), - definition = function(x, i) { - new("taxa", taxa = x@taxa[i]) - }) +setMethod( + f = "[", + signature = signature(x = "taxa", i = "numeric"), + definition = function(x, i) { + new("taxa", taxa = x@taxa[i]) + } +) #' @aliases cash,taxon-method #' @rdname cash -setMethod(f = "$", - signature = signature(x = "taxon"), - definition = function(x, name) { - slot(x, name) - }) +setMethod( + f = "$", + signature = signature(x = "taxon"), + definition = function(x, name) { + slot(x, name) + } +) #' @aliases cash,taxa-method #' @rdname cash -setMethod(f = "$", - signature = signature(x = "taxa"), - definition = function(x, name) { - x %>% - map(function(y) { - slot(y, name) - }) %>% - unlist() - }) +setMethod( + f = "$", + signature = signature(x = "taxa"), + definition = function(x, name) { + x %>% + map(function(y) { + slot(y, name) + }) %>% + unlist() + } +) #' @aliases as.data.frame,taxon-method #' @rdname as.data.frame -setMethod(f = "as.data.frame", - signature = signature("taxon"), - definition = function(x) { - data.frame(taxonid = as.character(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) - }) +setMethod( + f = "as.data.frame", + signature = signature("taxon"), + definition = function(x) { + data.frame( + taxonid = as.character(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 + ) + } +) #' @aliases as.data.frame,taxa-method #' @rdname as.data.frame -setMethod(f = "as.data.frame", +setMethod( + f = "as.data.frame", signature = "taxa", definition = function(x) { df <- map(x@taxa, function(y) { @@ -169,25 +205,34 @@ setMethod(f = "as.data.frame", ) }) %>% bind_rows() - return(df) + df } ) #' @aliases length,taxa-method #' @rdname length -setMethod(f = "length", - signature = signature(x = "taxa"), - definition = function(x) { - length(x@taxa) - }) +setMethod( + f = "length", + signature = signature(x = "taxa"), + definition = function(x) { + length(x@taxa) + } +) #' @aliases c,taxa-method #' @rdname c -setMethod(f = "c", - signature = signature(x = "taxa"), - definition = function(x, y) { - new("taxa", - taxa = unlist(c(x@taxa, - y@taxa), - recursive = FALSE)) - }) \ No newline at end of file +setMethod( + f = "c", + signature = signature(x = "taxa"), + definition = function(x, y) { + new("taxa", + taxa = unlist( + c( + x@taxa, + y@taxa + ), + recursive = FALSE + ) + ) + } +) diff --git a/R/testNull.R b/R/testNull.R index 57771c8b..78ddc1ce 100644 --- a/R/testNull.R +++ b/R/testNull.R @@ -6,10 +6,10 @@ #' @returns The values passed in \code{val} or \code{out} if #' \code{val} is \code{NULL}. #' @examples { -#' # Passing a null value into the function returns 12: -#' a <- testNull(val = NULL, out = 12) -#' # Passing a non-NULL value returns that value: -#' b <- testNull(val = 11, out = 12) +#' # Passing a null value into the function returns 12: +#' a <- testNull(val = NULL, out = 12) +#' # Passing a non-NULL value returns that value: +#' b <- testNull(val = 11, out = 12) #' } #' @keywords internal #' @noRd @@ -19,4 +19,4 @@ testNull <- function(val, out = NA) { } else { return(val) } -} \ No newline at end of file +} diff --git a/R/toWide.R b/R/toWide.R index 6c35d3dd..6298f624 100644 --- a/R/toWide.R +++ b/R/toWide.R @@ -15,13 +15,16 @@ #' 'prop', 'sum', 'presence'. #' @returns wide `data.frame` obtained from long `samples` `data.frame` #' @examples \dontrun{ -#' fc_sites <- neotoma2::get_datasets(limit=5, datasettype = "vertebrate fauna") +#' fc_sites <- neotoma2::get_datasets(limit = 5, datasettype = "vertebrate +#' fauna") #' fc_ds <- fc_sites %>% -#' neotoma2::get_downloads() +#' neotoma2::get_downloads() #' fc_dl1 <- fc_dl[[1]] #' fc_smp <- samples(fc_dl1) -#' toWide(fc_smp, ecologicalgroups=c('AVES', 'RODE'), -#' elementtypes='bone/tooth', unit='present/absent') +#' toWide(fc_smp, +#' ecologicalgroups = c("AVES", "RODE"), +#' elementtypes = "bone/tooth", unit = "present/absent" +#' ) #' } #' @description Obtain a wide table with information regarding of #' samples grouped by variablename and depth/age. @@ -33,16 +36,16 @@ toWide <- function(x, unit = NA, groupby = "age", operation = "prop") { - if (!(length(variablenames) == 1 && is.na(variablenames))) { + if (!(length(variablenames) == 1 && is.na(variablenames))) { x <- x %>% filter(.data$variablename %in% variablenames) } - if (!(length(ecologicalgroups) == 1 && is.na(ecologicalgroups))) { + if (!(length(ecologicalgroups) == 1 && is.na(ecologicalgroups))) { x <- x %>% filter(.data$ecologicalgroup %in% ecologicalgroups) } - if (!(length(elementtypes) == 1 && is.na(elementtypes))) { + if (!(length(elementtypes) == 1 && is.na(elementtypes))) { x <- x %>% filter(.data$elementtype %in% elementtypes) } - if (!(length(unit) == 1 && is.na(unit))) { + if (!(length(unit) == 1 && is.na(unit))) { x <- x %>% filter(units %in% unit) } # Get proportion values @@ -50,8 +53,10 @@ toWide <- function(x, group_by_at(groupby) %>% mutate(counter = sum(.data$value, na.rm = TRUE)) %>% group_by(.data$variablename) %>% - mutate(prop = .data$value / .data$counter, - n = .data$value) %>% + mutate( + prop = .data$value / .data$counter, + n = .data$value + ) %>% arrange(desc(groupby)) if (unit == "present/absent") { if (operation != "presence") { @@ -60,16 +65,21 @@ toWide <- function(x, operation <- "presence" } widetable <- onesite %>% - mutate(prop = as.numeric(.data$prop), - sum = as.numeric(.data$value), - presence = case_when(counter > 0 ~ 1, - counter == 0 ~ 0)) %>% + mutate( + prop = as.numeric(.data$prop), + sum = as.numeric(.data$value), + presence = case_when( + counter > 0 ~ 1, + counter == 0 ~ 0 + ) + ) %>% select(all_of(groupby), .data$variablename, all_of(operation)) counts <- pivot_wider(widetable, - id_cols = all_of(groupby), - names_from = .data$variablename, - values_from = operation, - values_fill = 0, - values_fn = sum) + id_cols = all_of(groupby), + names_from = .data$variablename, + values_from = operation, + values_fill = 0, + values_fn = sum + ) return(counts) -} \ No newline at end of file +} diff --git a/R/use_na.R b/R/use_na.R index ab887c40..11931107 100644 --- a/R/use_na.R +++ b/R/use_na.R @@ -9,35 +9,40 @@ #' @keywords internal #' @noRd use_na <- function(x, type) { - tryCatch({ - if (type == "sf") { - if (is.null(x) || nrow(x) == 0) { - return(sf::st_as_sf(sf::st_sfc())) - } else { - return(x) + tryCatch( + { + if (type == "sf") { + if (is.null(x) || nrow(x) == 0) { + return(sf::st_as_sf(sf::st_sfc())) + } else { + return(x) + } } + if (is.null(x) || (is.atomic(x) && all(is.na(x)))) { + return(switch(type, + "char" = NA_character_, + "int" = NA_integer_, + "list" = list(), + "date" = as.Date(NA_character_), + "bool" = NA, + "df" = data.frame(), + NA + )) + } + x + }, + error = function(e) { + # Fallback + switch(type, + "char" = NA_character_, + "int" = NA_integer_, + "sf" = sf::st_as_sf(sf::st_sfc()), + "list" = list(), + "date" = as.Date(NA_character_), + "bool" = NA, + "df" = data.frame(), + NA + ) } - if (is.null(x) || (is.atomic(x) && all(is.na(x)))) { - return(switch(type, - "char" = NA_character_, - "int" = NA_integer_, - "list" = list(), - "date" = as.Date(NA_character_), - "bool" = NA, - "df" = data.frame(), - NA)) - } - x - }, error = function(e) { - # Fallback - switch(type, - "char" = NA_character_, - "int" = NA_integer_, - "sf" = sf::st_as_sf(sf::st_sfc()), - "list" = list(), - "date" = as.Date(NA_character_), - "bool" = NA, - "df" = data.frame(), - NA) - }) -} \ No newline at end of file + ) +} diff --git a/R/utils-pipe.R b/R/utils-pipe.R index e401623b..cf53ec41 100644 --- a/R/utils-pipe.R +++ b/R/utils-pipe.R @@ -7,4 +7,4 @@ #' @importFrom magrittr %>% #' @usage lhs \%>\% rhs #' @returns NULL; allows using tidyverse pipe operator. -NULL \ No newline at end of file +NULL diff --git a/man/author_classes.Rd b/man/author_classes.Rd index 56a9045d..e1414409 100644 --- a/man/author_classes.Rd +++ b/man/author_classes.Rd @@ -17,7 +17,7 @@ a publication are represented by the \code{authors} object. } \examples{ { -simon <- new("contact", familyname = "Goring", givennames = "Simon J.") -firstauthor <- new("author", author = simon, order = 1) + simon <- new("contact", familyname = "Goring", givennames = "Simon J.") + firstauthor <- new("author", author = simon, order = 1) } } diff --git a/man/clean.Rd b/man/clean.Rd index c74756ae..dfd608ac 100644 --- a/man/clean.Rd +++ b/man/clean.Rd @@ -40,13 +40,16 @@ array of datasets. } \examples{ \dontrun{ -tryCatch({ - alex <- get_sites(sitename = "Alex\%") - alex2 <- get_sites(24) - c <- c(alex, alex2) #uncleaned -}, error = function(e) { - message("Neotoma server not responding. Try again later.") -}) +tryCatch( + { + alex <- get_sites(sitename = "Alex\%") + alex2 <- get_sites(24) + c <- c(alex, alex2) # uncleaned + }, + error = function(e) { + message("Neotoma server not responding. Try again later.") + } +) } } \author{ diff --git a/man/contacts_classes.Rd b/man/contacts_classes.Rd index 084d8bc5..c2ebbfe8 100644 --- a/man/contacts_classes.Rd +++ b/man/contacts_classes.Rd @@ -15,6 +15,6 @@ An unordered list of individual S4 \code{contact} objects. } \examples{ { -new("contact", familyname = "Goring", givennames = "Simon J.") + new("contact", familyname = "Goring", givennames = "Simon J.") } } diff --git a/man/count.Rd b/man/count.Rd index 3d925b9f..5b23c4e7 100644 --- a/man/count.Rd +++ b/man/count.Rd @@ -4,7 +4,8 @@ \alias{count} \alias{count,sites-method} \alias{count,site-method} -\title{Count the number of sites, datasets, or collectionunits associated with a site object.} +\title{Count the number of sites, datasets, or collectionunits associated +with a site object.} \usage{ count(x, level = "sites") @@ -15,11 +16,13 @@ count(x, level = "sites") \arguments{ \item{x}{A \code{sites} or \code{site} object.} -\item{level}{The level at which you want to count. Can be sites, collunits, or datasets. Default is sites.} +\item{level}{The level at which you want to count. Can be sites, collunits, +or datasets. Default is sites.} } \value{ A count of the specified level in the object } \description{ -Count the number of sites, datasets, or collectionunits associated with a site object. +Count the number of sites, datasets, or collectionunits associated +with a site object. } diff --git a/man/filter.Rd b/man/filter.Rd index ccf06987..be18ee87 100644 --- a/man/filter.Rd +++ b/man/filter.Rd @@ -79,21 +79,27 @@ as an alias for \code{loc}. \examples{ \dontrun{ # Download 10 sites, but only keep the sites that are close to sea level. -tryCatch({ - some_sites <- get_sites(sitename = "Lake\%", limit = 3) - site_subset <- some_sites \%>\% filter(altitude < 100) -}, error = function(e) { - message("Neotoma server not responding. Try again later.") -}) +tryCatch( + { + some_sites <- get_sites(sitename = "Lake\%", limit = 3) + site_subset <- some_sites \%>\% filter(altitude < 100) + }, + error = function(e) { + message("Neotoma server not responding. Try again later.") + } +) # Download 10 sites, get all associated datasets, but keep only # sites/datasets that are of datasettype "pollen": -tryCatch({ - sites <- get_sites(limit = 10) \%>\% - get_datasets() - pollen_subset <- sites \%>\% filter(datasettype == "pollen") -}, error = function(e) { - message("Neotoma server not responding. Try again later.") -}) +tryCatch( + { + sites <- get_sites(limit = 10) \%>\% + get_datasets() + pollen_subset <- sites \%>\% filter(datasettype == "pollen") + }, + error = function(e) { + message("Neotoma server not responding. Try again later.") + } +) } } \author{ diff --git a/man/get_datasets.Rd b/man/get_datasets.Rd index 5e180723..f28ce940 100644 --- a/man/get_datasets.Rd +++ b/man/get_datasets.Rd @@ -94,18 +94,24 @@ For the complete records, use \code{all_data=TRUE} } \examples{ \dontrun{ -tryCatch({ - random_sites <- get_sites(1) - allds <- get_datasets(random_sites, limit=3) -}, error = function(e) { - message("Neotoma server not responding. Try again later.") -}) +tryCatch( + { + random_sites <- get_sites(1) + allds <- get_datasets(random_sites, limit = 3) + }, + error = function(e) { + message("Neotoma server not responding. Try again later.") + } +) # To find all datasets with a min altitude of 12 and a max altitude of 25: -tryCatch({ - sites_12to25 <- get_datasets(altmin=12, altmax=25) -}, error = function(e) { - message("Neotoma server not responding. Try again later.") -}) +tryCatch( + { + sites_12to25 <- get_datasets(altmin = 12, altmax = 25) + }, + error = function(e) { + message("Neotoma server not responding. Try again later.") + } +) # To find all datasets in Brazil brazil <- '{"type": "Polygon", "coordinates": [[ @@ -114,11 +120,14 @@ brazil <- '{"type": "Polygon", [-36.5625,-7.710991655433217], [-68.203125,13.923403897723347], [-73.125,-9.102096738726443]]]}' -tryCatch({ - brazil_datasets <- get_datasets(loc = brazil[1], limit=2) -}, error = function(e) { - message("Neotoma server not responding. Try again later.") -}) +tryCatch( + { + brazil_datasets <- get_datasets(loc = brazil[1], limit = 2) + }, + error = function(e) { + message("Neotoma server not responding. Try again later.") + } +) } } \author{ diff --git a/man/get_documentation.Rd b/man/get_documentation.Rd index f36e1e9a..476942bb 100644 --- a/man/get_documentation.Rd +++ b/man/get_documentation.Rd @@ -12,7 +12,7 @@ Open up the Neotoma R homepage. \examples{ \dontrun{ if (interactive()) { - get_documentation() + get_documentation() } } } diff --git a/man/get_downloads.Rd b/man/get_downloads.Rd index d503ae0d..b7597d96 100644 --- a/man/get_downloads.Rd +++ b/man/get_downloads.Rd @@ -81,11 +81,14 @@ off. \examples{ \dontrun{ # To find the downloads object of dataset 24: -tryCatch({ - downloads24 <- get_downloads(24) -}, error = function(e) { - message("Neotoma server not responding. Try again later.") -}) +tryCatch( + { + downloads24 <- get_downloads(24) + }, + error = function(e) { + message("Neotoma server not responding. Try again later.") + } +) # To find all downloads in Brazil brazil <- '{"type": "Polygon", "coordinates": [[ @@ -94,12 +97,15 @@ brazil <- '{"type": "Polygon", [-36.5625,-7.710991655433217], [-68.203125,13.923403897723347], [-73.125,-9.102096738726443]]]}' -tryCatch({ - brazil_datasets <- get_datasets(loc = brazil[1]) - brazil_downloads <- get_downloads(brazil_datasets) -}, error = function(e) { - message("Neotoma server not responding. Try again later.") -}) +tryCatch( + { + brazil_datasets <- get_datasets(loc = brazil[1]) + brazil_downloads <- get_downloads(brazil_datasets) + }, + error = function(e) { + message("Neotoma server not responding. Try again later.") + } +) } } \author{ diff --git a/man/get_manual.Rd b/man/get_manual.Rd index e0213852..548ed6a8 100644 --- a/man/get_manual.Rd +++ b/man/get_manual.Rd @@ -17,7 +17,7 @@ Open up the Neotoma manual homepage. # This call does not work from `source()` calls or in testing. # interactive() just lets us know you are interacting with the console: if (interactive()) { - get_manual() + get_manual() } } } diff --git a/man/get_publications.Rd b/man/get_publications.Rd index efa11cd6..58c4e77a 100644 --- a/man/get_publications.Rd +++ b/man/get_publications.Rd @@ -44,31 +44,40 @@ about publications associated with data in the Neotoma Paleoecology Database \examples{ \dontrun{ # How old are the papers in Neotoma that include the term "mammut"? -tryCatch({ - mammoth_papers <- get_publications(search="mammut") \%>\% - as.data.frame() - hist(as.numeric(mammoth_papers$year)) -}, error = function(e) { - message("Neotoma server not responding. Try again later.") -}) +tryCatch( + { + mammoth_papers <- get_publications(search = "mammut") \%>\% + as.data.frame() + hist(as.numeric(mammoth_papers$year)) + }, + error = function(e) { + message("Neotoma server not responding. Try again later.") + } +) # We want the paper identified in Neotoma as 666: -tryCatch({ -get_publications(666) -}, error = function(e) { -message("Neotoma server not responding. Try again later.") -}) +tryCatch( + { + get_publications(666) + }, + error = function(e) { + message("Neotoma server not responding. Try again later.") + } +) # Take a publication object and purposely degrade the metadata: -tryCatch({ - bad_pub <- get_publications(666) - # Note this only changes the reported year, not the citation string. - bad_pub[[1]]@year <- "1923" - bad_pub[[1]]@publicationid <- NA_integer_ - updated_pubs <- get_publications(bad_pub[[1]]) - attr(updated_pubs, "matches") - # we see the proper citation in the record: - updated_pubs <- attr(updated_pubs, "matches")[[3]] -}, error = function(e) { - message("Neotoma server not responding. Try again later.") -}) +tryCatch( + { + bad_pub <- get_publications(666) + # Note this only changes the reported year, not the citation string. + bad_pub[[1]]@year <- "1923" + bad_pub[[1]]@publicationid <- NA_integer_ + updated_pubs <- get_publications(bad_pub[[1]]) + attr(updated_pubs, "matches") + # we see the proper citation in the record: + updated_pubs <- attr(updated_pubs, "matches")[[3]] + }, + error = function(e) { + message("Neotoma server not responding. Try again later.") + } +) } } diff --git a/man/get_sites.Rd b/man/get_sites.Rd index e249aaab..5dc2ffd8 100644 --- a/man/get_sites.Rd +++ b/man/get_sites.Rd @@ -94,8 +94,8 @@ and datasets located at that site. \examples{ \dontrun{ ## Find sites with a min altitude of 12m and a max altitude of 25m -sites_12to25 <- get_sites(altmin=12, altmax=25) -sites_2500 <- get_sites(altmin=2500, all_data = TRUE) +sites_12to25 <- get_sites(altmin = 12, altmax = 25) +sites_2500 <- get_sites(altmin = 2500, all_data = TRUE) ## To find sites in Brazil brazil <- '{"type": "Polygon", "coordinates": [[ diff --git a/man/get_speleothems.Rd b/man/get_speleothems.Rd index f9702f42..40dffa16 100644 --- a/man/get_speleothems.Rd +++ b/man/get_speleothems.Rd @@ -38,7 +38,7 @@ vector of dataset IDs. \examples{ \dontrun{ ## Find speleothems by numeric datasetid: -speleo <- get_speleothems(c(2,5)) +speleo <- get_speleothems(c(2, 5)) } } \author{ diff --git a/man/get_stats.Rd b/man/get_stats.Rd index ba80d05d..4c32f434 100644 --- a/man/get_stats.Rd +++ b/man/get_stats.Rd @@ -37,11 +37,14 @@ high value for \code{end}). } \examples{ \dontrun{ -tryCatch({ -last_month <- get_stats(start = 0, end = 1, type = "dsdbmonth") -}, error = function(e) { - message("Neotoma server not responding. Try again later.") -}) +tryCatch( + { + last_month <- get_stats(start = 0, end = 1, type = "dsdbmonth") + }, + error = function(e) { + message("Neotoma server not responding. Try again later.") + } +) } } \author{ diff --git a/man/get_table.Rd b/man/get_table.Rd index 6e1e9905..378ecc80 100644 --- a/man/get_table.Rd +++ b/man/get_table.Rd @@ -30,6 +30,6 @@ Call Neotoma and return a table \examples{ \dontrun{ # Returns only the first 25 specimen records. -someSpec <- get_table('specimens') +someSpec <- get_table("specimens") } } diff --git a/man/plotLeaflet-sites-method.Rd b/man/plotLeaflet-sites-method.Rd index 4be5e233..9e778fcd 100644 --- a/man/plotLeaflet-sites-method.Rd +++ b/man/plotLeaflet-sites-method.Rd @@ -18,11 +18,14 @@ Plot sites on a leaflet map \examples{ \dontrun{ # Note that by default the limit for queries is 25 records: -tryCatch({ -modernSites <- get_sites(keyword = "Modern") -plotLeaflet(modernSites) -}, error = function(e) { - message("Neotoma server not responding. Try again later.") -}) +tryCatch( + { + modernSites <- get_sites(keyword = "Modern") + plotLeaflet(modernSites) + }, + error = function(e) { + message("Neotoma server not responding. Try again later.") + } +) } } diff --git a/man/publications_classes.Rd b/man/publications_classes.Rd index 63562a50..b415e6e2 100644 --- a/man/publications_classes.Rd +++ b/man/publications_classes.Rd @@ -17,16 +17,17 @@ or more publication classes associated with it. } \examples{ { -simon <- new("contact", familyname = "Goring", givennames = "Simon J.") -socorro <- new("contact", familyname = "Dominguez", givennames = "Socorro") -first_author <- new("author", author = simon, order = 1) -second_author <- new("author", author = socorro, order = 2) -author_list <- new("authors", authors = list(first_author, second_author)) -pub <- new("publication", - articletitle = "Top or bottom: Best toast spreading surfaces.", - journal = "Peanut Butter Science", - year = "2022", - volume = "2", - author = author_list) - } + simon <- new("contact", familyname = "Goring", givennames = "Simon J.") + socorro <- new("contact", familyname = "Dominguez", givennames = "Socorro") + first_author <- new("author", author = simon, order = 1) + second_author <- new("author", author = socorro, order = 2) + author_list <- new("authors", authors = list(first_author, second_author)) + pub <- new("publication", + articletitle = "Top or bottom: Best toast spreading surfaces.", + journal = "Peanut Butter Science", + year = "2022", + volume = "2", + author = author_list + ) +} } diff --git a/man/set_collunit.Rd b/man/set_collunit.Rd index 20fe6085..a2e0d8aa 100644 --- a/man/set_collunit.Rd +++ b/man/set_collunit.Rd @@ -67,8 +67,8 @@ The new object will not be uploaded to the database. } \examples{ { -# Create a collunit -my_collunit <- set_collunit(notes = "my lake") + # Create a collunit + my_collunit <- set_collunit(notes = "my lake") } } \author{ diff --git a/man/set_contact.Rd b/man/set_contact.Rd index cc809363..24a8ee93 100644 --- a/man/set_contact.Rd +++ b/man/set_contact.Rd @@ -38,7 +38,8 @@ without spaces (e.g. \code{G.G.}).} \code{George Gaylord}). Initials with spaces are used if full given names are not known (e.g. \code{G. G}).} -\item{contactname}{Full name of a person (e.g. \code{George Gaylord Simpson}).} +\item{contactname}{Full name of a person (e.g. \code{George Gaylord +Simpson}).} \item{suffix}{Suffix of a person’s name (e.g. \code{Jr.}, \code{III}).} diff --git a/man/set_dataset.Rd b/man/set_dataset.Rd index 07746cbe..8c347d6e 100644 --- a/man/set_dataset.Rd +++ b/man/set_dataset.Rd @@ -59,10 +59,12 @@ The new object will not be uploaded to the database. } \examples{ { -# Create a dataset -my_dataset <- set_dataset(database = "EPD", - datasettype = "pollen", - notes = "my lake") + # Create a dataset + my_dataset <- set_dataset( + database = "EPD", + datasettype = "pollen", + notes = "my lake" + ) } } \author{ diff --git a/man/set_sample.Rd b/man/set_sample.Rd index 97653d45..d10bf0fe 100644 --- a/man/set_sample.Rd +++ b/man/set_sample.Rd @@ -50,8 +50,8 @@ The new object will not be uploaded to the database. } \examples{ { -# Set an empty sample -my_sample <- set_sample() + # Set an empty sample + my_sample <- set_sample() } } \author{ diff --git a/man/set_site.Rd b/man/set_site.Rd index 7683bf2b..af1c9fe5 100644 --- a/man/set_site.Rd +++ b/man/set_site.Rd @@ -50,12 +50,14 @@ set Site Information for Fossil Sites } \examples{ { -# Create a site called "My Lake", to -x <- sf::st_as_sf(sf::st_sfc(sf::st_point(c(5,5)))) -my_site <- set_site(sitename = "My Lake", - geography = x, - description = "my lake", - altitude = 30) + # Create a site called "My Lake", to + x <- sf::st_as_sf(sf::st_sfc(sf::st_point(c(5, 5)))) + my_site <- set_site( + sitename = "My Lake", + geography = x, + description = "my lake", + altitude = 30 + ) } } \author{ diff --git a/man/sub-sub.Rd b/man/sub-sub.Rd index 92dcc29a..97cdfbe9 100644 --- a/man/sub-sub.Rd +++ b/man/sub-sub.Rd @@ -64,7 +64,7 @@ Obtain one of the elements within a \code{sites}, } \examples{ \dontrun{ -some_site <- get_sites(sitename = "Site\%", limit=3) +some_site <- get_sites(sitename = "Site\%", limit = 3) some_site[[2]] } } diff --git a/man/toWide.Rd b/man/toWide.Rd index ae6457d9..a2c1541c 100644 --- a/man/toWide.Rd +++ b/man/toWide.Rd @@ -41,13 +41,16 @@ samples grouped by variablename and depth/age. } \examples{ \dontrun{ -fc_sites <- neotoma2::get_datasets(limit=5, datasettype = "vertebrate fauna") +fc_sites <- neotoma2::get_datasets(limit = 5, datasettype = "vertebrate +fauna") fc_ds <- fc_sites \%>\% - neotoma2::get_downloads() + neotoma2::get_downloads() fc_dl1 <- fc_dl[[1]] fc_smp <- samples(fc_dl1) -toWide(fc_smp, ecologicalgroups=c('AVES', 'RODE'), - elementtypes='bone/tooth', unit='present/absent') +toWide(fc_smp, + ecologicalgroups = c("AVES", "RODE"), + elementtypes = "bone/tooth", unit = "present/absent" +) } } \author{ diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 6d05d9c4..c174109e 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -35,14 +35,23 @@ skip_if_api_unreachable <- function(seconds = 12) { old_r <- Sys.getenv("NEOTOMA_RETRIES", unset = NA) Sys.setenv(NEOTOMA_TIMEOUT = seconds, NEOTOMA_RETRIES = 1) on.exit({ - if (is.na(old_t)) Sys.unsetenv("NEOTOMA_TIMEOUT") else + if (is.na(old_t)) { + Sys.unsetenv("NEOTOMA_TIMEOUT") + } else { Sys.setenv(NEOTOMA_TIMEOUT = old_t) - if (is.na(old_r)) Sys.unsetenv("NEOTOMA_RETRIES") else + } + if (is.na(old_r)) { + Sys.unsetenv("NEOTOMA_RETRIES") + } else { Sys.setenv(NEOTOMA_RETRIES = old_r) + } }) - ok <- tryCatch({ - suppressWarnings(get_datasets(loc = brazil_json[1], limit = 1)) - TRUE - }, error = function(e) FALSE) + ok <- tryCatch( + { + suppressWarnings(get_datasets(loc = brazil_json[1], limit = 1)) + TRUE + }, + error = function(e) FALSE + ) if (!isTRUE(ok)) testthat::skip("Neotoma API (spatial endpoint) unreachable") } diff --git a/tests/testthat/test_add_chronology.R b/tests/testthat/test_add_chronology.R index 1f8d296c..07ba07ec 100644 --- a/tests/testthat/test_add_chronology.R +++ b/tests/testthat/test_add_chronology.R @@ -20,36 +20,42 @@ test_that("Add a new chronology to a record:", { select(depth, analysisunitid) %>% unique() %>% arrange(depth) - new_chron <- Bchron::Bchronology(ages = controls$chroncontrolage, - ageSds = abs(controls$agelimityounger - - controls$chroncontrolage), - calCurves = c("normal", rep("intcal20", 4)), - positionThicknesses = controls$thickness, - positions = controls$depth, - allowOutside = TRUE, - ids = controls$chroncontrolid) + new_chron <- Bchron::Bchronology( + ages = controls$chroncontrolage, + ageSds = abs(controls$agelimityounger - controls$chroncontrolage), + calCurves = c("normal", rep("intcal20", 4)), + positionThicknesses = controls$thickness, + positions = controls$depth, + allowOutside = TRUE, + ids = controls$chroncontrolid + ) newpredictions <- predict(new_chron, predict_depths$depth) - new_chron_stara <- set_chronology(agemodel = "Bchron model", - isdefault = TRUE, - ageboundolder = max(newpredictions), - ageboundyounger = min(newpredictions), - dateprepared = Sys.Date(), - modelagetype = "Calibrated radiocarbon years BP", - chronologyname = "Simon's example chronology", - chroncontrols = controls) + new_chron_stara <- set_chronology( + agemodel = "Bchron model", + isdefault = TRUE, + ageboundolder = max(newpredictions), + ageboundyounger = min(newpredictions), + dateprepared = Sys.Date(), + modelagetype = "Calibrated radiocarbon years BP", + chronologyname = "Simon's example chronology", + chroncontrols = controls + ) new_sample_ages <- data.frame(predict_depths, - age = colMeans(newpredictions), - ageolder = colMeans(newpredictions) + - apply(newpredictions, 2, sd), - ageyounger = colMeans(newpredictions) - - apply(newpredictions, 2, sd), - agetype = "Calibrated radiocarbon years") - stara[[1]]$collunits[[1]] <- add_chronology(stara[[1]]$collunits[[1]], - new_chron_stara, - new_sample_ages) + age = colMeans(newpredictions), + ageolder = colMeans(newpredictions) + + apply(newpredictions, 2, sd), + ageyounger = colMeans(newpredictions) - + apply(newpredictions, 2, sd), + agetype = "Calibrated radiocarbon years" + ) + stara[[1]]$collunits[[1]] <- add_chronology( + stara[[1]]$collunits[[1]], + new_chron_stara, + new_sample_ages + ) last_age <- samples(stara) %>% dplyr::filter(analysisunitid == 194633) %>% select(age) %>% unique() testthat::expect_true(last_age == new_sample_ages$age[nrow(new_sample_ages)]) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_c.R b/tests/testthat/test_c.R index d43f2d78..7f01e17d 100644 --- a/tests/testthat/test_c.R +++ b/tests/testthat/test_c.R @@ -4,23 +4,23 @@ library("httptest") context("Concatenation of c() in `neotoma2` objects works appropriately.") httptest::with_mock_api({ -test_that("c() concats properly.", { - skip_on_cran() - alex <- get_sites(24) - site5 <- get_sites(5) - sites <- c(alex, site5) - testthat::expect_equal(length(sites), 2) -}) + test_that("c() concats properly.", { + skip_on_cran() + alex <- get_sites(24) + site5 <- get_sites(5) + sites <- c(alex, site5) + testthat::expect_equal(length(sites), 2) + }) -test_that("c() removes duplicates properly.", { - skip_on_cran() - alex <- get_sites(24) - alex2 <- get_datasets(7870) - sites <- c(alex, alex2) - testthat::expect_equal(length(sites), 1) - - site5 <- get_sites(5) - sites <- c(sites, site5) - testthat::expect_equal(length(sites), 2) -}) + test_that("c() removes duplicates properly.", { + skip_on_cran() + alex <- get_sites(24) + alex2 <- get_datasets(7870) + sites <- c(alex, alex2) + testthat::expect_equal(length(sites), 1) + + site5 <- get_sites(5) + sites <- c(sites, site5) + testthat::expect_equal(length(sites), 2) + }) }) diff --git a/tests/testthat/test_chroncontrols.R b/tests/testthat/test_chroncontrols.R index f06c1bba..608c1cab 100644 --- a/tests/testthat/test_chroncontrols.R +++ b/tests/testthat/test_chroncontrols.R @@ -5,27 +5,27 @@ library("httptest") context("Chronology controls functions work as expected.") httptest::with_mock_api({ -test_that("Chroncontrols gets record", { - skip_on_cran() - single <- chroncontrols(get_downloads(4716)) - multi <- chroncontrols(get_downloads(21007)) - mamchron <- chroncontrols(get_downloads(4564)) - - testthat::expect_is(single, "data.frame") - testthat::expect_equal(length(unique(single$chronologyid)), 3) - testthat::expect_is(multi, "data.frame") - testthat::expect_gt(length(unique(multi$chronologyid)), 4) - testthat::expect_is(mamchron, "data.frame") -}) + test_that("Chroncontrols gets record", { + skip_on_cran() + single <- chroncontrols(get_downloads(4716)) + multi <- chroncontrols(get_downloads(21007)) + mamchron <- chroncontrols(get_downloads(4564)) + + testthat::expect_is(single, "data.frame") + testthat::expect_equal(length(unique(single$chronologyid)), 3) + testthat::expect_is(multi, "data.frame") + testthat::expect_gt(length(unique(multi$chronologyid)), 4) + testthat::expect_is(mamchron, "data.frame") + }) }) context("Chronology controls return nothing when nothing.") httptest::with_mock_api({ -test_that("Chroncontrols is empty for a record with no chronology", { - skip_on_cran() - empty <- chroncontrols(get_downloads(100)) + test_that("Chroncontrols is empty for a record with no chronology", { + skip_on_cran() + empty <- chroncontrols(get_downloads(100)) - testthat::expect_s3_class(empty, "data.frame") - testthat::expect_equal(nrow(empty), 0) -}) + testthat::expect_s3_class(empty, "data.frame") + testthat::expect_equal(nrow(empty), 0) + }) }) diff --git a/tests/testthat/test_chronologies.R b/tests/testthat/test_chronologies.R index f74a08a9..a340ed1d 100644 --- a/tests/testthat/test_chronologies.R +++ b/tests/testthat/test_chronologies.R @@ -2,30 +2,32 @@ library("testthat") library("neotoma2") library("httptest") -context("`chronologies()` function displays all chronologies for a download object") +context("`chronologies()` displays all chronologies for a download object") httptest::with_mock_api({ -test_that("`get_downloads()` fills up chronologies' slots.", { - skip_on_cran() - dl <- get_downloads(4716) - chron <- dl %>% chronologies() %>% as.data.frame() + test_that("`get_downloads()` fills up chronologies' slots.", { + skip_on_cran() + dl <- get_downloads(4716) + chron <- dl %>% + chronologies() %>% + as.data.frame() - testthat::expect_is(dl[[1]]@collunits[[1]]@chronologies, "chronologies") - testthat::expect_true(nrow(chron) > 1) - testthat::expect_true(any(chron$chronologyid == 2195)) - # Only one isdefault value - # Careful, if the DB is wrong, so will the API and this test will fail - testthat::expect_equal(sum(chron$isdefault), 1) - testthat::expect_is(chron, "data.frame") -}) + testthat::expect_is(dl[[1]]@collunits[[1]]@chronologies, "chronologies") + testthat::expect_true(nrow(chron) > 1) + testthat::expect_true(any(chron$chronologyid == 2195)) + # Only one isdefault value + # Careful, if the DB is wrong, so will the API and this test will fail + testthat::expect_equal(sum(chron$isdefault), 1) + testthat::expect_is(chron, "data.frame") + }) }) context("`chronologies()` function is empty for empty downloads") httptest::with_mock_api({ -test_that("`chronologies()` is empty for a record with no chronology", { - skip_on_cran() - dl <- get_downloads(100) - chron <- dl %>% chronologies() + test_that("`chronologies()` is empty for a record with no chronology", { + skip_on_cran() + dl <- get_downloads(100) + chron <- dl %>% chronologies() - testthat::expect_equal(length(chron@chronologies), 0) -}) + testthat::expect_equal(length(chron@chronologies), 0) + }) }) diff --git a/tests/testthat/test_cite_data.R b/tests/testthat/test_cite_data.R index 5c3ee594..3d5a62ac 100644 --- a/tests/testthat/test_cite_data.R +++ b/tests/testthat/test_cite_data.R @@ -6,30 +6,30 @@ library("httptest") context("`cite_data()` function") httptest::with_mock_api({ -test_that("cite_data() returns dataframe", { - skip_on_cran() - st <- get_sites(c(24, 100)) - citation <- cite_data(st) - testthat::expect_is(citation, "data.frame") -}) + test_that("cite_data() returns dataframe", { + skip_on_cran() + st <- get_sites(c(24, 100)) + citation <- cite_data(st) + testthat::expect_is(citation, "data.frame") + }) -test_that("cite_data() returns correct DOIs for each dataset", { - skip_on_cran() - st <- get_datasets(c(24, 100)) - citation <- cite_data(st) - cit24 <- citation %>% - dplyr::filter(datasetid == 24) - cit24 <- cit24$citation - doi24 <- st[[1]]@collunits[[1]]@datasets[[1]]@doi %>% unlist() - # expect that doi is in citation string - testthat::expect_true(any(str_detect(cit24, fixed(doi24)))) - cit100 <- citation %>% - filter(datasetid == 100) - cit100 <- cit100$citation - doi100 <- st[[2]]@collunits[[1]]@datasets[[1]]@doi %>% unlist() - # expect that doi is in citation string - testthat::expect_true(any(str_detect(cit100, fixed(doi100)))) - testthat::expect_false(any(str_detect(cit100, fixed(doi24)))) - testthat::expect_false(any(str_detect(cit24, fixed(doi100)))) -}) + test_that("cite_data() returns correct DOIs for each dataset", { + skip_on_cran() + st <- get_datasets(c(24, 100)) + citation <- cite_data(st) + cit24 <- citation %>% + dplyr::filter(datasetid == 24) + cit24 <- cit24$citation + doi24 <- st[[1]]@collunits[[1]]@datasets[[1]]@doi %>% unlist() + # expect that doi is in citation string + testthat::expect_true(any(str_detect(cit24, fixed(doi24)))) + cit100 <- citation %>% + filter(datasetid == 100) + cit100 <- cit100$citation + doi100 <- st[[2]]@collunits[[1]]@datasets[[1]]@doi %>% unlist() + # expect that doi is in citation string + testthat::expect_true(any(str_detect(cit100, fixed(doi100)))) + testthat::expect_false(any(str_detect(cit100, fixed(doi24)))) + testthat::expect_false(any(str_detect(cit24, fixed(doi100)))) + }) }) diff --git a/tests/testthat/test_clean.R b/tests/testthat/test_clean.R index 215f5835..cf162642 100644 --- a/tests/testthat/test_clean.R +++ b/tests/testthat/test_clean.R @@ -6,28 +6,30 @@ context("Verifying that neotoma objects do not have duplicates and are nested properly respecting Neotoma's data object: site <- cu <- ds") httptest::with_mock_api({ -test_that("Doubling a set of records results and cleaning results in a clean set.", { - skip_on_cran() - # c calls clean internally but we can call it again to be sure - # Runs offline against recorded fixtures (see tests/testthat/fixtures/). - # Site 24 is one of the sites returned by the "Alex%" search, so combining - # the two sets must not grow the set: `c()` cleans internally, and a second - # explicit `clean()` must be a no-op rather than dropping or duplicating. - alex <- get_sites(sitename = "Alex%") - alex2 <- get_sites(24) - alex_sets <- c(alex, alex2) - clean_al <- clean(alex_sets, verbose = FALSE) - testthat::expect_equal(length(alex_sets), length(alex)) - testthat::expect_equal(length(clean_al), length(alex_sets)) - # Read siteids off the site objects: `as.data.frame()` returns one row per - # collection unit, so a multi-collunit site would look duplicated there. - clean_ids <- vapply(clean_al@sites, function(s) as.numeric(s@siteid), - numeric(1)) - testthat::expect_false(any(duplicated(clean_ids))) - fiftyds <- get_datasets(limit = 50) - nextds <- get_datasets(limit = 50) - doubled <- c(fiftyds, nextds) - testthat::expect_equal(getids(doubled), getids(nextds)) - testthat::expect_equal(length(doubled), length(fiftyds)) + test_that("Doubling a set of records and cleaning gives a clean set.", { + skip_on_cran() + # c calls clean internally but we can call it again to be sure + # Runs offline against recorded fixtures (see tests/testthat/fixtures/). + # Site 24 is one of the sites returned by the "Alex%" search, so combining + # the two sets must not grow the set: `c()` cleans internally, and a second + # explicit `clean()` must be a no-op rather than dropping or duplicating. + alex <- get_sites(sitename = "Alex%") + alex2 <- get_sites(24) + alex_sets <- c(alex, alex2) + clean_al <- clean(alex_sets, verbose = FALSE) + testthat::expect_equal(length(alex_sets), length(alex)) + testthat::expect_equal(length(clean_al), length(alex_sets)) + # Read siteids off the site objects: `as.data.frame()` returns one row per + # collection unit, so a multi-collunit site would look duplicated there. + clean_ids <- vapply( + clean_al@sites, function(s) as.numeric(s@siteid), + numeric(1) + ) + testthat::expect_false(any(duplicated(clean_ids))) + fiftyds <- get_datasets(limit = 50) + nextds <- get_datasets(limit = 50) + doubled <- c(fiftyds, nextds) + testthat::expect_equal(getids(doubled), getids(nextds)) + testthat::expect_equal(length(doubled), length(fiftyds)) + }) }) -}) \ No newline at end of file diff --git a/tests/testthat/test_collunits.R b/tests/testthat/test_collunits.R index 01d18a74..789b2457 100644 --- a/tests/testthat/test_collunits.R +++ b/tests/testthat/test_collunits.R @@ -3,19 +3,21 @@ library("neotoma2") library("httptest") httptest::with_mock_api({ -test_that("collunits()`", { - skip_on_cran() - # Bounded to a few known sites so the recorded fixture stays small; the - # accessor assertions below hold for any handful of sites. - dls <- get_sites(c(24, 1001, 2001)) %>% - get_downloads() - sumDl <- summary(dls) - ids <- getids(dls) - cus <- collunits(dls) - testthat::expect_identical(length(unique(cus$collectionunitid)), - length(unique(ids$collunitid))) - testthat::expect_true(all(sumDl$collunit_name %in% cus$handle)) -}) + test_that("collunits()`", { + skip_on_cran() + # Bounded to a few known sites so the recorded fixture stays small; the + # accessor assertions below hold for any handful of sites. + dls <- get_sites(c(24, 1001, 2001)) %>% + get_downloads() + sum_dl <- summary(dls) + ids <- getids(dls) + cus <- collunits(dls) + testthat::expect_identical( + length(unique(cus$collectionunitid)), + length(unique(ids$collunitid)) + ) + testthat::expect_true(all(sum_dl$collunit_name %in% cus$handle)) + }) }) ## Not every site has collection units -- the API returns some with none at all. @@ -26,9 +28,11 @@ test_that("collunits()`", { test_that("collection units combine when some sites have none", { empty <- methods::new("collunits", collunits = list()) one <- methods::new("collunits", - collunits = list(set_collunit(handle = "CU1"))) + collunits = list(set_collunit(handle = "CU1")) + ) two <- methods::new("collunits", - collunits = list(set_collunit(handle = "CU2"))) + collunits = list(set_collunit(handle = "CU2")) + ) testthat::expect_equal(length(c(empty, empty)), 0) testthat::expect_equal(length(c(empty, one)), 1) diff --git a/tests/testthat/test_coordinates.R b/tests/testthat/test_coordinates.R index abef5ddf..1ddd4a8c 100644 --- a/tests/testthat/test_coordinates.R +++ b/tests/testthat/test_coordinates.R @@ -4,16 +4,16 @@ library("httptest") context("`coordinates()` function") httptest::with_mock_api({ -testthat::test_that("coordinates() returns correct coordinates", { - skip_on_cran() - sts <- get_sites(c(101, 102)) - sts_df <- as.data.frame(sts) - coords <- coordinates(sts) - testthat::expect_is(coords, "data.frame") - testthat::expect_equal(nrow(coords), 2) - testthat::expect_equal(ncol(coords), 3) - testthat::expect_equal(coords$siteid, sts_df$siteid) - testthat::expect_equal(coords$latitude, sts_df$latitude, tolerance = 0.01) - testthat::expect_equal(coords$longitude, sts_df$longitude, tolerance = 0.01) + testthat::test_that("coordinates() returns correct coordinates", { + skip_on_cran() + sts <- get_sites(c(101, 102)) + sts_df <- as.data.frame(sts) + coords <- coordinates(sts) + testthat::expect_is(coords, "data.frame") + testthat::expect_equal(nrow(coords), 2) + testthat::expect_equal(ncol(coords), 3) + testthat::expect_equal(coords$siteid, sts_df$siteid) + testthat::expect_equal(coords$latitude, sts_df$latitude, tolerance = 0.01) + testthat::expect_equal(coords$longitude, sts_df$longitude, tolerance = 0.01) + }) }) -}) \ No newline at end of file diff --git a/tests/testthat/test_datasets.R b/tests/testthat/test_datasets.R index 5bf81942..c2c2157e 100644 --- a/tests/testthat/test_datasets.R +++ b/tests/testthat/test_datasets.R @@ -3,18 +3,20 @@ library("neotoma2") library("httptest") httptest::with_mock_api({ -test_that("`datasets()`", { - skip_on_cran() - # Bounded to a few known sites so the recorded fixture stays small; the - # accessor invariants below hold for any handful of sites. - dls <- get_sites(c(24, 1001, 2001)) %>% - get_downloads() - sumDl <- summary(dls) - ids <- getids(dls) - dss <- datasets(dls) - testthat::expect_identical(length(dss), nrow(ids)) - testthat::expect_identical(sum(sumDl$n_datasets), nrow(ids)) - testthat::expect_identical(length(unique(dss$datasetid)), - length(unique(ids$datasetid))) -}) + test_that("`datasets()`", { + skip_on_cran() + # Bounded to a few known sites so the recorded fixture stays small; the + # accessor invariants below hold for any handful of sites. + dls <- get_sites(c(24, 1001, 2001)) %>% + get_downloads() + sum_dl <- summary(dls) + ids <- getids(dls) + dss <- datasets(dls) + testthat::expect_identical(length(dss), nrow(ids)) + testthat::expect_identical(sum(sum_dl$n_datasets), nrow(ids)) + testthat::expect_identical( + length(unique(dss$datasetid)), + length(unique(ids$datasetid)) + ) + }) }) diff --git a/tests/testthat/test_doi.R b/tests/testthat/test_doi.R index 8fc0d16d..ea6f9df3 100644 --- a/tests/testthat/test_doi.R +++ b/tests/testthat/test_doi.R @@ -4,37 +4,52 @@ library("httptest") context("`doi()` function") httptest::with_mock_api({ -test_that("", { - skip_on_cran() - sts <- get_datasets(c(24, 100, 101)) - dois <- doi(sts) - testthat::expect_is(dois, "data.frame") - st24 <- sts[[1]] - doi24 <- purrr::map(datasets(st24)@datasets, - function(x) { - doi <- x@doi - unlist(doi, recursive = TRUE, use.names = FALSE) - }) %>% unlist() - dois24_df <- dois %>% dplyr::filter(siteid == 24) %>% dplyr::pull(doi) %>% unlist() - testthat::expect_true(all(doi24 %in% dois24_df)) - testthat::expect_true(all(dois24_df %in% doi24)) - st100 <- sts[[2]] - doi100 <- purrr::map(datasets(st100)@datasets, - function(x) { - doi <- x@doi - unlist(doi, recursive = TRUE, use.names = FALSE) - }) %>% unlist() - dois100_df <- dois %>% dplyr::filter(siteid == 100) %>% dplyr::pull(doi) %>% unlist() - testthat::expect_true(all(doi100 %in% dois100_df)) - testthat::expect_true(all(dois100_df %in% doi100)) - st101 <- sts[[3]] - doi101 <- purrr::map(datasets(st101)@datasets, - function(x) { - doi <- x@doi - unlist(doi, recursive = TRUE, use.names = FALSE) - }) %>% unlist() - dois101_df <- dois %>% dplyr::filter(siteid == 101) %>% dplyr::pull(doi) %>% unlist() - testthat::expect_true(all(doi101 %in% dois101_df)) - testthat::expect_true(all(dois101_df %in% doi101)) -}) + test_that("", { + skip_on_cran() + sts <- get_datasets(c(24, 100, 101)) + dois <- doi(sts) + testthat::expect_is(dois, "data.frame") + st24 <- sts[[1]] + doi24 <- purrr::map( + datasets(st24)@datasets, + function(x) { + doi <- x@doi + unlist(doi, recursive = TRUE, use.names = FALSE) + } + ) %>% unlist() + dois24_df <- dois %>% + dplyr::filter(siteid == 24) %>% + dplyr::pull(doi) %>% + unlist() + testthat::expect_true(all(doi24 %in% dois24_df)) + testthat::expect_true(all(dois24_df %in% doi24)) + st100 <- sts[[2]] + doi100 <- purrr::map( + datasets(st100)@datasets, + function(x) { + doi <- x@doi + unlist(doi, recursive = TRUE, use.names = FALSE) + } + ) %>% unlist() + dois100_df <- dois %>% + dplyr::filter(siteid == 100) %>% + dplyr::pull(doi) %>% + unlist() + testthat::expect_true(all(doi100 %in% dois100_df)) + testthat::expect_true(all(dois100_df %in% doi100)) + st101 <- sts[[3]] + doi101 <- purrr::map( + datasets(st101)@datasets, + function(x) { + doi <- x@doi + unlist(doi, recursive = TRUE, use.names = FALSE) + } + ) %>% unlist() + dois101_df <- dois %>% + dplyr::filter(siteid == 101) %>% + dplyr::pull(doi) %>% + unlist() + testthat::expect_true(all(doi101 %in% dois101_df)) + testthat::expect_true(all(dois101_df %in% doi101)) + }) }) diff --git a/tests/testthat/test_examples.R b/tests/testthat/test_examples.R index 4802a023..16d094b9 100644 --- a/tests/testthat/test_examples.R +++ b/tests/testthat/test_examples.R @@ -13,13 +13,16 @@ for (topic in topics) { test_that(paste0("Example for '", topic, "' runs without error"), { skip_on_cran() testthat::expect_error( - example(topic = t, - package = "neotoma2", - ask = FALSE, - character.only = TRUE, - run.dontrun = TRUE, - echo = FALSE), - NA) + example( + topic = t, + package = "neotoma2", + ask = FALSE, + character.only = TRUE, + run.dontrun = TRUE, + echo = FALSE + ), + NA + ) }) }) -} \ No newline at end of file +} diff --git a/tests/testthat/test_filter.R b/tests/testthat/test_filter.R index 23a2c1cd..76377eef 100644 --- a/tests/testthat/test_filter.R +++ b/tests/testthat/test_filter.R @@ -9,20 +9,20 @@ context("Test that filter receives a sites object # one heavy integration test (19-site get_downloads chain) stays live below the # wrapper because its multi-site dataset URL is unmockable (filename too long). httptest::with_mock_api({ -test_that("filter datasettype", { - skip_on_cran() - sts <- get_sites() - pollen_sts <- - sts %>% - neotoma2::filter(datasettype == "pollen") - sum <- summary(pollen_sts) - pollen_types <- unique(sum$dataset_types) - testthat::expect_equal(pollen_types, "pollen") -}) + test_that("filter datasettype", { + skip_on_cran() + sts <- get_sites() + pollen_sts <- + sts %>% + neotoma2::filter(datasettype == "pollen") + sum <- summary(pollen_sts) + pollen_types <- unique(sum$dataset_types) + testthat::expect_equal(pollen_types, "pollen") + }) -test_that("filter datasettype + loc", { - skip_on_cran() - brazil <- '{"type": "Polygon", + test_that("filter datasettype + loc", { + skip_on_cran() + brazil <- '{"type": "Polygon", "coordinates": [[ [-73.125, -9.102], [-56.953, -33.138], @@ -30,191 +30,208 @@ test_that("filter datasettype + loc", { [-68.203, 13.923], [-73.125, -9.102] ]]}' - brazil_sf <- geojsonsf::geojson_sf(brazil) - brazil_datasets <- get_datasets(loc = brazil[1], limit=10) - brazil_pollen <- neotoma2::filter(brazil_datasets, datasettype == "pollen") - brazil_summary <- summary(brazil_pollen) - brazil_datatype <- unique(brazil_summary$dataset_types) - testthat::expect_equal(brazil_datatype, "pollen") -}) + brazil_sf <- geojsonsf::geojson_sf(brazil) + brazil_datasets <- get_datasets(loc = brazil[1], limit = 10) + brazil_pollen <- neotoma2::filter(brazil_datasets, datasettype == "pollen") + brazil_summary <- summary(brazil_pollen) + brazil_datatype <- unique(brazil_summary$dataset_types) + testthat::expect_equal(brazil_datatype, "pollen") + }) -test_that("filter lat & long.", { - skip_on_cran() - sts <- get_sites() - lat_sts <- - sts %>% - neotoma2::filter(lat >= 50 & lat <= 90) - latitudes <- as.data.frame(lat_sts)$lat - testthat::expect_true(all(latitudes <= 90)) - testthat::expect_true(all(latitudes >= 50)) - testthat::expect_lt(length(lat_sts), length(sts)) - testthat::expect_true(all(getids(lat_sts)$siteid %in% getids(sts)$siteid)) - testthat::expect_true(all(getids(lat_sts)$datasetid %in% getids(sts)$datasetid)) - testthat::expect_true(all(getids(lat_sts)$collunitid %in% getids(sts)$collunitid)) -}) + test_that("filter lat & long.", { + skip_on_cran() + sts <- get_sites() + lat_sts <- + sts %>% + neotoma2::filter(lat >= 50 & lat <= 90) + latitudes <- as.data.frame(lat_sts)$lat + testthat::expect_true(all(latitudes <= 90)) + testthat::expect_true(all(latitudes >= 50)) + testthat::expect_lt(length(lat_sts), length(sts)) + testthat::expect_true(all(getids(lat_sts)$siteid %in% getids(sts)$siteid)) + lat_ids <- getids(lat_sts) + all_ids <- getids(sts) + testthat::expect_true(all(lat_ids$datasetid %in% all_ids$datasetid)) + testthat::expect_true(all(lat_ids$collunitid %in% all_ids$collunitid)) + }) -test_that("filter get_datasets('datasettype') by datasettype - does not change sites", { - skip_on_cran() - ds <- get_datasets(datasettype = "pollen") - pollen_ds <- neotoma2::filter(ds, datasettype == "pollen") - testthat::expect_equal(length(ds), length(pollen_ds)) - # test ids in datastid for ds and pollen ds are the same - testthat::expect_setequal(getids(ds)$datasetid, - getids(pollen_ds)$datasetid) - }) + test_that("filter get_datasets('datasettype') does not change sites", { + skip_on_cran() + ds <- get_datasets(datasettype = "pollen") + pollen_ds <- neotoma2::filter(ds, datasettype == "pollen") + testthat::expect_equal(length(ds), length(pollen_ds)) + # test ids in datastid for ds and pollen ds are the same + testthat::expect_setequal( + getids(ds)$datasetid, + getids(pollen_ds)$datasetid + ) + }) -test_that("filter by 2 datasettypes", { - skip_on_cran() - sts <- get_sites() - filtered <- sts %>% - neotoma2::filter(datasettype == "pollen" | datasettype == "charcoal") - dst <- datasets(filtered) %>% - as.data.frame() %>% - select(datasettype) %>% - unlist() - testthat::expect_true(all(dst %in% c("pollen", "charcoal"))) -}) + test_that("filter by 2 datasettypes", { + skip_on_cran() + sts <- get_sites() + filtered <- sts %>% + neotoma2::filter(datasettype == "pollen" | datasettype == "charcoal") + dst <- datasets(filtered) %>% + as.data.frame() %>% + select(datasettype) %>% + unlist() + testthat::expect_true(all(dst %in% c("pollen", "charcoal"))) + }) -test_that("filter datasets returns a clean object", { - skip_on_cran() - sts <- get_sites() %>% - neotoma2::filter(datasettype == "pollen" | datasettype == "charcoal") - ids <- getids(sts) %>% - select(siteid) %>% - unique() %>% - nrow() - testthat::expect_equal(ids, length(sts)) - testthat::expect_lte(length(sts), nrow(summary(sts))) -}) + test_that("filter datasets returns a clean object", { + skip_on_cran() + sts <- get_sites() %>% + neotoma2::filter(datasettype == "pollen" | datasettype == "charcoal") + ids <- getids(sts) %>% + select(siteid) %>% + unique() %>% + nrow() + testthat::expect_equal(ids, length(sts)) + testthat::expect_lte(length(sts), nrow(summary(sts))) + }) -test_that("multi-condition filter across two levels (regression)", { - skip_on_cran() - sites <- get_sites(limit = 10) %>% get_datasets() - result <- sites %>% filter(altitude < 3000, datasettype == "pollen") - testthat::expect_s4_class(result, "sites") - dts <- as.data.frame(datasets(result)) - testthat::expect_true(all(dts$datasettype == "pollen")) -}) + test_that("multi-condition filter across two levels (regression)", { + skip_on_cran() + sites <- get_sites(limit = 10) %>% get_datasets() + result <- sites %>% filter(altitude < 3000, datasettype == "pollen") + testthat::expect_s4_class(result, "sites") + dts <- as.data.frame(datasets(result)) + testthat::expect_true(all(dts$datasettype == "pollen")) + }) -test_that("order of conditions does not matter", { - skip_on_cran() - sites <- get_sites(limit = 10) %>% get_datasets() - a <- sites %>% filter(altitude < 3000, datasettype == "pollen") - b <- sites %>% filter(datasettype == "pollen", altitude < 3000) - testthat::expect_equal(length(a@sites), length(b@sites)) -}) + test_that("order of conditions does not matter", { + skip_on_cran() + sites <- get_sites(limit = 10) %>% get_datasets() + a <- sites %>% filter(altitude < 3000, datasettype == "pollen") + b <- sites %>% filter(datasettype == "pollen", altitude < 3000) + testthat::expect_equal(length(a@sites), length(b@sites)) + }) -test_that("single-condition filters still work (no regression)", { - skip_on_cran() - sites <- get_sites(limit = 10) %>% get_datasets() - s_site <- sites %>% filter(altitude < 3000) - s_ds <- sites %>% filter(datasettype == "pollen") - testthat::expect_s4_class(s_site, "sites") - testthat::expect_s4_class(s_ds, "sites") -}) + test_that("single-condition filters still work (no regression)", { + skip_on_cran() + sites <- get_sites(limit = 10) %>% get_datasets() + s_site <- sites %>% filter(altitude < 3000) + s_ds <- sites %>% filter(datasettype == "pollen") + testthat::expect_s4_class(s_site, "sites") + testthat::expect_s4_class(s_ds, "sites") + }) -test_that("three levels at once", { - skip_on_cran() - sites <- get_sites(limit = 10) %>% get_datasets() - result <- sites %>% - filter(altitude < 5000, datasettype == "pollen", waterdepth > 0) - testthat::expect_s4_class(result, "sites") -}) + test_that("three levels at once", { + skip_on_cran() + sites <- get_sites(limit = 10) %>% get_datasets() + result <- sites %>% + filter(altitude < 5000, datasettype == "pollen", waterdepth > 0) + testthat::expect_s4_class(result, "sites") + }) -test_that("substring false-positive guard (value contains a column substring)", { - skip_on_cran() - sites <- get_sites(limit = 10) %>% get_datasets() - # "LONGCORE" contains "long", but the referenced column is `handle` - # (a collunit column), so only the collunit join should be triggered. - result <- sites %>% filter(handle == "SOME-LONG-HANDLE") - testthat::expect_s4_class(result, "sites") -}) + test_that("substring false-positive guard: value holds a column name", { + skip_on_cran() + sites <- get_sites(limit = 10) %>% get_datasets() + # "LONGCORE" contains "long", but the referenced column is `handle` + # (a collunit column), so only the collunit join should be triggered. + result <- sites %>% filter(handle == "SOME-LONG-HANDLE") + testthat::expect_s4_class(result, "sites") + }) -test_that("no matches returns an empty sites", { - skip_on_cran() - sites <- get_sites(limit = 10) %>% get_datasets() - result <- sites %>% filter(altitude < -100000) - testthat::expect_s4_class(result, "sites") - testthat::expect_equal(length(result@sites), 0) -}) + test_that("no matches returns an empty sites", { + skip_on_cran() + sites <- get_sites(limit = 10) %>% get_datasets() + result <- sites %>% filter(altitude < -100000) + testthat::expect_s4_class(result, "sites") + testthat::expect_equal(length(result@sites), 0) + }) -test_that("filter(NULL) warns and returns NULL", { - skip_on_cran() - testthat::expect_warning(res <- filter(NULL), "No sites to filter") - testthat::expect_null(res) -}) + test_that("filter(NULL) warns and returns NULL", { + skip_on_cran() + testthat::expect_warning(res <- filter(NULL), "No sites to filter") + testthat::expect_null(res) + }) -test_that("spatial loc filter keeps only sites inside the region", { - skip_on_cran() - brazil <- paste0('{"type": "Polygon", "coordinates": [[', - '[-73.125, -9.102], [-56.953, -33.138],', - '[-36.563, -7.711], [-68.203, 13.923],', - '[-73.125, -9.102]]]}') - brazil_sf <- geojsonsf::geojson_sf(brazil) - sites <- get_datasets(loc = brazil, limit = 20) - result <- sites %>% filter(loc == brazil_sf) - testthat::expect_s4_class(result, "sites") - testthat::expect_lte(length(result@sites), length(sites)) -}) + test_that("spatial loc filter keeps only sites inside the region", { + skip_on_cran() + brazil <- paste0( + '{"type": "Polygon", "coordinates": [[', + "[-73.125, -9.102], [-56.953, -33.138],", + "[-36.563, -7.711], [-68.203, 13.923],", + "[-73.125, -9.102]]]}" + ) + brazil_sf <- geojsonsf::geojson_sf(brazil) + sites <- get_datasets(loc = brazil, limit = 20) + result <- sites %>% filter(loc == brazil_sf) + testthat::expect_s4_class(result, "sites") + testthat::expect_lte(length(result@sites), length(sites)) + }) -test_that("loc combines with an ordinary condition", { - skip_on_cran() - brazil <- paste0('{"type": "Polygon", "coordinates": [[', - '[-73.125, -9.102], [-56.953, -33.138],', - '[-36.563, -7.711], [-68.203, 13.923],', - '[-73.125, -9.102]]]}') - brazil_sf <- geojsonsf::geojson_sf(brazil) - sites <- get_datasets(loc = brazil, limit = 20) - result <- sites %>% filter(altitude < 3000, loc == brazil_sf) - testthat::expect_s4_class(result, "sites") - elev <- as.data.frame(result)$elev - testthat::expect_true(all(elev < 3000 | is.na(elev))) -}) + test_that("loc combines with an ordinary condition", { + skip_on_cran() + brazil <- paste0( + '{"type": "Polygon", "coordinates": [[', + "[-73.125, -9.102], [-56.953, -33.138],", + "[-36.563, -7.711], [-68.203, 13.923],", + "[-73.125, -9.102]]]}" + ) + brazil_sf <- geojsonsf::geojson_sf(brazil) + sites <- get_datasets(loc = brazil, limit = 20) + result <- sites %>% filter(altitude < 3000, loc == brazil_sf) + testthat::expect_s4_class(result, "sites") + elev <- as.data.frame(result)$elev + testthat::expect_true(all(elev < 3000 | is.na(elev))) + }) -test_that("geography is an alias for loc", { - skip_on_cran() - brazil <- paste0('{"type": "Polygon", "coordinates": [[', - '[-73.125, -9.102], [-56.953, -33.138],', - '[-36.563, -7.711], [-68.203, 13.923],', - '[-73.125, -9.102]]]}') - brazil_sf <- geojsonsf::geojson_sf(brazil) - sites <- get_datasets(loc = brazil, limit = 20) - a <- sites %>% filter(loc == brazil_sf) - b <- sites %>% filter(geography == brazil_sf) - testthat::expect_equal(length(a@sites), length(b@sites)) -}) + test_that("geography is an alias for loc", { + skip_on_cran() + brazil <- paste0( + '{"type": "Polygon", "coordinates": [[', + "[-73.125, -9.102], [-56.953, -33.138],", + "[-36.563, -7.711], [-68.203, 13.923],", + "[-73.125, -9.102]]]}" + ) + brazil_sf <- geojsonsf::geojson_sf(brazil) + sites <- get_datasets(loc = brazil, limit = 20) + a <- sites %>% filter(loc == brazil_sf) + b <- sites %>% filter(geography == brazil_sf) + testthat::expect_equal(length(a@sites), length(b@sites)) + }) -test_that("filter(loc == WKT) matches filter(loc == GeoJSON)", { - skip_on_cran() - brazil_geojson <- paste0('{"type": "Polygon", "coordinates": [[', - '[-73.125, -9.102], [-56.953, -33.138],', - '[-36.563, -7.711], [-68.203, 13.923],', - '[-73.125, -9.102]]]}') - brazil_wkt <- paste0("POLYGON ((-73.125 -9.102, -56.953 -33.138, ", - "-36.563 -7.711, -68.203 13.923, -73.125 -9.102))") - sites <- get_datasets(loc = brazil_geojson, limit = 20) - a <- sites %>% filter(loc == brazil_geojson) - b <- sites %>% filter(loc == brazil_wkt) - testthat::expect_s4_class(b, "sites") - testthat::expect_equal(length(a@sites), length(b@sites)) -}) + test_that("filter(loc == WKT) matches filter(loc == GeoJSON)", { + skip_on_cran() + brazil_geojson <- paste0( + '{"type": "Polygon", "coordinates": [[', + "[-73.125, -9.102], [-56.953, -33.138],", + "[-36.563, -7.711], [-68.203, 13.923],", + "[-73.125, -9.102]]]}" + ) + brazil_wkt <- paste0( + "POLYGON ((-73.125 -9.102, -56.953 -33.138, ", + "-36.563 -7.711, -68.203 13.923, -73.125 -9.102))" + ) + sites <- get_datasets(loc = brazil_geojson, limit = 20) + a <- sites %>% filter(loc == brazil_geojson) + b <- sites %>% filter(loc == brazil_wkt) + testthat::expect_s4_class(b, "sites") + testthat::expect_equal(length(a@sites), length(b@sites)) + }) -test_that("WKT loc combines with an ordinary condition (geography alias)", { - skip_on_cran() - brazil_geojson <- paste0('{"type": "Polygon", "coordinates": [[', - '[-73.125, -9.102], [-56.953, -33.138],', - '[-36.563, -7.711], [-68.203, 13.923],', - '[-73.125, -9.102]]]}') - brazil_wkt <- paste0("POLYGON ((-73.125 -9.102, -56.953 -33.138, ", - "-36.563 -7.711, -68.203 13.923, -73.125 -9.102))") - sites <- get_datasets(loc = brazil_geojson, limit = 20) - r <- sites %>% filter(altitude < 3000, geography == brazil_wkt) - testthat::expect_s4_class(r, "sites") - elev <- as.data.frame(r)$elev - testthat::expect_true(all(elev < 3000 | is.na(elev))) -}) -}) # end with_mock_api + test_that("WKT loc combines with an ordinary condition (geography alias)", { + skip_on_cran() + brazil_geojson <- paste0( + '{"type": "Polygon", "coordinates": [[', + "[-73.125, -9.102], [-56.953, -33.138],", + "[-36.563, -7.711], [-68.203, 13.923],", + "[-73.125, -9.102]]]}" + ) + brazil_wkt <- paste0( + "POLYGON ((-73.125 -9.102, -56.953 -33.138, ", + "-36.563 -7.711, -68.203 13.923, -73.125 -9.102))" + ) + sites <- get_datasets(loc = brazil_geojson, limit = 20) + r <- sites %>% filter(altitude < 3000, geography == brazil_wkt) + testthat::expect_s4_class(r, "sites") + elev <- as.data.frame(r)$elev + testthat::expect_true(all(elev < 3000 | is.na(elev))) + }) +}) # end with_mock_api # --------------------------------------------------------------------------- # Live integration tests. These download whole records that are too large to @@ -228,37 +245,38 @@ test_that("filter by collunitid removes samples", { skip_on_ci() meer <- get_sites(sitename = "meerfeld%") %>% get_downloads() - meerDS42510 <- meer %>% + meer_ds42510 <- meer %>% neotoma2::filter(collunitid == 29576) %>% samples() - testthat::expect_true(all(meerDS42510$collectionunitid == 29576)) + testthat::expect_true(all(meer_ds42510$collectionunitid == 29576)) }) -test_that("filter by datasetid keeps all other collection units - where the dataset does not belong", { - skip_on_cran() - skip_on_ci() - meer <- get_sites(sitename = "meerfeld%") %>% - get_downloads() - meerDS42510 <- meer %>% - neotoma2::filter(datasetid == 42510) - meerId <- as.data.frame(collunits(meerDS42510))$collectionunitid - testthat::expect_equal(meerId, 29576) - }) +test_that("filter by datasetid keeps collection units without the dataset", { + skip_on_cran() + skip_on_ci() + meer <- get_sites(sitename = "meerfeld%") %>% + get_downloads() + meer_ds42510 <- meer %>% + neotoma2::filter(datasetid == 42510) + meer_id <- as.data.frame(collunits(meer_ds42510))$collectionunitid + testthat::expect_equal(meer_id, 29576) +}) test_that("filter works before/after get_downloads", { skip_on_cran() skip_on_ci() - core_sites <- c(13949, 11904, 13319, 728, - 13248, 2625, 2806, - 13280, 519, 11745, 273, 13956, - 11880, 13321, 9801, 13698, 11816, - 13909, 13921) + core_sites <- c( + 13949, 11904, 13319, 728, + 13248, 2625, 2806, + 13280, 519, 11745, 273, 13956, + 11880, 13321, 9801, 13698, 11816, + 13909, 13921 + ) core_wc_dl_f <- get_sites(core_sites) %>% get_datasets() %>% get_downloads() %>% neotoma2::filter(datasettype == "water chemistry") - + core_wc_f_dl <- get_sites(core_sites) %>% get_datasets() %>% neotoma2::filter(datasettype == "water chemistry") %>% diff --git a/tests/testthat/test_get_contacts.R b/tests/testthat/test_get_contacts.R index e4e23227..9867987f 100644 --- a/tests/testthat/test_get_contacts.R +++ b/tests/testthat/test_get_contacts.R @@ -8,7 +8,7 @@ test_that("`get_contacts()` numeric", { testthat::expect_equal(length(single), 1) testthat::expect_true(class(single) == "contacts") testthat::expect_true(class(single[[1]]) == "contact") - + multiple <- get_contacts(x = c(1, 2, 3)) testthat::expect_equal(length(multiple), 3) testthat::expect_true(class(multiple) == "contacts") @@ -19,8 +19,8 @@ test_that("`get_contacts()` numeric", { test_that("`get_contacts()` query", { skip_on_cran() - goring <- get_contacts(familyname ="Goring") + goring <- get_contacts(familyname = "Goring") testthat::expect_gt(length(goring), 0) testthat::expect_true(class(goring) == "contacts") testthat::expect_true(class(goring[[1]]) == "contact") -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_get_datasets.R b/tests/testthat/test_get_datasets.R index b1101417..fb102777 100644 --- a/tests/testthat/test_get_datasets.R +++ b/tests/testthat/test_get_datasets.R @@ -1,7 +1,7 @@ library("testthat") library("neotoma2") -context("get_datasets() retrieves data from /dataset endpoint +context("get_datasets() retrieves data from /dataset endpoint and parses content as expected.") test_that("get_datasets numeric", { skip_on_cran() @@ -57,12 +57,16 @@ test_that("get_datasets with loc attribute", { test_that("get_datasets accepts a WKT loc equivalently to GeoJSON", { skip_on_ci() skip_if_api_unreachable() - brazil_geojson <- paste0('{"type": "Polygon", "coordinates": [[', - '[-73.125, -9.102], [-56.953, -33.138],', - '[-36.563, -7.711], [-68.203, 13.923],', - '[-73.125, -9.102]]]}') - brazil_wkt <- paste0("POLYGON ((-73.125 -9.102, -56.953 -33.138, ", - "-36.563 -7.711, -68.203 13.923, -73.125 -9.102))") + brazil_geojson <- paste0( + '{"type": "Polygon", "coordinates": [[', + "[-73.125, -9.102], [-56.953, -33.138],", + "[-36.563, -7.711], [-68.203, 13.923],", + "[-73.125, -9.102]]]}" + ) + brazil_wkt <- paste0( + "POLYGON ((-73.125 -9.102, -56.953 -33.138, ", + "-36.563 -7.711, -68.203 13.923, -73.125 -9.102))" + ) ds_geo <- get_datasets(loc = brazil_geojson, limit = 10) ds_wkt <- get_datasets(loc = brazil_wkt, limit = 10) testthat::expect_s4_class(ds_wkt, "sites") @@ -73,10 +77,12 @@ test_that("get_datasets accepts a WKT loc equivalently to GeoJSON", { test_that("get_datasets GeoJSON loc still works (no regression)", { skip_on_ci() skip_if_api_unreachable() - brazil_geojson <- paste0('{"type": "Polygon", "coordinates": [[', - '[-73.125, -9.102], [-56.953, -33.138],', - '[-36.563, -7.711], [-68.203, 13.923],', - '[-73.125, -9.102]]]}') + brazil_geojson <- paste0( + '{"type": "Polygon", "coordinates": [[', + "[-73.125, -9.102], [-56.953, -33.138],", + "[-36.563, -7.711], [-68.203, 13.923],", + "[-73.125, -9.102]]]}" + ) ds_geo <- get_datasets(loc = brazil_geojson, limit = 5) testthat::expect_s4_class(ds_geo, "sites") }) @@ -86,7 +92,8 @@ test_that("a loc string that is neither WKT nor GeoJSON errors clearly", { # the GeoJSON branch, where parsing raises a clear error. `parseLocation()` is # the layer that builds the request body; `get_datasets()` itself catches this # and returns NULL with a message, so we assert on the parse layer directly. -testthat::expect_error(neotoma2:::parseLocation("not a geometry at all"), "GeoJSON") + testthat::expect_error(neotoma2:::parseLocation("not a geometry at all"), + "GeoJSON") }) test_that("all_data + loc", { @@ -122,18 +129,22 @@ test_that("get_datasets with or without all_data works.", { skip_on_ci() skip_if_api_unreachable() on.exit(Sys.sleep(5), add = TRUE) + # nolint start uk_bbox_geojson <- "{\n\"type\": \"FeatureCollection\",\n\"name\": \"out\",\n\"crs\": { \"type\": \"name\", \"properties\": { \"name\": \"urn:ogc:def:crs:OGC:1.3:CRS84\" } },\n\"features\": [\n{ \"type\": \"Feature\", \"properties\": { }, \"geometry\": { \"type\": \"Polygon\", \"coordinates\": [ [ [ -10.390234374999977, 50.021386718749994 ], [ 1.74658203125, 50.021386718749994 ], [ 1.74658203125, 60.831884765624991 ], [ -10.390234374999977, 60.831884765624991 ], [ -10.390234374999977, 50.021386718749994 ] ] ] } }\n]\n}" + # nolint end uk_sts <- get_sites( loc = uk_bbox_geojson, - datasettype = 'pollen', - limit=5 + datasettype = "pollen", + limit = 5 ) - uk_dl <- get_datasets(uk_sts, all_data=TRUE) + uk_dl <- get_datasets(uk_sts, all_data = TRUE) uk_dl2 <- get_datasets(uk_sts) - testthat::expect_equal(nrow(as.data.frame(datasets(uk_dl))), - nrow(as.data.frame(datasets(uk_dl2)))) + testthat::expect_equal( + nrow(as.data.frame(datasets(uk_dl))), + nrow(as.data.frame(datasets(uk_dl2))) + ) # expect no error - testthat::expect_error(get_datasets(uk_sts, all_data=TRUE), NA) - testthat::expect_error(get_datasets(uk_sts, all_data=FALSE), NA) + testthat::expect_error(get_datasets(uk_sts, all_data = TRUE), NA) + testthat::expect_error(get_datasets(uk_sts, all_data = FALSE), NA) testthat::expect_error(get_datasets(uk_sts), NA) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_get_documentation.R b/tests/testthat/test_get_documentation.R index cb575482..5f54e165 100644 --- a/tests/testthat/test_get_documentation.R +++ b/tests/testthat/test_get_documentation.R @@ -19,6 +19,7 @@ test_that("Documentation loading succeeds when interactive is true:", { }) on.exit(options(op), add = TRUE) testthat::expect_null(rlang::with_interactive(get_documentation(), - value = TRUE)) + value = TRUE + )) testthat::expect_equal(seen, "https://open.neotomadb.org/neotoma2/") -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_get_downloads.R b/tests/testthat/test_get_downloads.R index 4e21eace..9462661c 100644 --- a/tests/testthat/test_get_downloads.R +++ b/tests/testthat/test_get_downloads.R @@ -1,7 +1,7 @@ library("testthat") library("neotoma2") -context("get_downloads() retrieves data from /download endpoint +context("get_downloads() retrieves data from /download endpoint and parses content as expected.") test_that("get_downloads numeric", { skip_on_cran() @@ -14,30 +14,35 @@ test_that("get_downloads numeric", { testthat::expect_equivalent(datasets_ids, 1001) }) -test_that("get_downloads from get_datasets() - sites object.", { - skip_on_ci() - skip_if_api_unreachable() - # Space this out; it downloads full sample data. - on.exit(Sys.sleep(10), add = TRUE) - # `brazil_sf` comes from setup.R. A small `limit` is enough to prove - # that downloading a multi-dataset object preserves the id set -- - # `all_data = TRUE` over the whole region is unnecessary here and - # was the single heaviest call in the suite. - brazil_datasets <- get_datasets(loc = brazil_sf, limit = 5) - brazil_dl <- get_downloads(brazil_datasets) - testthat::expect_identical(nrow(getids(brazil_datasets)), - nrow(getids(brazil_dl))) - testthat::expect_equal(getids(brazil_datasets), - getids(brazil_dl)) - }) +test_that("get_downloads works on a get_datasets() sites object", { + skip_on_ci() + skip_if_api_unreachable() + # Space this out; it downloads full sample data. + on.exit(Sys.sleep(10), add = TRUE) + # `brazil_sf` comes from setup.R. A small `limit` is enough to prove + # that downloading a multi-dataset object preserves the id set -- + # `all_data = TRUE` over the whole region is unnecessary here and + # was the single heaviest call in the suite. + brazil_datasets <- get_datasets(loc = brazil_sf, limit = 5) + brazil_dl <- get_downloads(brazil_datasets) + testthat::expect_identical( + nrow(getids(brazil_datasets)), + nrow(getids(brazil_dl)) + ) + testthat::expect_equal( + getids(brazil_datasets), + getids(brazil_dl) + ) +}) test_that("get_downloads from get_sites sites", { skip_on_cran() - core_sites <- c(13949, 11904, 13319, 728, - 13248, 2625, 2806, 13280, 519, 11745, - 273, 13956, 11880, 13321, 9801, 13698, - 11816, 13909, 13921) + core_sites <- c( + 13949, 11904, 13319, 728, + 13248, 2625, 2806, 13280, 519, 11745, + 273, 13956, 11880, 13321, 9801, 13698, + 11816, 13909, 13921 + ) df1 <- get_sites(core_sites) %>% get_downloads() %>% getids() @@ -60,7 +65,9 @@ test_that("get_downloads with or without all_data works.", { skip_on_ci() skip_if_api_unreachable() on.exit(Sys.sleep(5), add = TRUE) + # nolint start uk_bbox_geojson <- "{\n\"type\": \"FeatureCollection\",\n\"name\": \"out\",\n\"crs\": { \"type\": \"name\", \"properties\": { \"name\": \"urn:ogc:def:crs:OGC:1.3:CRS84\" } },\n\"features\": [\n{ \"type\": \"Feature\", \"properties\": { }, \"geometry\": { \"type\": \"Polygon\", \"coordinates\": [ [ [ -10.390234374999977, 50.021386718749994 ], [ 1.74658203125, 50.021386718749994 ], [ 1.74658203125, 60.831884765624991 ], [ -10.390234374999977, 60.831884765624991 ], [ -10.390234374999977, 50.021386718749994 ] ] ] } }\n]\n}" + # nolint end uk_datasets <- get_datasets( loc = uk_bbox_geojson, datasettype = "pollen", @@ -68,8 +75,10 @@ test_that("get_downloads with or without all_data works.", { ) uk_dl <- get_downloads(uk_datasets, all_data = TRUE) uk_dl2 <- get_downloads(uk_datasets) - testthat::expect_equal(nrow(as.data.frame(datasets(uk_dl))), - nrow(as.data.frame(datasets(uk_dl2)))) + testthat::expect_equal( + nrow(as.data.frame(datasets(uk_dl))), + nrow(as.data.frame(datasets(uk_dl2))) + ) # expect no error testthat::expect_error(get_downloads(uk_datasets, all_data = TRUE), NA) testthat::expect_error(get_downloads(uk_datasets, all_data = FALSE), NA) @@ -108,11 +117,15 @@ mock_downloads <- function(log, fail_on = NULL) { log$ids <- c(log$ids, list(ids)) log$args <- c(log$args, list(list(...))) if (!is.null(fail_on) && fail_on %in% ids) stop("HTTP 504") - list(status = "success", - data = lapply(ids, function(i) list(datasetid = i))) + list( + status = "success", + data = lapply(ids, function(i) list(datasetid = i)) + ) } - local_mocked_bindings(parseURL = fake_parse_url, parse_site = function(x) x, - .package = "neotoma2", .env = parent.frame()) + local_mocked_bindings( + parseURL = fake_parse_url, parse_site = function(x) x, + .package = "neotoma2", .env = parent.frame() + ) } test_that("get_downloads fetches a long id vector in sequential batches", { @@ -186,8 +199,10 @@ test_that("get_downloads(sites) lets a caller turn all_data off", { seen <<- list(...) NULL } - local_mocked_bindings(getids = function(x) data.frame(datasetid = c(1, 2)), - get_downloads = record_args, .package = "neotoma2") + local_mocked_bindings( + getids = function(x) data.frame(datasetid = c(1, 2)), + get_downloads = record_args, .package = "neotoma2" + ) # Call the method itself: get_downloads() is the thing being replaced. neotoma2:::get_downloads.sites(new("sites", sites = list()), all_data = FALSE) expect_false(seen$all_data) diff --git a/tests/testthat/test_get_manual.R b/tests/testthat/test_get_manual.R index 26188fc8..d6f83840 100644 --- a/tests/testthat/test_get_manual.R +++ b/tests/testthat/test_get_manual.R @@ -19,6 +19,7 @@ test_that("Manual loading succeeds when interactive is true:", { }) on.exit(options(op), add = TRUE) testthat::expect_null(rlang::with_interactive(get_manual(), - value = TRUE)) + value = TRUE + )) testthat::expect_equal(seen, "https://open.neotomadb.org/manual/") -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_get_publications.R b/tests/testthat/test_get_publications.R index e879d050..6ece5aa5 100644 --- a/tests/testthat/test_get_publications.R +++ b/tests/testthat/test_get_publications.R @@ -25,4 +25,4 @@ test_that("`get_publications` publications", { counts <- get_publications(c(1, 2, 3, 4)) frompubs <- get_publications(counts) testthat::expect_identical(counts, frompubs) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_get_sites.R b/tests/testthat/test_get_sites.R index 059d0161..989f1672 100644 --- a/tests/testthat/test_get_sites.R +++ b/tests/testthat/test_get_sites.R @@ -53,6 +53,7 @@ test_that("all_data + loc", { testthat::expect_true(all(st_ids %in% br_ids$siteid)) }) +# nolint start # context("get_sites()") # test_that("If B is contained in A region, # get_sites() from B will be contained @@ -61,6 +62,7 @@ test_that("all_data + loc", { # # Heavy spatial query (limit = 20000); space it out to reduce load # # spikes on the API. # on.exit(Sys.sleep(10), add = TRUE) +# nolint end # location <- '{"type": "Polygon", # "coordinates": [[ # [-169, 24], @@ -68,7 +70,10 @@ test_that("all_data + loc", { # [-52, 75], # [-52, 24], # [-169, 24]]]}' +# nolint start # usa <- get_sites(loc = location, limit = 20000) # fla <- get_sites(gpid = "Florida", limit = 10000) -# testthat::expect_true(all(getids(fla)$siteid %in% getids(usa)$siteid)) +# nolint end +# testthat::expect_true(all(getids(fla)$siteid %in% +# getids(usa)$siteid)) # }) diff --git a/tests/testthat/test_get_speleothems.R b/tests/testthat/test_get_speleothems.R index b42164dc..d35cbff1 100644 --- a/tests/testthat/test_get_speleothems.R +++ b/tests/testthat/test_get_speleothems.R @@ -26,14 +26,16 @@ test_that("get_speleothems works with sites object", { # test_that("get_speleothems handles invalid datasetid", { +# nolint start # skip_on_cran() # skip_if(TRUE, "Speleothem functionality needs verification") -# +# # # Test with non-existent datasetid # spel_invalid <- get_speleothems(999999999) -# +# # # Should return NULL or empty result # testthat::expect_true(is.null(spel_invalid) || length(spel_invalid) == 0) +# nolint end # }) test_that("get_speleothems returns correct structure", { @@ -65,4 +67,4 @@ test_that("get_speleothems integrates with summary", { testthat::expect_is(sum_data, "data.frame") testthat::expect_true(nrow(sum_data) > 0) } -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_get_stats.R b/tests/testthat/test_get_stats.R index da3b9383..0bbc5c07 100644 --- a/tests/testthat/test_get_stats.R +++ b/tests/testthat/test_get_stats.R @@ -12,16 +12,18 @@ test_that("get_stats with the default values", { test_that("get_stats rawbymonth", { skip_on_cran() - stats <- get_stats(type="rawbymonth") + stats <- get_stats(type = "rawbymonth") testthat::expect_is(stats, "data.frame") testthat::expect_true(nrow(stats) == 1) - testthat::expect_true(all(c("datasets", "sites", "publications", - "authors", "countrygpid", "observations") %in% colnames(stats))) + testthat::expect_true(all(c( + "datasets", "sites", "publications", + "authors", "countrygpid", "observations" + ) %in% colnames(stats))) }) test_that("get_stats dstypemonth", { skip_on_cran() - stats <- get_stats(type="dstypemonth") + stats <- get_stats(type = "dstypemonth") testthat::expect_is(stats, "data.frame") testthat::expect_true(all(c("datasettype", "counts") %in% colnames(stats))) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_get_table.R b/tests/testthat/test_get_table.R index 28c39932..f7a77f31 100644 --- a/tests/testthat/test_get_table.R +++ b/tests/testthat/test_get_table.R @@ -16,29 +16,33 @@ test_that("Apply limits for get_table()", { testthat::expect_equal(nrow(tb), 3) }) -test_that("Limit and offsets work as expected. - Offsetting by one returns a different result.", { - skip_on_cran() - tb1 <- get_table("agetypes", limit = 1) - tb2 <- get_table("agetypes", limit = 1, offset = 1) - testthat::expect_false(rlang::hash(tb1) == - rlang::hash(tb2)) - }) +test_that("Limit and offsets work: offsetting by one changes the result", { + skip_on_cran() + tb1 <- get_table("agetypes", limit = 1) + tb2 <- get_table("agetypes", limit = 1, offset = 1) + testthat::expect_false(rlang::hash(tb1) == rlang::hash(tb2)) +}) test_that("Correct table", { skip_on_cran() tb1 <- get_table("agetypes", limit = 1) - cols <- c("agetypeid", "agetype", "precedence", - "shortagetype", "recdatecreated", "recdatemodified") + cols <- c( + "agetypeid", "agetype", "precedence", + "shortagetype", "recdatecreated", "recdatemodified" + ) testthat::expect_identical(colnames(tb1), cols) }) ## Offline tests: parseURL() is replaced, so these touch no API. table_result <- function() { - list(status = "success", - data = list(data = list(list(agetypeid = 1, agetype = "A"), - list(agetypeid = 2, agetype = "B")))) + list( + status = "success", + data = list(data = list( + list(agetypeid = 1, agetype = "A"), + list(agetypeid = 2, agetype = "B") + )) + ) } test_that("get_table asks the API once for the same table in one session", { diff --git a/tests/testthat/test_get_taxa.R b/tests/testthat/test_get_taxa.R index 06e1bd52..b3f62d87 100644 --- a/tests/testthat/test_get_taxa.R +++ b/tests/testthat/test_get_taxa.R @@ -11,11 +11,17 @@ test_that("get_taxa() sites object", { skip_if_api_unreachable() abies <- get_taxa(1) testthat::expect_is(abies, "sites") - abies_df <- abies %>% get_downloads() %>% taxa() %>% suppressWarnings() + abies_df <- abies %>% + get_downloads() %>% + taxa() %>% + suppressWarnings() testthat::expect_true(any(grepl("Abies", abies_df$variablename))) abies <- get_taxa(taxonname = "abies") testthat::expect_is(abies, "sites") - abies_df <- abies %>% get_downloads() %>% taxa() %>% suppressWarnings() + abies_df <- abies %>% + get_downloads() %>% + taxa() %>% + suppressWarnings() testthat::expect_true(any(grepl("Abies", abies_df$variablename))) }) @@ -25,7 +31,9 @@ test_that("get_taxa() sites object", { fake_taxon <- function(names) { force(names) function(...) { - if (is.null(names)) return(NULL) + if (is.null(names)) { + return(NULL) + } new("taxa", taxa = lapply(seq_along(names), function(i) { new("taxon", taxonid = i, taxonname = names[[i]]) })) @@ -38,9 +46,11 @@ mock_taxa_steps <- function(names, log, .env = parent.frame()) { log$calls <- c(log$calls, list(list(...))) "datasets" } - local_mocked_bindings(get_taxon = fake_taxon(names), - get_datasets = record_datasets, - .package = "neotoma2", .env = .env) + local_mocked_bindings( + get_taxon = fake_taxon(names), + get_datasets = record_datasets, + .package = "neotoma2", .env = .env + ) } test_that("get_taxa(taxa=) sends the names, not the taxa() generic", { @@ -63,15 +73,19 @@ test_that("get_taxa honours a caller's all_data in both calls", { test_that("get_taxa(taxonname=) forwards the dataset arguments", { log <- new.env() mock_taxa_steps("Pinus", log) - get_taxa(taxonname = "Pinus", datasettype = c("pollen", "macrofossil"), - loc = c(-80, 40, -70, 50), limit = 5, offset = 10, - ageyoung = 100, ageold = 5000) + get_taxa( + taxonname = "Pinus", datasettype = c("pollen", "macrofossil"), + loc = c(-80, 40, -70, 50), limit = 5, offset = 10, + ageyoung = 100, ageold = 5000 + ) call <- log$calls[[1]] expect_equal(call$taxa, "Pinus") expect_equal(call$datasettype, c("pollen", "macrofossil")) expect_equal(call$loc, c(-80, 40, -70, 50)) - expect_equal(call[c("limit", "offset", "ageyoung", "ageold")], - list(limit = 5, offset = 10, ageyoung = 100, ageold = 5000)) + expect_equal( + call[c("limit", "offset", "ageyoung", "ageold")], + list(limit = 5, offset = 10, ageyoung = 100, ageold = 5000) + ) expect_false("taxonname" %in% names(call)) }) @@ -90,9 +104,11 @@ test_that("get_taxa sends only the id to the taxa endpoint", { seen <<- list(...) new("taxa", taxa = list(new("taxon", taxonid = 1, taxonname = "Abies"))) } - local_mocked_bindings(get_taxon = fake_get_taxon, - get_datasets = function(...) "datasets", - .package = "neotoma2") + local_mocked_bindings( + get_taxon = fake_get_taxon, + get_datasets = function(...) "datasets", + .package = "neotoma2" + ) get_taxa(1, limit = 5, offset = 2, all_data = TRUE, loc = c(1, 2, 3, 4)) expect_equal(seen, list(1)) }) @@ -100,13 +116,17 @@ test_that("get_taxa sends only the id to the taxa endpoint", { test_that("get_taxa never asks for datasets without a taxon filter", { log <- new.env() mock_taxa_steps(NULL, log) - expect_message(res <- get_taxa(taxonname = "Zzzzz not a taxon"), - "No datasets were requested") + expect_message( + res <- get_taxa(taxonname = "Zzzzz not a taxon"), + "No datasets were requested" + ) expect_null(res) expect_message(res <- get_taxa(999999999), "No datasets were requested") expect_null(res) - expect_message(res <- get_taxa(taxa = character(0)), - "No datasets were requested") + expect_message( + res <- get_taxa(taxa = character(0)), + "No datasets were requested" + ) expect_null(log$calls) }) @@ -129,9 +149,11 @@ test_that("get_taxa() searches datasets for that taxon, not all", { # passed its id to get_taxa(). The datasets that came back were pollen surface # samples with none of the taxon: the old get_taxa() called get_datasets() # with no taxon filter, so it returned the API's first page of datasets. - bison_taxa <- list(new("taxon", taxonid = 6774, taxonname = "Bison"), - new("taxon", taxonid = 5868, taxonname = "Bison bison"), - new("taxon", taxonid = 6772, taxonname = "Bison priscus")) + bison_taxa <- list( + new("taxon", taxonid = 6774, taxonname = "Bison"), + new("taxon", taxonid = 5868, taxonname = "Bison bison"), + new("taxon", taxonid = 6772, taxonname = "Bison priscus") + ) bison <- new("taxa", taxa = bison_taxa) seen <- new.env() fake_get_taxon <- function(x = NULL, ...) { @@ -146,9 +168,11 @@ test_that("get_taxa() searches datasets for that taxon, not all", { seen$datasets <- c(seen$datasets, list(list(...))) "datasets" } - local_mocked_bindings(get_taxon = fake_get_taxon, - get_datasets = fake_get_datasets, - .package = "neotoma2") + local_mocked_bindings( + get_taxon = fake_get_taxon, + get_datasets = fake_get_datasets, + .package = "neotoma2" + ) second <- get_taxon(taxonname = "Bison*")[2] expect_equal(second$taxonid, 5868) diff --git a/tests/testthat/test_get_taxon.R b/tests/testthat/test_get_taxon.R index 6dd22473..1c46a464 100644 --- a/tests/testthat/test_get_taxon.R +++ b/tests/testthat/test_get_taxon.R @@ -16,10 +16,12 @@ test_that("`get_taxon` yields specific taxon information", { ## Offline tests: parseURL() is replaced, so these touch no API. taxon_result <- function(n) { - list(status = "success", message = "ok", - data = lapply(seq_len(n), function(i) { - list(taxonid = i, taxonname = paste("Taxon", i)) - })) + list( + status = "success", message = "ok", + data = lapply(seq_len(n), function(i) { + list(taxonid = i, taxonname = paste("Taxon", i)) + }) + ) } taxon_params <- function(...) list("taxonname", "limit", "offset", "all_data") @@ -32,8 +34,10 @@ test_that("get_taxon(taxonname=) fetches every page by default", { seen <<- list(x = x, ...) taxon_result(3) } - local_mocked_bindings(get_params = taxon_params, parseURL = fake_parse_url, - .package = "neotoma2") + local_mocked_bindings( + get_params = taxon_params, parseURL = fake_parse_url, + .package = "neotoma2" + ) out <- get_taxon(taxonname = "Pinus%") expect_equal(seen$x, "data/taxa") expect_true(seen$all_data) @@ -48,8 +52,10 @@ test_that("get_taxon honours all_data = FALSE and never sends it twice", { seen <<- list(...) taxon_result(1) } - local_mocked_bindings(get_params = taxon_params, parseURL = fake_parse_url, - .package = "neotoma2") + local_mocked_bindings( + get_params = taxon_params, parseURL = fake_parse_url, + .package = "neotoma2" + ) get_taxon(taxonname = "Pinus%", all_data = FALSE) expect_false(seen$all_data) expect_equal(sum(names(seen) == "all_data"), 1) @@ -67,10 +73,15 @@ test_that("a long vector of taxon ids never POSTs to data/taxa", { list(taxonid = as.numeric(i), taxonname = paste("Taxon", i)) }) body <- jsonlite::toJSON(list(status = "success", data = records), - auto_unbox = TRUE) - structure(list(url = url, status_code = 200L, headers = list(), - content = charToRaw(as.character(body))), - class = "response") + auto_unbox = TRUE + ) + structure( + list( + url = url, status_code = 200L, headers = list(), + content = charToRaw(as.character(body)) + ), + class = "response" + ) } local_mocked_bindings(neotoma_retry = fake_retry, .package = "neotoma2") out <- get_taxon(1:1500) @@ -82,8 +93,10 @@ test_that("a long vector of taxon ids never POSTs to data/taxa", { }) test_that("get_taxon with no ids returns NULL and asks for nothing", { - local_mocked_bindings(parseURL = function(...) stop("must not be called"), - .package = "neotoma2") + local_mocked_bindings( + parseURL = function(...) stop("must not be called"), + .package = "neotoma2" + ) expect_message(res <- get_taxon(numeric(0)), "No taxon ID") expect_null(res) }) @@ -92,8 +105,10 @@ test_that("get_taxon with no ids returns NULL and asks for nothing", { test_that("a taxon record without a taxon group still parses", { # `taxagroupid` is a character slot; a missing value used to be coerced to an # integer NA, which made the whole taxa object invalid. - records <- list(list(taxonid = 1, taxonname = "Abies"), - list(taxonid = 2, taxonname = "Pinus", taxagroupid = "VPL")) + records <- list( + list(taxonid = 1, taxonname = "Abies"), + list(taxonid = 2, taxonname = "Pinus", taxagroupid = "VPL") + ) out <- neotoma2:::parse_taxon(list(data = records)) expect_s4_class(out, "taxa") expect_true(is.na(out[[1]]@taxagroupid)) diff --git a/tests/testthat/test_getids.R b/tests/testthat/test_getids.R index b30c76f7..d855a9f1 100644 --- a/tests/testthat/test_getids.R +++ b/tests/testthat/test_getids.R @@ -5,53 +5,55 @@ library("httptest") context("`getids()` retrieves all 'site', 'collection unit', and 'dataset' IDs from Neotoma2 objects") httptest::with_mock_api({ -test_that("getids gets correct site IDs", { - skip_on_cran() - sts <- get_sites(c(1001, 2001, 15, 24)) - ids <- getids(sts) - testthat::expect_setequal(ids$siteid, c(1001, 2001, 15, 24)) -}) + test_that("getids gets correct site IDs", { + skip_on_cran() + sts <- get_sites(c(1001, 2001, 15, 24)) + ids <- getids(sts) + testthat::expect_setequal(ids$siteid, c(1001, 2001, 15, 24)) + }) -test_that("getids gets correct dataset IDs", { - skip_on_cran() - dss <- get_datasets(c(1001, 2001, 15, 24)) - ids <- getids(dss) - testthat::expect_setequal(ids$datasetid, c(1001, 2001, 15, 24)) -}) + test_that("getids gets correct dataset IDs", { + skip_on_cran() + dss <- get_datasets(c(1001, 2001, 15, 24)) + ids <- getids(dss) + testthat::expect_setequal(ids$datasetid, c(1001, 2001, 15, 24)) + }) -test_that("getids gets correct IDs and correct alignment", { - skip_on_cran() - sts <- get_sites(c(1001, 2001, 15, 24)) - ids <- getids(sts) - sts_ids_df <- purrr::map_df(sts@sites, function(x) { - siteid <- x@siteid - purrr::map(x@collunits, function(y) { - cuid <- y@collectionunitid - dsids <- purrr::map(y@datasets, function(z) z$datasetid) %>% unlist() - # Return one row per datasetid - data.frame( - siteid = siteid, - collectionunitid = cuid, - datasetid = dsids - )}) %>% - do.call(rbind, .) + test_that("getids gets correct IDs and correct alignment", { + skip_on_cran() + sts <- get_sites(c(1001, 2001, 15, 24)) + ids <- getids(sts) + sts_ids_df <- purrr::map_df(sts@sites, function(x) { + siteid <- x@siteid + purrr::map(x@collunits, function(y) { + cuid <- y@collectionunitid + dsids <- purrr::map(y@datasets, function(z) z$datasetid) %>% unlist() + # Return one row per datasetid + data.frame( + siteid = siteid, + collectionunitid = cuid, + datasetid = dsids + ) + }) %>% + do.call(rbind, .) + }) + testthat::expect_equal(nrow(ids), nrow(sts_ids_df)) + testthat::expect_setequal(ids$siteid, sts_ids_df$siteid) + testthat::expect_setequal(ids$datasetid, sts_ids_df$datasetid) + testthat::expect_setequal(ids$collunitid, sts_ids_df$collectionunitid) + sts_cu <- sts_ids_df$collectionunitid %>% unique() + st15_ids <- ids %>% + dplyr::filter(siteid == 15) + st15_map <- sts_ids_df %>% + dplyr::filter(siteid == 15) + testthat::expect_setequal(st15_ids$datasetid, st15_map$datasetid) + testthat::expect_setequal(st15_ids$collunitid, st15_map$collectionunitid) + st2001_ids <- ids %>% + dplyr::filter(siteid == 2001) + st2001_map <- sts_ids_df %>% + dplyr::filter(siteid == 2001) + testthat::expect_setequal(st2001_ids$datasetid, st2001_map$datasetid) + testthat::expect_setequal(st2001_ids$collunitid, + st2001_map$collectionunitid) }) - testthat::expect_equal(nrow(ids), nrow(sts_ids_df)) - testthat::expect_setequal(ids$siteid, sts_ids_df$siteid) - testthat::expect_setequal(ids$datasetid, sts_ids_df$datasetid) - testthat::expect_setequal(ids$collunitid, sts_ids_df$collectionunitid) - sts_cu <- sts_ids_df$collectionunitid %>% unique() - st15_ids <- ids %>% - dplyr::filter(siteid == 15) - st15_map <- sts_ids_df %>% - dplyr::filter(siteid == 15) - testthat::expect_setequal(st15_ids$datasetid, st15_map$datasetid) - testthat::expect_setequal(st15_ids$collunitid, st15_map$collectionunitid) - st2001_ids <- ids %>% - dplyr::filter(siteid == 2001) - st2001_map <- sts_ids_df %>% - dplyr::filter(siteid == 2001) - testthat::expect_setequal(st2001_ids$datasetid, st2001_map$datasetid) - testthat::expect_setequal(st2001_ids$collunitid, st2001_map$collectionunitid) }) -}) \ No newline at end of file diff --git a/tests/testthat/test_group_data.R b/tests/testthat/test_group_data.R index 048957a5..2527ef0c 100644 --- a/tests/testthat/test_group_data.R +++ b/tests/testthat/test_group_data.R @@ -15,23 +15,32 @@ test_that("pick takes the first spelling the API used", { # A field none of the spellings match is NULL, not an error. testthat::expect_null(neotoma2:::pick(list(handle = "ABC"), spellings)) # A NULL value is skipped in favour of the next spelling. - testthat::expect_equal(neotoma2:::pick(list(unittype = NULL, - collunittype = "Core"), - spellings), "Core") + testthat::expect_equal(neotoma2:::pick( + list( + unittype = NULL, + collunittype = "Core" + ), + spellings + ), "Core") }) test_that("pick does not partially match a field name", { # `$` would match `collunittype` from `collunit`; `pick()` must not. - testthat::expect_null(neotoma2:::pick(list(collunittype = "Core"), - "collunit")) + testthat::expect_null(neotoma2:::pick( + list(collunittype = "Core"), + "collunit" + )) }) test_that("group_response gives every endpoint the same shape", { - files <- c("data_sites24.json", "data_datasets24.json", - "data_downloads24_dup.json") + files <- c( + "data_sites24.json", "data_datasets24.json", + "data_downloads24_dup.json" + ) for (f in files) { result <- jsonlite::fromJSON(test_path("fixtures", f), - simplifyVector = FALSE) + simplifyVector = FALSE + ) grouped <- neotoma2:::group_response(result$data) # One site, reached the same way regardless of which endpoint answered. testthat::expect_length(grouped, 1) @@ -48,10 +57,14 @@ test_that("group_response returns an empty list for an empty response", { test_that("group_collunits folds repeated units and pools their datasets", { cus <- list( - list(collectionunitid = 24, handle = "ALEXLAKE", - datasets = list(list(datasetid = 24))), - list(collectionunitid = 24, handle = "ALEXLAKE", - datasets = list(list(datasetid = 7870))) + list( + collectionunitid = 24, handle = "ALEXLAKE", + datasets = list(list(datasetid = 24)) + ), + list( + collectionunitid = 24, handle = "ALEXLAKE", + datasets = list(list(datasetid = 7870)) + ) ) folded <- neotoma2:::group_collunits(cus) testthat::expect_length(folded, 1) @@ -70,12 +83,16 @@ test_that("group_collunits keeps genuinely different units apart", { }) test_that("unique_datasets reports each dataset once", { - datasets <- list(list(datasetid = 24), list(datasetid = 24), - list(datasetid = 7870)) + datasets <- list( + list(datasetid = 24), list(datasetid = 24), + list(datasetid = 7870) + ) kept <- neotoma2:::unique_datasets(datasets) testthat::expect_length(kept, 2) - testthat::expect_setequal(sapply(kept, function(x) x$datasetid), - c(24, 7870)) + testthat::expect_setequal( + sapply(kept, function(x) x$datasetid), + c(24, 7870) + ) }) test_that("group_sites keeps the order the API sent", { @@ -84,19 +101,29 @@ test_that("group_sites keeps the order the API sent", { list(site = list(siteid = id), collectionunits = list()) }) grouped <- neotoma2:::group_sites(elements) - testthat::expect_equal(sapply(grouped, function(x) x$site$siteid), - c(24, 1001, 3)) + testthat::expect_equal( + sapply(grouped, function(x) x$site$siteid), + c(24, 1001, 3) + ) }) test_that("group_sites folds elements that share a site", { # `downloads` reports one element per dataset, so a site can arrive twice. elements <- list( - list(site = list(siteid = 24), - collectionunits = list(list(collectionunitid = 24, - datasets = list(list(datasetid = 24))))), - list(site = list(siteid = 24), - collectionunits = list(list(collectionunitid = 24, - datasets = list(list(datasetid = 7870))))) + list( + site = list(siteid = 24), + collectionunits = list(list( + collectionunitid = 24, + datasets = list(list(datasetid = 24)) + )) + ), + list( + site = list(siteid = 24), + collectionunits = list(list( + collectionunitid = 24, + datasets = list(list(datasetid = 7870)) + )) + ) ) grouped <- neotoma2:::group_sites(elements) testthat::expect_length(grouped, 1) diff --git a/tests/testthat/test_length.R b/tests/testthat/test_length.R index 24d6813d..b0b69a8e 100644 --- a/tests/testthat/test_length.R +++ b/tests/testthat/test_length.R @@ -5,40 +5,41 @@ library("httptest") context("`length()` retrieves correct number of 'sites', 'collection units', and 'datasets'") httptest::with_mock_api({ -test_that("length of sites is correct", { - skip_on_cran() - sts <- get_sites(c(1001, 2001, 15, 24)) - len <- length(sts) - testthat::expect_equal(len, length(c(1001, 2001, 15, 24))) -}) + test_that("length of sites is correct", { + skip_on_cran() + sts <- get_sites(c(1001, 2001, 15, 24)) + len <- length(sts) + testthat::expect_equal(len, length(c(1001, 2001, 15, 24))) + }) -test_that("length of collection units is correct", { - skip_on_cran() - sts <- get_sites(c(1001, 2001, 15, 24)) - cu <- collunits(sts) - len <- length(cu) - ids <- getids(sts)$collunitid %>% unique() %>% length() - testthat::expect_equal(len, ids) - len <- length(sts[[3]]@collunits) - stid <- getids(sts[[3]])$siteid %>% unique() - cuids <- filter(getids(sts), siteid == stid)$collunitid %>% length() - testthat::expect_equal(len, cuids) -}) + test_that("length of collection units is correct", { + skip_on_cran() + sts <- get_sites(c(1001, 2001, 15, 24)) + cu <- collunits(sts) + len <- length(cu) + ids <- getids(sts)$collunitid %>% + unique() %>% + length() + testthat::expect_equal(len, ids) + len <- length(sts[[3]]@collunits) + stid <- getids(sts[[3]])$siteid %>% unique() + cuids <- filter(getids(sts), siteid == stid)$collunitid %>% length() + testthat::expect_equal(len, cuids) + }) -test_that("length of datasets is correct", { - skip_on_cran() - sts <- get_datasets(c(1001, 2001, 15, 24)) - ds <- datasets(sts) - len <- length(ds) - ids <- getids(sts)$datasetid %>% length() - testthat::expect_equal(len, ids) - len <- length( - map(sts[[1]]@collunits, function(y) { + test_that("length of datasets is correct", { + skip_on_cran() + sts <- get_datasets(c(1001, 2001, 15, 24)) + ds <- datasets(sts) + len <- length(ds) + ids <- getids(sts)$datasetid %>% length() + testthat::expect_equal(len, ids) + nested_ids <- map(sts[[1]]@collunits, function(y) { map(y@datasets, function(z) z$datasetid) %>% unlist() - }) %>% unlist() - ) - stid <- getids(sts[[1]])$siteid %>% unique() - dsids <- filter(getids(sts), siteid == stid)$datasetid %>% length() - testthat::expect_equal(len, dsids) -}) + }) + len <- length(unlist(nested_ids)) + stid <- getids(sts[[1]])$siteid %>% unique() + dsids <- filter(getids(sts), siteid == stid)$datasetid %>% length() + testthat::expect_equal(len, dsids) + }) }) diff --git a/tests/testthat/test_parseURL.R b/tests/testthat/test_parseURL.R index 45a16554..7c455745 100644 --- a/tests/testthat/test_parseURL.R +++ b/tests/testthat/test_parseURL.R @@ -4,16 +4,24 @@ library("neotoma2") context("Test `parseURL()` transport helpers.") test_that("neotoma_baseurl resolves servers and honors APIPOINT", { - expect_equal(neotoma2:::neotoma_baseurl("neotoma"), - "https://api.neotomadb.org/v2.0/") - expect_equal(neotoma2:::neotoma_baseurl("dev"), - "https://api-dev.neotomadb.org/v2.0/") - expect_equal(neotoma2:::neotoma_baseurl("local"), - "http://localhost:3001/v2.0/") + expect_equal( + neotoma2:::neotoma_baseurl("neotoma"), + "https://api.neotomadb.org/v2.0/" + ) + expect_equal( + neotoma2:::neotoma_baseurl("dev"), + "https://api-dev.neotomadb.org/v2.0/" + ) + expect_equal( + neotoma2:::neotoma_baseurl("local"), + "http://localhost:3001/v2.0/" + ) old <- Sys.getenv("APIPOINT") Sys.setenv("APIPOINT" = "local") - expect_equal(neotoma2:::neotoma_baseurl("neotoma"), - "http://localhost:3001/v2.0/") + expect_equal( + neotoma2:::neotoma_baseurl("neotoma"), + "http://localhost:3001/v2.0/" + ) if (old == "") Sys.unsetenv("APIPOINT") else Sys.setenv("APIPOINT" = old) }) @@ -26,22 +34,28 @@ test_that("neotoma_body builds a JSON body from the query", { ## Pagination and retry. Every HTTP call below is stubbed, so these tests are ## pure logic: they touch no API and need no skip. -cz_geojson <- paste0("{\"type\":\"Polygon\",\"coordinates\":[[[12.4,50.14],", - "[14.1,48.64],[16.95,48.66],[18.91,49.61],", - "[15.24,50.99],[12.4,50.14]]]}") +cz_geojson <- paste0( + "{\"type\":\"Polygon\",\"coordinates\":[[[12.4,50.14],", + "[14.1,48.64],[16.95,48.66],[18.91,49.61],", + "[15.24,50.99],[12.4,50.14]]]}" +) api_url <- "https://api.neotomadb.org/v2.0/data/sites" fake_response <- function(status, headers = list()) { - structure(list(url = "https://api.neotomadb.org/v2.0/data/sites", - status_code = as.integer(status), - headers = headers, - all_headers = list(), - content = raw(0), - request = list(), - date = Sys.time(), - times = numeric(0)), - class = "response") + structure( + list( + url = "https://api.neotomadb.org/v2.0/data/sites", + status_code = as.integer(status), + headers = headers, + all_headers = list(), + content = raw(0), + request = list(), + date = Sys.time(), + times = numeric(0) + ), + class = "response" + ) } ## A stub for neotoma_fetch() that serves `total` records `limit` at a time and @@ -51,9 +65,11 @@ fake_api <- function(total, log) { log$offsets <- c(log$offsets, query$offset) log$limits <- c(log$limits, query$limit) n <- min(query$limit, max(0, total - query$offset)) - list(status = 200, - data = replicate(n, list(siteid = 1), simplify = FALSE), - message = "Success") + list( + status = 200, + data = replicate(n, list(siteid = 1), simplify = FALSE), + message = "Success" + ) } } @@ -62,11 +78,15 @@ test_that("pagination stops on a short page instead of on an empty one", { # page. Confirming that with a further request costs a full round trip -- on # the spatial endpoints, tens of seconds -- and returns nothing. log <- new.env() - local_mocked_bindings(neotoma_fetch = fake_api(185, log), - .package = "neotoma2") + local_mocked_bindings( + neotoma_fetch = fake_api(185, log), + .package = "neotoma2" + ) - result <- neotoma2:::neotoma_paginate("https://api.neotomadb.org/v2.0/", - "data/sites", list(loc = cz_geojson)) + result <- neotoma2:::neotoma_paginate( + "https://api.neotomadb.org/v2.0/", + "data/sites", list(loc = cz_geojson) + ) expect_length(result$data, 185) expect_equal(log$offsets, 0) @@ -74,11 +94,15 @@ test_that("pagination stops on a short page instead of on an empty one", { test_that("pagination walks every page of a multi-page result", { log <- new.env() - local_mocked_bindings(neotoma_fetch = fake_api(4500, log), - .package = "neotoma2") + local_mocked_bindings( + neotoma_fetch = fake_api(4500, log), + .package = "neotoma2" + ) - result <- neotoma2:::neotoma_paginate("https://api.neotomadb.org/v2.0/", - "data/sites", list(loc = cz_geojson)) + result <- neotoma2:::neotoma_paginate( + "https://api.neotomadb.org/v2.0/", + "data/sites", list(loc = cz_geojson) + ) expect_length(result$data, 4500) expect_equal(log$offsets, c(0, 2000, 4000)) @@ -88,11 +112,15 @@ test_that("a result that is an exact multiple of the page size is complete", { # The one case where the extra request is unavoidable: a full final page is # indistinguishable from a page with more behind it. log <- new.env() - local_mocked_bindings(neotoma_fetch = fake_api(4000, log), - .package = "neotoma2") + local_mocked_bindings( + neotoma_fetch = fake_api(4000, log), + .package = "neotoma2" + ) - result <- neotoma2:::neotoma_paginate("https://api.neotomadb.org/v2.0/", - "data/sites", list(siteid = 1)) + result <- neotoma2:::neotoma_paginate( + "https://api.neotomadb.org/v2.0/", + "data/sites", list(siteid = 1) + ) expect_length(result$data, 4000) expect_equal(log$offsets, c(0, 2000, 4000)) @@ -100,11 +128,15 @@ test_that("a result that is an exact multiple of the page size is complete", { test_that("an empty result returns no data and makes one request", { log <- new.env() - local_mocked_bindings(neotoma_fetch = fake_api(0, log), - .package = "neotoma2") + local_mocked_bindings( + neotoma_fetch = fake_api(0, log), + .package = "neotoma2" + ) - result <- neotoma2:::neotoma_paginate("https://api.neotomadb.org/v2.0/", - "data/sites", list(loc = cz_geojson)) + result <- neotoma2:::neotoma_paginate( + "https://api.neotomadb.org/v2.0/", + "data/sites", list(loc = cz_geojson) + ) expect_length(result$data, 0) expect_equal(log$offsets, 0) @@ -115,11 +147,15 @@ test_that("pages are requested at the largest size the API supports", { # returns fewer records overall, because the second page comes back short. # Shrinking the page size therefore loses data, and is not a speed knob. log <- new.env() - local_mocked_bindings(neotoma_fetch = fake_api(10, log), - .package = "neotoma2") + local_mocked_bindings( + neotoma_fetch = fake_api(10, log), + .package = "neotoma2" + ) - neotoma2:::neotoma_paginate("https://api.neotomadb.org/v2.0/", "data/sites", - list(loc = cz_geojson)) + neotoma2:::neotoma_paginate( + "https://api.neotomadb.org/v2.0/", "data/sites", + list(loc = cz_geojson) + ) expect_equal(log$limits, 2000) }) @@ -136,8 +172,10 @@ test_that("the loc geometry is converted once, not once per page", { .package = "neotoma2" ) - neotoma2:::neotoma_paginate("https://api.neotomadb.org/v2.0/", - "data/sites", list(loc = cz_geojson)) + neotoma2:::neotoma_paginate( + "https://api.neotomadb.org/v2.0/", + "data/sites", list(loc = cz_geojson) + ) expect_equal(length(log$offsets), 3) expect_equal(calls, 1) @@ -164,18 +202,22 @@ test_that("a timed-out request is retried at most once", { stop("Timeout was reached: Operation timed out after 180000 ms") }, .package = "neotoma2") - expect_error(neotoma2:::neotoma_retry("POST", api_url, times = 4), - "did not respond within") + expect_error( + neotoma2:::neotoma_retry("POST", api_url, times = 4), + "did not respond within" + ) expect_equal(attempts, 2) }) test_that("rate limiting (429) is retried up to `times`", { attempts <- 0 - local_mocked_bindings(VERB = function(...) { - attempts <<- attempts + 1 - fake_response(429) - }, neotoma_wait = function(response, attempt) invisible(0), - .package = "neotoma2") + local_mocked_bindings( + VERB = function(...) { + attempts <<- attempts + 1 + fake_response(429) + }, neotoma_wait = function(response, attempt) invisible(0), + .package = "neotoma2" + ) response <- neotoma2:::neotoma_retry("GET", api_url, times = 3) @@ -188,11 +230,13 @@ test_that("a busy gateway (502/503/504) is retried at most once", { # stacks a second heavy query on the first. for (status in c(502, 503, 504)) { attempts <- 0 - local_mocked_bindings(VERB = function(...) { - attempts <<- attempts + 1 - fake_response(status) - }, neotoma_wait = function(response, attempt) invisible(0), - .package = "neotoma2") + local_mocked_bindings( + VERB = function(...) { + attempts <<- attempts + 1 + fake_response(status) + }, neotoma_wait = function(response, attempt) invisible(0), + .package = "neotoma2" + ) response <- neotoma2:::neotoma_retry("GET", api_url, times = 4) @@ -240,8 +284,10 @@ test_that("the wait before a retry follows the policy", { # A Retry-After that is a date, or nonsense, is ignored; so is a connection # error. Both fall back to a short jittered backoff. slept <- NULL - a_date <- fake_response(429, - list("retry-after" = "Wed, 21 Oct 2026 07:28:00 GMT")) + a_date <- fake_response( + 429, + list("retry-after" = "Wed, 21 Oct 2026 07:28:00 GMT") + ) neotoma2:::neotoma_wait(a_date, 2) neotoma2:::neotoma_wait(simpleError("Could not resolve host"), 2) expect_true(all(slept >= 3 & slept <= 5)) @@ -307,9 +353,11 @@ test_that("get_params fetches the Swagger document once per session", { fetches <- 0 local_mocked_bindings(get_swagger = function() { fetches <<- fetches + 1 - paste0('"v2.0/data/testendpoint": {', - '"#/components/parameters/siteidQuery"', - '"#/components/parameters/sitenameQuery"', "}\n") + paste0( + '"v2.0/data/testendpoint": {', + '"#/components/parameters/siteidQuery"', + '"#/components/parameters/sitenameQuery"', "}\n" + ) }, .package = "neotoma2") first <- neotoma2:::get_params("testendpoint") @@ -317,8 +365,8 @@ test_that("get_params fetches the Swagger document once per session", { expect_equal(fetches, 1) expect_identical(first, second) - expect_true(all(c("siteid", "sitename", "limit", "offset", "all_data") %in% - unlist(first))) + expected_args <- c("siteid", "sitename", "limit", "offset", "all_data") + expect_true(all(expected_args %in% unlist(first))) }) @@ -334,7 +382,8 @@ test_that("the User-Agent carries the package and R versions", { ua <- neotoma2:::neotoma_user_agent() expect_match(ua, "^neotoma2/[0-9][0-9.]* \\(R [0-9.]+\\)$") expect_match(ua, as.character(utils::packageVersion("neotoma2")), - fixed = TRUE) + fixed = TRUE + ) }) test_that("a contact is added to the User-Agent only when one is set", { @@ -349,11 +398,15 @@ test_that("a contact is added to the User-Agent only when one is set", { Sys.setenv(NEOTOMA_CONTACT = "env@example.org") expect_match(neotoma2:::neotoma_user_agent(), - "; contact: env@example.org)", fixed = TRUE) + "; contact: env@example.org)", + fixed = TRUE + ) options(neotoma2.contact = "opt@example.org") expect_match(neotoma2:::neotoma_user_agent(), - "; contact: opt@example.org)", fixed = TRUE) + "; contact: opt@example.org)", + fixed = TRUE + ) }) test_that("a web page in place of data gets a clear error", { @@ -373,20 +426,30 @@ json_failure <- function(status, json) { test_that("the API's reason for a failure is shown to the user", { # Current shape: the database error is in `message`, `data` is null. - json <- paste0('{"status":"failure","data":null,', - '"message":"operator does not exist: integer = text"}') + json <- paste0( + '{"status":"failure","data":null,', + '"message":"operator does not exist: integer = text"}' + ) new_shape <- json_failure(500, json) - expect_equal(neotoma2:::neotoma_api_message(new_shape), - "operator does not exist: integer = text") - expect_error(neotoma2:::neotoma_status_check(new_shape), - "The API said: operator does not exist: integer = text") + expect_equal( + neotoma2:::neotoma_api_message(new_shape), + "operator does not exist: integer = text" + ) + expect_error( + neotoma2:::neotoma_status_check(new_shape), + "The API said: operator does not exist: integer = text" + ) # Earlier shape: the database error is in `data`, `message` is generic. - json <- paste0('{"status":"failure","data":', - '"operator does not exist: integer = text",', - '"message":"SQL Error."}') + json <- paste0( + '{"status":"failure","data":', + '"operator does not exist: integer = text",', + '"message":"SQL Error."}' + ) old_shape <- json_failure(500, json) - expect_equal(neotoma2:::neotoma_api_message(old_shape), - "operator does not exist: integer = text") + expect_equal( + neotoma2:::neotoma_api_message(old_shape), + "operator does not exist: integer = text" + ) # No usable reason: the plain HTTP error still comes through. html <- fake_response(500) html$content <- charToRaw("oops") @@ -396,10 +459,14 @@ test_that("the API's reason for a failure is shown to the user", { }) test_that("a busy server is named as such, not blamed on the API path", { - expect_error(neotoma2:::neotoma_status_check(fake_response(504)), - "busy or restarting") - expect_error(neotoma2:::neotoma_status_check(fake_response(429)), - "Too many requests") + expect_error( + neotoma2:::neotoma_status_check(fake_response(504)), + "busy or restarting" + ) + expect_error( + neotoma2:::neotoma_status_check(fake_response(429)), + "Too many requests" + ) }) ## Capture the requests that neotoma_retry() would make, and answer each with @@ -410,8 +477,10 @@ record_requests <- function(log) { log$verb <- c(log$verb, verb) log$url <- c(log$url, url) log$body <- c(log$body, if (!is.null(args$body)) as.character(args$body)) - log$config <- c(log$config, list(Filter(function(a) inherits(a, "request"), - args))) + log$config <- c(log$config, list(Filter( + function(a) inherits(a, "request"), + args + ))) ids <- if (!is.null(args$body)) { sent <- jsonlite::fromJSON(as.character(args$body)) as.character(if (!is.null(sent$siteid)) sent$siteid else sent$datasetid) @@ -433,11 +502,15 @@ test_that("long id lists go as short GETs where there is no POST route", { # redirected to /api-docs. for (endpoint in c("data/taxa/", "data/publications/", "data/contacts/")) { log <- new.env() - local_mocked_bindings(neotoma_retry = record_requests(log), - .package = "neotoma2") + local_mocked_bindings( + neotoma_retry = record_requests(log), + .package = "neotoma2" + ) path <- paste0(endpoint, paste(1:1500, collapse = ",")) - result <- neotoma2:::neotoma_fetch("https://api.neotomadb.org/", path, - list(offset = 0, limit = 2000)) + result <- neotoma2:::neotoma_fetch( + "https://api.neotomadb.org/", path, + list(offset = 0, limit = 2000) + ) expect_true(all(log$verb == "GET"), info = endpoint) expect_length(log$url, 15) expect_true(all(nchar(log$url) < 2000), info = endpoint) @@ -446,7 +519,8 @@ test_that("long id lists go as short GETs where there is no POST route", { requested <- as.numeric(unlist(strsplit(sub(".*[=/]", "", log$url), ","))) expect_equal(requested, 1:1500, info = endpoint) expect_equal(vapply(result$data, function(r) r$id, numeric(1)), 1:1500, - info = endpoint) + info = endpoint + ) } }) @@ -454,32 +528,46 @@ test_that("long id lists for sites, datasets, downloads POST in chunks", { cases <- list( list(path = "data/sites/", post = "data/sites", key = "siteid"), list(path = "data/datasets/", post = "data/datasets", key = "datasetid"), - list(path = "data/downloads?datasetid=", post = "data/downloads", - key = "datasetid") + list( + path = "data/downloads?datasetid=", post = "data/downloads", + key = "datasetid" + ) ) for (case in cases) { log <- new.env() - local_mocked_bindings(neotoma_retry = record_requests(log), - .package = "neotoma2") + local_mocked_bindings( + neotoma_retry = record_requests(log), + .package = "neotoma2" + ) path <- paste0(case$path, paste(1:1500, collapse = ",")) - result <- neotoma2:::neotoma_fetch("https://api.neotomadb.org/v2.0/", path, - list(offset = 0, limit = 2000)) + result <- neotoma2:::neotoma_fetch( + "https://api.neotomadb.org/v2.0/", path, + list(offset = 0, limit = 2000) + ) expect_true(all(log$verb == "POST"), info = case$path) expect_length(log$url, 15) # the ids are in the body, never in the URL, so no `?datasetid=` prefix can # leak into a body value - expect_true(all(log$url == paste0("https://api.neotomadb.org/v2.0/", - case$post)), info = case$path) + expect_true(all(log$url == paste0( + "https://api.neotomadb.org/v2.0/", + case$post + )), info = case$path) bodies <- lapply(log$body, jsonlite::fromJSON) - expect_true(all(vapply(bodies, function(b) !is.null(b[[case$key]]), - logical(1))), info = case$path) + expect_true(all(vapply( + bodies, function(b) !is.null(b[[case$key]]), + logical(1) + )), info = case$path) expect_true(all(vapply(bodies, function(b) b$limit == 2000, logical(1))), - info = case$path) - sent <- as.numeric(unlist(strsplit(vapply(bodies, function(b) b[[case$key]], - character(1)), ","))) + info = case$path + ) + sent <- as.numeric(unlist(strsplit(vapply( + bodies, function(b) b[[case$key]], + character(1) + ), ","))) expect_equal(sent, 1:1500, info = case$path) expect_equal(vapply(result$data, function(r) r$id, numeric(1)), 1:1500, - info = case$path) + info = case$path + ) } }) @@ -487,13 +575,19 @@ test_that("a POST keeps its method and body through a redirect", { # libcurl turns a redirected POST into a GET and drops the body unless asked # not to; the API then answers with its unfiltered first page. log <- new.env() - local_mocked_bindings(neotoma_retry = record_requests(log), - .package = "neotoma2") - neotoma2:::neotoma_post("https://api.neotomadb.org/v2.0/data/sites", - list(siteid = "24,25")) - expect_true(any(vapply(log$config[[1]], - function(a) identical(a$options$postredir, 7), - logical(1)))) + local_mocked_bindings( + neotoma_retry = record_requests(log), + .package = "neotoma2" + ) + neotoma2:::neotoma_post( + "https://api.neotomadb.org/v2.0/data/sites", + list(siteid = "24,25") + ) + expect_true(any(vapply( + log$config[[1]], + function(a) identical(a$options$postredir, 7), + logical(1) + ))) }) test_that("a POST for ids that were not applied is reported, not returned", { @@ -506,23 +600,33 @@ test_that("a POST for ids that were not applied is reported, not returned", { local_mocked_bindings(neotoma_retry = default_page, .package = "neotoma2") # more records than ids api <- "https://api.neotomadb.org/v2.0/" - expect_error(neotoma2:::neotoma_get_ids(api, "data/sites/24,25,26", list()), - "ids were not applied") + expect_error( + neotoma2:::neotoma_get_ids(api, "data/sites/24,25,26", list()), + "ids were not applied" + ) # fewer records than ids, but not the ones asked for other_ids <- paste0("data/sites/", paste(101:200, collapse = ",")) - expect_error(neotoma2:::neotoma_get_ids(api, other_ids, list()), - "ids were not applied") + expect_error( + neotoma2:::neotoma_get_ids(api, other_ids, list()), + "ids were not applied" + ) returned <- list(list(siteid = 24), list(siteid = 25)) - expect_true(neotoma2:::neotoma_ids_applied(returned, "siteid", - c("24", "25", "26"))) + expect_true(neotoma2:::neotoma_ids_applied( + returned, "siteid", + c("24", "25", "26") + )) }) test_that("a spatial loc query is still sent as a POST body", { log <- new.env() - local_mocked_bindings(neotoma_retry = record_requests(log), - .package = "neotoma2") - neotoma2:::neotoma_fetch("https://api.neotomadb.org/", "data/datasets", - list(loc = cz_geojson, limit = 5)) + local_mocked_bindings( + neotoma_retry = record_requests(log), + .package = "neotoma2" + ) + neotoma2:::neotoma_fetch( + "https://api.neotomadb.org/", "data/datasets", + list(loc = cz_geojson, limit = 5) + ) expect_equal(log$verb, "POST") expect_equal(log$url, "https://api.neotomadb.org/data/datasets") expect_true(jsonlite::validate(log$body)) @@ -530,39 +634,53 @@ test_that("a spatial loc query is still sent as a POST body", { test_that("a long filter list is POSTed where there is a route, else one GET", { log <- new.env() - local_mocked_bindings(neotoma_retry = record_requests(log), - .package = "neotoma2") + local_mocked_bindings( + neotoma_retry = record_requests(log), + .package = "neotoma2" + ) neotoma2:::parseURL("data/datasets", taxa = paste0("Taxon", 1:300), limit = 5) expect_equal(log$verb, "POST") expect_equal(jsonlite::fromJSON(log$body)$limit, 5) expect_length(strsplit(jsonlite::fromJSON(log$body)$taxa, ",")[[1]], 300) log2 <- new.env() - local_mocked_bindings(neotoma_retry = record_requests(log2), - .package = "neotoma2") - neotoma2:::parseURL("data/publications", search = strrep("word ", 500), - limit = 5) + local_mocked_bindings( + neotoma_retry = record_requests(log2), + .package = "neotoma2" + ) + neotoma2:::parseURL("data/publications", + search = strrep("word ", 500), + limit = 5 + ) expect_equal(log2$verb, "GET") expect_length(log2$url, 1) }) test_that("only the endpoints the API accepts a POST for are POST-routed", { - yes <- c("data/sites", "data/datasets", "data/downloads", "data/datasets/24", - "data/sites/24/datasets", "data/geopoliticalunits/1/sites", - "data/downloads?datasetid=1,2") - no <- c("data/taxa", "data/taxa/1,2", "data/publications", "data/contacts", - "data/sites/24", "data/sites/24/chronologies", - "data/dbtables/agetypes") + yes <- c( + "data/sites", "data/datasets", "data/downloads", "data/datasets/24", + "data/sites/24/datasets", "data/geopoliticalunits/1/sites", + "data/downloads?datasetid=1,2" + ) + no <- c( + "data/taxa", "data/taxa/1,2", "data/publications", "data/contacts", + "data/sites/24", "data/sites/24/chronologies", + "data/dbtables/agetypes" + ) expect_true(all(vapply(yes, neotoma2:::neotoma_post_route, logical(1)))) expect_false(any(vapply(no, neotoma2:::neotoma_post_route, logical(1)))) }) test_that("a short id list is still a single GET", { log <- new.env() - local_mocked_bindings(neotoma_retry = record_requests(log), - .package = "neotoma2") - neotoma2:::neotoma_fetch("https://api.neotomadb.org/", "data/taxa/1,2,3", - list()) + local_mocked_bindings( + neotoma_retry = record_requests(log), + .package = "neotoma2" + ) + neotoma2:::neotoma_fetch( + "https://api.neotomadb.org/", "data/taxa/1,2,3", + list() + ) expect_equal(log$verb, "GET") expect_length(log$url, 1) }) @@ -575,9 +693,11 @@ test_that("a multi-valued argument is sent as one comma-separated value", { sent <<- query list(status = 200, data = list()) }, .package = "neotoma2") - neotoma2:::parseURL("data/datasets", taxa = c("Abies", "Pinus"), - datasettype = c("pollen", "macrofossil"), limit = 5, - loc = c(-80, 40, -70, 50)) + neotoma2:::parseURL("data/datasets", + taxa = c("Abies", "Pinus"), + datasettype = c("pollen", "macrofossil"), limit = 5, + loc = c(-80, 40, -70, 50) + ) expect_equal(sent$taxa, "Abies,Pinus") expect_equal(sent$datasettype, "pollen,macrofossil") expect_equal(sent$limit, 5) @@ -591,6 +711,7 @@ test_that("a vector parameter makes a valid GET URL end to end", { fake_body('{"status":"success","data":[]}') }, .package = "neotoma2") expect_no_error(neotoma2:::parseURL("data/datasets", - taxa = c("Abies", "Pinus"))) + taxa = c("Abies", "Pinus") + )) expect_equal(log$query$taxa, "Abies,Pinus") }) diff --git a/tests/testthat/test_parse_location.R b/tests/testthat/test_parse_location.R index 280293a4..328e828c 100644 --- a/tests/testthat/test_parse_location.R +++ b/tests/testthat/test_parse_location.R @@ -4,12 +4,14 @@ testthat::test_that("Parse location fails with an incomplete bounding box:", { }) # testthat::test_that("We can pass in an sf object and return the WKT:", { +# nolint start # g <- sf::st_sfc(st_point(1:2)) # sf_obj <- sf::st_sf(a = 3, g) # testthat::expect_is(parseLocation(sf_obj), "geojson") # }) -# +# # testthat::test_that("Passing in a WKT works:", { # poly <- parse_location("POLYGON ((40 40, 20 45, 45 30, 40 40))") # testthat::expect_is(parseLocation(poly), "geojson") +# nolint end # }) diff --git a/tests/testthat/test_parse_site.R b/tests/testthat/test_parse_site.R index 4aecaf95..36d8d356 100644 --- a/tests/testthat/test_parse_site.R +++ b/tests/testthat/test_parse_site.R @@ -5,7 +5,8 @@ context("Test `parse_site()` builds the right number of objects.") test_that("parse_site keeps one site, one collection unit and both datasets", { result <- jsonlite::fromJSON(test_path("fixtures", "data_sites24.json"), - simplifyVector = FALSE) + simplifyVector = FALSE + ) sites <- neotoma2:::parse_site(result) ids <- getids(sites) # The API returns two collection units that share id 24 but each carries a @@ -18,7 +19,8 @@ test_that("parse_site keeps one site, one collection unit and both datasets", { test_that("parse_site of a datasets response keeps the site and dataset", { result <- jsonlite::fromJSON(test_path("fixtures", "data_datasets24.json"), - simplifyVector = FALSE) + simplifyVector = FALSE + ) sites <- neotoma2:::parse_site(result) ids <- getids(sites) testthat::expect_length(sites, 1) @@ -27,8 +29,8 @@ test_that("parse_site of a datasets response keeps the site and dataset", { }) test_that("parse_site of a downloads response folds the repeated unit", { - result <- jsonlite::fromJSON(test_path("fixtures", "data_downloads24_dup.json"), - simplifyVector = FALSE) + fixture <- test_path("fixtures", "data_downloads24_dup.json") + result <- jsonlite::fromJSON(fixture, simplifyVector = FALSE) # `downloads` returns one element per dataset, so collection unit 24 arrives # twice, once for dataset 24 and once for dataset 7870. We keep one unit. testthat::expect_length(result$data, 2) @@ -42,11 +44,14 @@ test_that("parse_site of a downloads response folds the repeated unit", { test_that("parse_site reads the same site from every endpoint format", { # The three endpoints describe site 24 in three different shapes, and spell # several fields differently. They should still parse to the same site. - files <- c("data_sites24.json", "data_datasets24.json", - "data_downloads24_dup.json") + files <- c( + "data_sites24.json", "data_datasets24.json", + "data_downloads24_dup.json" + ) sites <- lapply(files, function(f) { neotoma2:::parse_site(jsonlite::fromJSON(test_path("fixtures", f), - simplifyVector = FALSE)) + simplifyVector = FALSE + )) }) for (site in sites) { testthat::expect_length(site, 1) @@ -65,7 +70,8 @@ test_that("parse_site keeps the dataset fields the API reports", { # `datasetnotes`, `agerange$units` and `datasetpi` each used to be lost # between `parse_site()` and `build_dataset()`. result <- jsonlite::fromJSON(test_path("fixtures", "data_datasets24.json"), - simplifyVector = FALSE) + simplifyVector = FALSE + ) sites <- neotoma2:::parse_site(result) ds <- sites[[1]]@collunits@collunits[[1]]@datasets@datasets[[1]] testthat::expect_equal(ds@age_units, "Calendar years BP") @@ -76,11 +82,13 @@ test_that("parse_site keeps the dataset fields the API reports", { }) test_that("parse_site reads the geopolitical units from a download", { - result <- jsonlite::fromJSON(test_path("fixtures", "data_downloads24_dup.json"), - simplifyVector = FALSE) + fixture <- test_path("fixtures", "data_downloads24_dup.json") + result <- jsonlite::fromJSON(fixture, simplifyVector = FALSE) sites <- neotoma2:::parse_site(result) - testthat::expect_setequal(unlist(sites[[1]]@geopolitical), - c("Freedonia", "Northern Province")) + testthat::expect_setequal( + unlist(sites[[1]]@geopolitical), + c("Freedonia", "Northern Province") + ) }) test_that("parse_site reads chronology metadata from a download", { @@ -99,8 +107,12 @@ test_that("a site returns the same counts from sites and datasets", { # end up with the same site, the same units and the same datasets. from_sites <- getids(get_sites(666)) from_datasets <- getids(get_datasets(get_sites(666))) - testthat::expect_setequal(unique(from_sites$collunitid), - unique(from_datasets$collunitid)) - testthat::expect_setequal(unique(from_sites$datasetid), - unique(from_datasets$datasetid)) + testthat::expect_setequal( + unique(from_sites$collunitid), + unique(from_datasets$collunitid) + ) + testthat::expect_setequal( + unique(from_sites$datasetid), + unique(from_datasets$datasetid) + ) }) diff --git a/tests/testthat/test_parse_speleothem.R b/tests/testthat/test_parse_speleothem.R index 33367522..f122f731 100644 --- a/tests/testthat/test_parse_speleothem.R +++ b/tests/testthat/test_parse_speleothem.R @@ -10,17 +10,21 @@ context("Test `parse_speleothem()` against partial API records.") ## The shape parse_speleothem() consumes: a list of records, each wrapping the ## speleothem fields under `$speleothem`. speleothem_record <- function(entityid, ...) { - fields <- list(entityid = entityid, - entityname = paste0("Entity ", entityid), - siteid = 1, - collectionunitid = 1, - datasetid = 1) + fields <- list( + entityid = entityid, + entityname = paste0("Entity ", entityid), + siteid = 1, + collectionunitid = 1, + datasetid = 1 + ) list(speleothem = utils::modifyList(fields, list(...))) } test_that("a record without entrancedistanceunits parses", { - # The API omits this field rather than sending null, so `x$entrancedistanceunits` - # is NULL and `NULL == 37` is logical(0) -- which `if` cannot evaluate. Three of + # The API omits this field rather than sending null, so + # `x$entrancedistanceunits` + # is NULL and `NULL == 37` is logical(0) -- which `if` cannot evaluate. Three + # of # the seven La Vallina records come back this way, so an unguarded comparison # takes down get_speleothems() for most real queries. result <- neotoma2:::parse_speleothem(list(speleothem_record(1))) @@ -32,13 +36,15 @@ test_that("a record without entrancedistanceunits parses", { test_that("the unit code 37 is still translated to metres", { result <- neotoma2:::parse_speleothem( - list(speleothem_record(2, entrancedistanceunits = 37))) + list(speleothem_record(2, entrancedistanceunits = 37)) + ) testthat::expect_equal(result@speleothems[[1]]@entrancedistanceunits, "m") }) ## Note: the API only ever sends this field as the code 37 or omits it, which is -## what these tests cover. A different numeric code would still fail, in the slot +## what these tests cover. A different numeric code would still fail, in the +## slot ## assignment rather than here -- out of scope for this fix. test_that("a missing measurement does not pick up its own units string", { @@ -47,8 +53,10 @@ test_that("a missing measurement does not pick up its own units string", { # that string into a numeric slot. Same trap for dripheight/dripheightunits. result <- neotoma2:::parse_speleothem( list(speleothem_record(4, - entrancedistanceunits = 37, - dripheightunits = "cm"))) + entrancedistanceunits = 37, + dripheightunits = "cm" + )) + ) speleothem <- result@speleothems[[1]] testthat::expect_true(is.na(speleothem@entrancedistance)) @@ -61,14 +69,19 @@ test_that("a mixed batch parses every record", { # The real failure mode: one good record and one missing the field. Before the # guard the whole batch errored, losing the valid entries too. result <- neotoma2:::parse_speleothem( - list(speleothem_record(1), - speleothem_record(2, entrancedistanceunits = 37), - speleothem_record(3))) + list( + speleothem_record(1), + speleothem_record(2, entrancedistanceunits = 37), + speleothem_record(3) + ) + ) testthat::expect_length(result@speleothems, 3) - units <- vapply(result@speleothems, - function(x) as.character(x@entrancedistanceunits), - character(1)) + units <- vapply( + result@speleothems, + function(x) as.character(x@entrancedistanceunits), + character(1) + ) testthat::expect_equal(sum(is.na(units)), 2) testthat::expect_equal(sum(units == "m", na.rm = TRUE), 1) }) diff --git a/tests/testthat/test_pingNeotoma.R b/tests/testthat/test_pingNeotoma.R index ce4481e7..3f7e1c1d 100644 --- a/tests/testthat/test_pingNeotoma.R +++ b/tests/testthat/test_pingNeotoma.R @@ -6,11 +6,15 @@ test_that("The Pings work", { skip_on_cran() ping_head <- try(httr::HEAD("https://api.neotomadb.org")) ping_call <- try(pingNeotoma("neotoma")) - testthat::expect_equal(ping_head$status_code, - ping_call$status_code) - + testthat::expect_equal( + ping_head$status_code, + ping_call$status_code + ) + ping_head <- try(httr::HEAD("https://api-dev.neotomadb.org")) ping_call <- try(pingNeotoma("dev")) - testthat::expect_equal(ping_head$status_code, - ping_call$status_code) + testthat::expect_equal( + ping_head$status_code, + ping_call$status_code + ) }) diff --git a/tests/testthat/test_plot.R b/tests/testthat/test_plot.R index 410f6a35..98681ffb 100644 --- a/tests/testthat/test_plot.R +++ b/tests/testthat/test_plot.R @@ -16,4 +16,4 @@ testthat::test_that("Plot a single record with plot.", { grDevices::pdf(NULL) on.exit(grDevices::dev.off(), add = TRUE) testthat::expect_error(plot(five[[1]]), NA) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_samples.R b/tests/testthat/test_samples.R index b622ac7c..e0f57d09 100644 --- a/tests/testthat/test_samples.R +++ b/tests/testthat/test_samples.R @@ -8,21 +8,27 @@ context("`samples()` retrieves a data.frame of all data.") # large downloads (0.9-1 MB each, plus a 13-dataset loop) that are too big to # ship as fixtures, so they stay live and skip on CI (GitHub Actions). httptest::with_mock_api({ -test_that("`samples` retrieve df.", { - skip_on_cran() - dl <- get_downloads(4716) %>% samples() - singlechron <- testthat::expect_true({dl; TRUE}) - # expect the return is a data frame - testthat::expect_is(dl, "data.frame") - testthat::expect_gt(nrow(dl), 0) - # expect at least one row - - dl2 <- get_downloads(21007) %>% samples() - testthat::expect_true({dl2; TRUE}) - testthat::expect_is(dl2, "data.frame") - testthat::expect_gt(nrow(dl2), 0) -}) -}) # end with_mock_api + test_that("`samples` retrieve df.", { + skip_on_cran() + dl <- get_downloads(4716) %>% samples() + singlechron <- testthat::expect_true({ + dl + TRUE + }) + # expect the return is a data frame + testthat::expect_is(dl, "data.frame") + testthat::expect_gt(nrow(dl), 0) + # expect at least one row + + dl2 <- get_downloads(21007) %>% samples() + testthat::expect_true({ + dl2 + TRUE + }) + testthat::expect_is(dl2, "data.frame") + testthat::expect_gt(nrow(dl2), 0) + }) +}) # end with_mock_api test_that("Get the samples out of dataset 15692.", { skip_on_cran() @@ -43,58 +49,66 @@ test_that("ggplot2 on samples", { group_by(age, ecologicalgroup) %>% dplyr::summarize(count = sum(value)) %>% ggplot2::ggplot() + - ggplot2::geom_path(ggplot2::aes(x = age, - y = count, - color = ecologicalgroup)) + ggplot2::geom_path(ggplot2::aes( + x = age, + y = count, + color = ecologicalgroup + )) testthat::expect_is(aa, "gg") }) # Test that no duplicated sampleids exist for a variety of datasetids # c(48891, 52833 52742) dups -datasetids <- c(41625, 46798, 48891, 47771, - 41620, 46689, 52833, 48756, - 52742, 46700, 47608, 46841, - 49238) +datasetids <- c( + 41625, 46798, 48891, 47771, + 41620, 46689, 52833, 48756, + 52742, 46700, 47608, 46841, + 49238 +) for (i in datasetids) { - test_that(paste0("Duplicated sampleids for Dataset ID, ", - i, " don't exist (in the APD)"), { - skip_on_cran() - skip_on_ci() - L <- get_datasets(i) %>% - get_downloads() - my_counts <- samples(L) - assertthat::assert_that(!any(duplicated(my_counts))) - counts <- my_counts %>% - mutate(age_chr = ifelse(is.na(age), "__NA__", - as.character(age))) %>% - pivot_wider( - id_cols = age_chr, - names_from = variablename, - values_from = value, - values_fn = sum, - values_fill = NA - ) %>% - mutate(age = as.numeric(dplyr::na_if(age_chr, "__NA__"))) %>% - select(-age_chr) - - counts <- counts%>% - tryCatch(.data, - error = function(e) e, - warning = function(w) w) - testthat::expect_false(any(duplicated(my_counts))) - testthat::expect_false(is(counts, "warning")) - }) + test_that(paste0( + "Duplicated sampleids for Dataset ID, ", + i, " don't exist (in the APD)" + ), { + skip_on_cran() + skip_on_ci() + dl <- get_datasets(i) %>% + get_downloads() + my_counts <- samples(dl) + assertthat::assert_that(!any(duplicated(my_counts))) + counts <- my_counts %>% + mutate(age_chr = ifelse(is.na(age), "__NA__", + as.character(age) + )) %>% + pivot_wider( + id_cols = age_chr, + names_from = variablename, + values_from = value, + values_fn = sum, + values_fill = NA + ) %>% + mutate(age = as.numeric(dplyr::na_if(age_chr, "__NA__"))) %>% + select(-age_chr) + + counts <- counts %>% + tryCatch(.data, + error = function(e) e, + warning = function(w) w + ) + testthat::expect_false(any(duplicated(my_counts))) + testthat::expect_false(is(counts, "warning")) + }) } -test_that("Samples of all sites has the same nrow as samples of each site combined", { +test_that("Samples of all sites have the same nrow as the sites combined", { skip_on_cran() skip_on_ci() - si <- get_sites(limit=3) + si <- get_sites(limit = 3) dl <- get_downloads(si) df1 <- nrow(samples(dl[[1]])) df2 <- nrow(samples(dl[[2]])) df3 <- nrow(samples(dl[[3]])) - + all_df <- nrow(samples(dl)) testthat::expect_equal(all_df, df1 + df2 + df3) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_set_chronology.R b/tests/testthat/test_set_chronology.R index 6d66f27c..746fe8ae 100644 --- a/tests/testthat/test_set_chronology.R +++ b/tests/testthat/test_set_chronology.R @@ -17,36 +17,42 @@ test_that("Add a new chronology to a record:", { select(depth, analysisunitid) %>% unique() %>% arrange(depth) - new_chron <- Bchron::Bchronology(ages = controls$chroncontrolage, - ageSds = abs(controls$agelimityounger - - controls$chroncontrolage), - calCurves = c("normal", rep("intcal20", 4)), - positionThicknesses = controls$thickness, - positions = controls$depth, - allowOutside = TRUE, - ids = controls$chroncontrolid) + new_chron <- Bchron::Bchronology( + ages = controls$chroncontrolage, + ageSds = abs(controls$agelimityounger - controls$chroncontrolage), + calCurves = c("normal", rep("intcal20", 4)), + positionThicknesses = controls$thickness, + positions = controls$depth, + allowOutside = TRUE, + ids = controls$chroncontrolid + ) newpredictions <- predict(new_chron, predict_depths$depth) - new_chron_stara <- set_chronology(agemodel = "Bchron model", - isdefault = TRUE, - ageboundolder = max(newpredictions), - ageboundyounger = min(newpredictions), - dateprepared = Sys.Date(), - modelagetype = "Calibrated radiocarbon years BP", - chronologyname = "Simon's example chronology", - chroncontrols = controls) + new_chron_stara <- set_chronology( + agemodel = "Bchron model", + isdefault = TRUE, + ageboundolder = max(newpredictions), + ageboundyounger = min(newpredictions), + dateprepared = Sys.Date(), + modelagetype = "Calibrated radiocarbon years BP", + chronologyname = "Simon's example chronology", + chroncontrols = controls + ) new_sample_ages <- data.frame(predict_depths, - age = colMeans(newpredictions), - ageolder = colMeans(newpredictions) + - apply(newpredictions, 2, sd), - ageyounger = colMeans(newpredictions) - - apply(newpredictions, 2, sd), - agetype = "Calibrated radiocarbon years") - stara[[1]]$collunits[[1]] <- add_chronology(stara[[1]]$collunits[[1]], - new_chron_stara, - new_sample_ages) + age = colMeans(newpredictions), + ageolder = colMeans(newpredictions) + + apply(newpredictions, 2, sd), + ageyounger = colMeans(newpredictions) - + apply(newpredictions, 2, sd), + agetype = "Calibrated radiocarbon years" + ) + stara[[1]]$collunits[[1]] <- add_chronology( + stara[[1]]$collunits[[1]], + new_chron_stara, + new_sample_ages + ) last_age <- samples(stara) %>% dplyr::filter(analysisunitid == 194633) %>% select(age) %>% unique() testthat::expect_true(last_age == new_sample_ages$age[nrow(new_sample_ages)]) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_set_collunit.R b/tests/testthat/test_set_collunit.R index 3714a2ee..bb96dddc 100644 --- a/tests/testthat/test_set_collunit.R +++ b/tests/testthat/test_set_collunit.R @@ -4,20 +4,24 @@ library("neotoma2") context("Creating collection units from scratch or updating existing objects.") test_that("`set_collunit()` for new collection unit", { skip_on_cran() - newCU <- set_collunit(notes = "CU set up", - handle = "My CU", - colldate = as.Date("2025-11-14"), - gpslocation = sf::st_as_sf( - sf::st_sfc( - sf::st_point(c(-100.0, 40.0)), - crs = 4326)), - collunittype = "magical") - datasets = new("datasets", datasets = list(new("dataset"))) - testthat::expect_is(newCU, "collunit") - testthat::expect_equal(newCU@handle, "My CU") - testthat::expect_equal(newCU@collunittype, "magical") - testthat::expect_equal(sf::st_coordinates(newCU@gpslocation)[1], -100.0) - testthat::expect_equal(sf::st_coordinates(newCU@gpslocation)[2], 40.0) + new_cu <- set_collunit( + notes = "CU set up", + handle = "My CU", + colldate = as.Date("2025-11-14"), + gpslocation = sf::st_as_sf( + sf::st_sfc( + sf::st_point(c(-100.0, 40.0)), + crs = 4326 + ) + ), + collunittype = "magical" + ) + datasets <- new("datasets", datasets = list(new("dataset"))) + testthat::expect_is(new_cu, "collunit") + testthat::expect_equal(new_cu@handle, "My CU") + testthat::expect_equal(new_cu@collunittype, "magical") + testthat::expect_equal(sf::st_coordinates(new_cu@gpslocation)[1], -100.0) + testthat::expect_equal(sf::st_coordinates(new_cu@gpslocation)[2], 40.0) }) test_that("Updating existing collection unit", { @@ -25,11 +29,12 @@ test_that("Updating existing collection unit", { # Invalid input: testthat::expect_error(set_collunit(x = 12, waterdepth = 33)) # Cannot update over a sites object: - downloadSite <- get_sites(limit = 1) - testthat::expect_error(set_collunit(x = downloadSite, waterdepth = 33)) + download_site <- get_sites(limit = 1) + testthat::expect_error(set_collunit(x = download_site, waterdepth = 33)) # Update single site - updatedSample <- set_collunit(x = downloadSite[[1]]@collunits[[1]], waterdepth = -9999) - testthat::expect_equal(updatedSample@waterdepth, -9999) + cu <- download_site[[1]]@collunits[[1]] + updated_sample <- set_collunit(x = cu, waterdepth = -9999) + testthat::expect_equal(updated_sample@waterdepth, -9999) # Cannot use invalid data types - testthat::expect_error(set_collunit(x = downloadSite[[1]]@collunits[[1]], waterdepth = "33a")) -}) \ No newline at end of file + testthat::expect_error(set_collunit(x = cu, waterdepth = "33a")) +}) diff --git a/tests/testthat/test_set_contact.R b/tests/testthat/test_set_contact.R index 4eae5a6e..76d126a2 100644 --- a/tests/testthat/test_set_contact.R +++ b/tests/testthat/test_set_contact.R @@ -6,10 +6,14 @@ test_that("check_contacts works properly.", { skip_on_cran() testthat::expect_error(check_contacts(12)) testthat::expect_error(check_contacts("party")) - new_name <- c(set_contact(familyname = "Goring"), - set_contact(familyname = "Cullen")) + new_name <- c( + set_contact(familyname = "Goring"), + set_contact(familyname = "Cullen") + ) testthat::expect_is(check_contacts(new_name), "list") - na_name <- c(set_contact(familyname = "Goring", contactid = NA), - set_contact(familyname = "Cullen")) + na_name <- c( + set_contact(familyname = "Goring", contactid = NA), + set_contact(familyname = "Cullen") + ) testthat::expect_is(check_contacts(na_name), "list") -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_set_dataset.R b/tests/testthat/test_set_dataset.R index ff71831e..6d807be9 100644 --- a/tests/testthat/test_set_dataset.R +++ b/tests/testthat/test_set_dataset.R @@ -4,28 +4,31 @@ library("neotoma2") context("Creating datasets from scratch or updating existing objects.") test_that("`set_dataset()` for a new dataset", { skip_on_cran() - newDS <- set_dataset(datasetid = 56, - datasetname = "My Dataset", - database = "neotoma", - recdatecreated = as.Date("2025-11-10"), - datasettype = "pollen") - testthat::expect_is(newDS, "dataset") - testthat::expect_equal(newDS@datasetname, "My Dataset") - testthat::expect_equal(newDS@datasettype, "pollen") - testthat::expect_equal(newDS@datasetid, 56) - testthat::expect_equal(newDS@database, "neotoma") - testthat::expect_equal(newDS@recdatecreated, as.Date("2025-11-10")) + new_ds <- set_dataset( + datasetid = 56, + datasetname = "My Dataset", + database = "neotoma", + recdatecreated = as.Date("2025-11-10"), + datasettype = "pollen" + ) + testthat::expect_is(new_ds, "dataset") + testthat::expect_equal(new_ds@datasetname, "My Dataset") + testthat::expect_equal(new_ds@datasettype, "pollen") + testthat::expect_equal(new_ds@datasetid, 56) + testthat::expect_equal(new_ds@database, "neotoma") + testthat::expect_equal(new_ds@recdatecreated, as.Date("2025-11-10")) testthat::expect_error(set_dataset(x = 12, waterdepth = 33)) }) test_that("Updating existing dataset", { skip_on_cran() # Cannot update over a sites object: - downloadSite <- get_sites(limit = 1) - testthat::expect_error(set_dataset(x = downloadSite, datasetid = -9999)) + download_site <- get_sites(limit = 1) + testthat::expect_error(set_dataset(x = download_site, datasetid = -9999)) # Update single site - updatedSample <- set_dataset(x = downloadSite[[1]]@collunits[[1]]@datasets[[1]], datasetid = -9999) - testthat::expect_equal(updatedSample@datasetid, -9999) + ds <- download_site[[1]]@collunits[[1]]@datasets[[1]] + updated_sample <- set_dataset(x = ds, datasetid = -9999) + testthat::expect_equal(updated_sample@datasetid, -9999) # Cannot use invalid data types - testthat::expect_error(set_dataset(x = downloadSite[[1]]@collunits[[1]]@datasets[[1]], waterdepth = "33a")) -}) \ No newline at end of file + testthat::expect_error(set_dataset(x = ds, waterdepth = "33a")) +}) diff --git a/tests/testthat/test_set_default.R b/tests/testthat/test_set_default.R index 32d6b419..657ab292 100644 --- a/tests/testthat/test_set_default.R +++ b/tests/testthat/test_set_default.R @@ -10,4 +10,4 @@ test_that("Set and change the default chronology.", { df_newchron <- as.data.frame(newchron)$isdefault tester <- all(df_default == df_newchron) testthat::expect_false(tester) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_set_publication.R b/tests/testthat/test_set_publication.R index 2b265d87..d79dfdb3 100644 --- a/tests/testthat/test_set_publication.R +++ b/tests/testthat/test_set_publication.R @@ -4,21 +4,25 @@ library("neotoma2") context("Creating publications from scratch or updating existing objects.") test_that("`set_publication()` for a new publication", { skip_on_cran() - newPub <- set_publication(publicationid = 56, - citation = "Citation for my publication", - doi = "fake.doi/10.1234/fake") - testthat::expect_is(newPub, "publication") - testthat::expect_equal(newPub@publicationid, 56) - testthat::expect_equal(newPub@citation, "Citation for my publication") - testthat::expect_equal(newPub@doi, "fake.doi/10.1234/fake") + new_pub <- set_publication( + publicationid = 56, + citation = "Citation for my publication", + doi = "fake.doi/10.1234/fake" + ) + testthat::expect_is(new_pub, "publication") + testthat::expect_equal(new_pub@publicationid, 56) + testthat::expect_equal(new_pub@citation, "Citation for my publication") + testthat::expect_equal(new_pub@doi, "fake.doi/10.1234/fake") }) test_that("Updating existing publication", { skip_on_cran() # Cannot update over a sites object: - downloadPub <- get_publications(search = "pollen", limit = 1) - testthat::expect_error(set_publications(x = downloadPub, doi = "fake.doi/10.1234/fake")) - testthat::expect_is(set_publication(x = downloadPub[[1]], doi = "fake.doi/10.1234/fake"), "publication") - updatedPub <- set_publication(x = downloadPub[[1]], doi = "fake.doi/10.1234/fake") - testthat::expect_equal(updatedPub@doi, "fake.doi/10.1234/fake") -}) \ No newline at end of file + download_pub <- get_publications(search = "pollen", limit = 1) + fake_doi <- "fake.doi/10.1234/fake" + testthat::expect_error(set_publications(x = download_pub, doi = fake_doi)) + testthat::expect_is(set_publication(x = download_pub[[1]], doi = fake_doi), + "publication") + updated_pub <- set_publication(x = download_pub[[1]], doi = fake_doi) + testthat::expect_equal(updated_pub@doi, "fake.doi/10.1234/fake") +}) diff --git a/tests/testthat/test_set_sample.R b/tests/testthat/test_set_sample.R index cd57d892..805ced9e 100644 --- a/tests/testthat/test_set_sample.R +++ b/tests/testthat/test_set_sample.R @@ -5,10 +5,12 @@ context("Creating samples from scratch or updating existing sample objects.") test_that("Creating samples for the neotoma2 package.", { skip_on_cran() testthat::expect_error(set_sample(x = 12, depth = 33)) - sm <- set_sample(depth = 140, - sampleid = 42, - thickness = 32, - samplename = "My Sample") + sm <- set_sample( + depth = 140, + sampleid = 42, + thickness = 32, + samplename = "My Sample" + ) testthat::expect_is(sm, "sample") testthat::expect_equal(sm@depth, 140) testthat::expect_equal(sm@sampleid, 42) @@ -17,14 +19,14 @@ test_that("Creating samples for the neotoma2 package.", { test_that("Updating samples for the neotoma2 package.", { skip_on_cran() - downloadSample <- get_sites(24) %>% get_downloads() + download_sample <- get_sites(24) %>% get_downloads() # Cannot update on sites object - testthat::expect_error(set_sample(downloadSample, depth=40)) + testthat::expect_error(set_sample(download_sample, depth = 40)) # Update single sample - oneSample <- downloadSample[[1]]@collunits[[1]]@datasets[[1]]@samples[[1]] - testthat::expect_true(is.na(oneSample@depth)) - updatedSample <- set_sample(x = oneSample, depth = 40) - testthat::expect_equal(updatedSample@depth, 40) + one_sample <- download_sample[[1]]@collunits[[1]]@datasets[[1]]@samples[[1]] + testthat::expect_true(is.na(one_sample@depth)) + updated_sample <- set_sample(x = one_sample, depth = 40) + testthat::expect_equal(updated_sample@depth, 40) # Cannot use invalid data types - testthat::expect_error(set_sample(x = oneSample, depth = "33a")) -}) \ No newline at end of file + testthat::expect_error(set_sample(x = one_sample, depth = "33a")) +}) diff --git a/tests/testthat/test_set_server.R b/tests/testthat/test_set_server.R index 556f7f05..2d9ec8a9 100644 --- a/tests/testthat/test_set_server.R +++ b/tests/testthat/test_set_server.R @@ -15,4 +15,4 @@ testthat::test_that("`Switching server with `set_server()`.", { testthat::test_that("Invalid server throws error.", { skip_on_cran() testthat::expect_error(set_server("invalid_server_name")) -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_set_site.R b/tests/testthat/test_set_site.R index cfe5bd7f..b8c423d1 100644 --- a/tests/testthat/test_set_site.R +++ b/tests/testthat/test_set_site.R @@ -4,17 +4,21 @@ library("neotoma2") context("Creating sites from scratch or updating existing site objects.") test_that("`set_sites()` for new site.", { skip_on_cran() - newSite <- set_site(sitename = "My New Site", - geography = sf::st_as_sf( - sf::st_sfc( - sf::st_point(c(-100.0, 40.0)), - crs = 4326)), - altitude = 250) - testthat::expect_is(newSite, "site") - testthat::expect_equal(newSite@sitename, "My New Site") - testthat::expect_equal(newSite@altitude, 250) - testthat::expect_equal(sf::st_coordinates(newSite@geography)[1], -100.0) - testthat::expect_equal(sf::st_coordinates(newSite@geography)[2], 40.0) + new_site <- set_site( + sitename = "My New Site", + geography = sf::st_as_sf( + sf::st_sfc( + sf::st_point(c(-100.0, 40.0)), + crs = 4326 + ) + ), + altitude = 250 + ) + testthat::expect_is(new_site, "site") + testthat::expect_equal(new_site@sitename, "My New Site") + testthat::expect_equal(new_site@altitude, 250) + testthat::expect_equal(sf::st_coordinates(new_site@geography)[1], -100.0) + testthat::expect_equal(sf::st_coordinates(new_site@geography)[2], 40.0) }) test_that("Updating existing site.", { @@ -22,11 +26,11 @@ test_that("Updating existing site.", { # Invalid input: testthat::expect_error(set_site(x = 12, altitude = 33)) # Cannot update over a sites object: - downloadSite <- get_sites(limit = 1) - testthat::expect_error(set_site(x = downloadSite, altitude = 33)) + download_site <- get_sites(limit = 1) + testthat::expect_error(set_site(x = download_site, altitude = 33)) # Update single site - updatedSample <- set_site(x = downloadSite[[1]], altitude = -9999) - testthat::expect_equal(updatedSample@altitude, -9999) + updated_sample <- set_site(x = download_site[[1]], altitude = -9999) + testthat::expect_equal(updated_sample@altitude, -9999) # Cannot use invalid data types - testthat::expect_error(set_site(x = downloadSite[[2]], altitude = "33a")) -}) \ No newline at end of file + testthat::expect_error(set_site(x = download_site[[2]], altitude = "33a")) +}) diff --git a/tests/testthat/test_set_speleothem.R b/tests/testthat/test_set_speleothem.R index baea362c..cf870cbc 100644 --- a/tests/testthat/test_set_speleothem.R +++ b/tests/testthat/test_set_speleothem.R @@ -5,29 +5,35 @@ library("neotoma2") context("Creating speleothems from scratch or updating existing objects.") test_that("`set_speleothem()` for a new publication", { skip_on_cran() - newSpeleo <- set_speleothem(entityid = 56, - entityname = "My Speleothem", - siteid = 54, - collectionunitid = 32) - testthat::expect_is(newSpeleo, "speleothem") - testthat::expect_equal(newSpeleo@entityid, 56) - testthat::expect_equal(newSpeleo@entityname, "My Speleothem") - testthat::expect_equal(newSpeleo@siteid, 54) - testthat::expect_equal(newSpeleo@collectionunitid, 32) + new_speleo <- set_speleothem( + entityid = 56, + entityname = "My Speleothem", + siteid = 54, + collectionunitid = 32 + ) + testthat::expect_is(new_speleo, "speleothem") + testthat::expect_equal(new_speleo@entityid, 56) + testthat::expect_equal(new_speleo@entityname, "My Speleothem") + testthat::expect_equal(new_speleo@siteid, 54) + testthat::expect_equal(new_speleo@collectionunitid, 32) }) test_that("Updating existing publication", { skip_on_cran() - newSpeleo <- set_speleothem(entityid = 56, - entityname = "My Speleothem", - siteid = 54, - collectionunitid = 32) + new_speleo <- set_speleothem( + entityid = 56, + entityname = "My Speleothem", + siteid = 54, + collectionunitid = 32 + ) site <- get_sites(3) siteid <- site[[1]]@siteid - site[[1]]@collunits[[1]]@speleothems <- new("speleothems", speleothems = list(newSpeleo)) - + site[[1]]@collunits[[1]]@speleothems <- new("speleothems", + speleothems = list(new_speleo)) + testthat::expect_error(set_speleothems(x = site, siteid = siteid)) - testthat::expect_is(newSpeleo, "speleothem") - updatedSpeleo <- set_speleothem(x = site[[1]]@collunits[[1]]@speleothems[[1]], siteid = siteid) - testthat::expect_equal(updatedSpeleo@siteid, site[[1]]@siteid) -}) \ No newline at end of file + testthat::expect_is(new_speleo, "speleothem") + speleo <- site[[1]]@collunits[[1]]@speleothems[[1]] + updated_speleo <- set_speleothem(x = speleo, siteid = siteid) + testthat::expect_equal(updated_speleo@siteid, site[[1]]@siteid) +}) diff --git a/tests/testthat/test_sites.R b/tests/testthat/test_sites.R index 99886fe9..4f8ed289 100644 --- a/tests/testthat/test_sites.R +++ b/tests/testthat/test_sites.R @@ -5,82 +5,90 @@ library("httptest") context("Run Neotoma `test_sites` only when not on CRAN") httptest::with_mock_api({ -test_that("get_sites runs as expected.", { - skip_on_cran() - alexander_lake <- get_sites(sitename = "Alexander Lake") - testthat::expect_identical(alexander_lake[[1]]@sitename, "Alexander Lake") -}) + test_that("get_sites runs as expected.", { + skip_on_cran() + alexander_lake <- get_sites(sitename = "Alexander Lake") + testthat::expect_identical(alexander_lake[[1]]@sitename, "Alexander Lake") + }) -test_that("get_sites runs as expected.", { - skip_on_cran() - alex <- get_sites(sitename = "Alex%") - for (i in seq_len(length(alex))) { - alex_char <- substring(alex[[i]]@sitename, 1,4) - alex_char <- tolower(alex_char) - testthat::expect_identical(alex_char, "alex") - } -}) + test_that("get_sites runs as expected.", { + skip_on_cran() + alex <- get_sites(sitename = "Alex%") + for (i in seq_len(length(alex))) { + alex_char <- substring(alex[[i]]@sitename, 1, 4) + alex_char <- tolower(alex_char) + testthat::expect_identical(alex_char, "alex") + } + }) -test_that("get_sites runs as expected.", { - skip_on_cran() - site.1001 <- get_sites(1001) - testthat::expect_equal(site.1001[[1]]@siteid, 1001) -}) + test_that("get_sites runs as expected.", { + skip_on_cran() + site_1001 <- get_sites(1001) + testthat::expect_equal(site_1001[[1]]@siteid, 1001) + }) -test_that("get_sites runs as expected.", { - skip_on_cran() - sites.ob <- get_sites(c(1001, 2001, 15, 24)) - sites.vec <- getids(sites.ob) - sites.vec <- unique(sites.vec$siteid) - testthat::expect_setequal(sites.vec, c(1001, 2001, 15, 24)) -}) + test_that("get_sites runs as expected.", { + skip_on_cran() + sites_ob <- get_sites(c(1001, 2001, 15, 24)) + sites_vec <- getids(sites_ob) + sites_vec <- unique(sites_vec$siteid) + testthat::expect_setequal(sites_vec, c(1001, 2001, 15, 24)) + }) -test_that("count() counts sites correctly.", { - skip_on_cran() - sites.ob <- get_sites(c(1001, 2001, 15, 24)) - length_sites = length(sites.ob) - count_sites = count(sites.ob) - number_collunit_names = summary(sites.ob) %>% distinct(collunit_name) %>% dplyr::count() - count_collunits = count(sites.ob, level = "collunits") - count_datasets = count(sites.ob, level = "datasets") - sum_datasets = sum(summary(sites.ob)$n_datasets) - testthat::expect_equal(number_collunit_names$n[[1]], count_collunits) - testthat::expect_equal(sum_datasets, count_datasets) - testthat::expect_equal(length_sites, count_sites) -}) + test_that("count() counts sites correctly.", { + skip_on_cran() + sites_ob <- get_sites(c(1001, 2001, 15, 24)) + length_sites <- length(sites_ob) + count_sites <- count(sites_ob) + number_collunit_names <- summary(sites_ob) %>% + distinct(collunit_name) %>% + dplyr::count() + count_collunits <- count(sites_ob, level = "collunits") + count_datasets <- count(sites_ob, level = "datasets") + sum_datasets <- sum(summary(sites_ob)$n_datasets) + testthat::expect_equal(number_collunit_names$n[[1]], count_collunits) + testthat::expect_equal(sum_datasets, count_datasets) + testthat::expect_equal(length_sites, count_sites) + }) -# test_that("All Czech sites work with different spatial bounds:", { -# skip_on_cran() -# cz_json <- '{"type": "Polygon", -# "coordinates": [[ -# [12.40, 50.14], -# [14.10, 48.64], -# [16.95, 48.66], -# [18.91, 49.61], -# [15.24, 50.99], -# [12.40, 50.14]]]}' -# cz_WKT <- 'POLYGON ((12.4 50.14, -# 14.1 48.64, -# 16.95 48.66, -# 18.91 49.61, -# 15.24 50.99, -# 12.4 50.14))' -# cz_bbox <- c(12.4, 48.64, 18.91, 50.99) -# -# testthat::expect_true(all.equal(get_sites(loc=cz_json), -# get_sites(loc=cz_WKT))) -# -# # Now, we know that all sites in cz_sites[[1]] should be in cz_sites[[3]], -# # but the bounding box strategy means that the reverse is not true: -# cz_ids <- getids(get_sites(loc=cz_json[1])) -# testthat::expect_true(all(cz_ids$siteid %in% -# getids(get_sites(loc = cz_bbox, limit = 50))$siteid)) -# }) + # test_that("All Czech sites work with different spatial bounds:", { + # nolint start + # skip_on_cran() + # nolint end + # cz_json <- '{"type": "Polygon", + # "coordinates": [[ + # [12.40, 50.14], + # [14.10, 48.64], + # [16.95, 48.66], + # [18.91, 49.61], + # [15.24, 50.99], + # [12.40, 50.14]]]}' + # cz_WKT <- 'POLYGON ((12.4 50.14, + # 14.1 48.64, + # 16.95 48.66, + # 18.91 49.61, + # 15.24 50.99, + # 12.4 50.14))' + # nolint start + # cz_bbox <- c(12.4, 48.64, 18.91, 50.99) + # nolint end + # + # testthat::expect_true(all.equal(get_sites(loc=cz_json), + # get_sites(loc=cz_WKT))) + # + # nolint start + # # Now, we know that all sites in cz_sites[[1]] should be in cz_sites[[3]], + # # but the bounding box strategy means that the reverse is not true: + # cz_ids <- getids(get_sites(loc=cz_json[1])) + # nolint end + # testthat::expect_true(all(cz_ids$siteid %in% + # getids(get_sites(loc = cz_bbox, limit = 50))$siteid)) + # }) -test_that("All Data + loc work", { - skip_on_cran() - on.exit(Sys.sleep(10), add = TRUE) - europe_json <- '{"type": "Polygon", + test_that("All Data + loc work", { + skip_on_cran() + on.exit(Sys.sleep(10), add = TRUE) + europe_json <- '{"type": "Polygon", "coordinates": [ [[-23.5546875, 70.8446726342528], [-25.3125, 39.36827914916014], @@ -88,12 +96,13 @@ test_that("All Data + loc work", { [62.57812500000001, 74.01954331150228], [-23.5546875, 70.8446726342528]] ]}' - # This only needs to prove that a large region returns many sites; a single - # page (`limit = 100`) satisfies `> 50` without paginating the whole continent. - data <- get_sites(loc = europe_json[1], limit = 100) - testthat::expect_gt(length(data), 50) + # This only needs to prove that a large region returns many sites; a single + # page (`limit = 100`) satisfies `> 50` without paginating the whole + # continent. + data <- get_sites(loc = europe_json[1], limit = 100) + testthat::expect_gt(length(data), 50) - # Now, we know that all sites in cz_sites[[1]] should be in cz_sites[[3]], - # but the bounding box strategy means that the reverse is not true: -}) + # Now, we know that all sites in cz_sites[[1]] should be in cz_sites[[3]], + # but the bounding box strategy means that the reverse is not true: + }) }) diff --git a/tests/testthat/test_specimens.R b/tests/testthat/test_specimens.R index 6a00ec6f..f505d730 100644 --- a/tests/testthat/test_specimens.R +++ b/tests/testthat/test_specimens.R @@ -18,10 +18,12 @@ test_that("Manual loading fails if interactive is false.", { test_that("Building a specimen works.", { skip_on_cran() - dataset <- data.frame(datasetid = 12, + dataset <- data.frame( + datasetid = 12, repo = c("Manhattan", "Banana"), - taxonid = seq(1, 12)) + taxonid = seq(1, 12) + ) # Build error when we pass multiple rows. new_spec <- testthat::expect_error(build_specimen(dataset)) new_spec <- testthat::expect_is(build_specimen(dataset[1, ]), "specimen") -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_speleothems.R b/tests/testthat/test_speleothems.R index 6bf6e6e8..62cb1323 100644 --- a/tests/testthat/test_speleothems.R +++ b/tests/testthat/test_speleothems.R @@ -5,7 +5,7 @@ library("neotoma2") context("Run Neotoma `test_speleothems` only when not on CRAN") test_that("speleothems method extracts data correctly", { skip_on_cran() - spel_data<- get_datasets(datasettype='speleothem', limit=2) + spel_data <- get_datasets(datasettype = "speleothem", limit = 2) spel_data <- get_speleothems(spel_data) if (!is.null(spel_data) && length(spel_data) > 0) { spel_extracted <- speleothems(spel_data) @@ -16,7 +16,7 @@ test_that("speleothems method extracts data correctly", { test_that("no duplicate rows in speleothems data frame", { skip_on_cran() - spel_data<- get_datasets(datasettype='speleothem', limit=10) + spel_data <- get_datasets(datasettype = "speleothem", limit = 10) spel_data <- speleothems(get_speleothems(spel_data)) testthat::expect_equal(nrow(spel_data), nrow(unique(spel_data))) }) @@ -24,7 +24,7 @@ test_that("no duplicate rows in speleothems data frame", { # Tests for speleothemdetails() function test_that("speleothemdetails method works on sites object", { skip_on_cran() - spel_data<- get_datasets(datasettype='speleothem', limit=10) + spel_data <- get_datasets(datasettype = "speleothem", limit = 10) spel_sites <- get_speleothems(spel_data) if (!is.null(spel_sites) && length(spel_sites) > 0) { testthat::expect_warning( @@ -92,14 +92,15 @@ test_that("speleothemdetails method works on collunits object", { testthat::expect_true(length(unique(result$datasetid)) == 1) } } -}) +}) test_that("speleothemdetails joins speleothems and samples for collunit", { skip_on_cran() - spel_site <- get_datasets(datasettype="speleothem", limit=1) %>% + spel_site <- get_datasets(datasettype = "speleothem", limit = 1) %>% get_speleothems() - if (!is.null(spel_site) && length(spel_site) > 0 && - length(spel_site[[1]]@collunits@collunits) > 0) { + has_collunits <- !is.null(spel_site) && length(spel_site) > 0 && + length(spel_site[[1]]@collunits@collunits) > 0 + if (has_collunits) { collunit_obj <- spel_site[[1]]@collunits@collunits[[1]] testthat::expect_warning( result <- speleothemdetails(collunit_obj) @@ -112,4 +113,4 @@ test_that("speleothemdetails joins speleothems and samples for collunit", { testthat::expect_true(has_sample_cols) } } -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_summary.R b/tests/testthat/test_summary.R index 2fef65b8..ee77a2fd 100644 --- a/tests/testthat/test_summary.R +++ b/tests/testthat/test_summary.R @@ -3,21 +3,21 @@ library("neotoma2") library("httptest") httptest::with_mock_api({ -test_that("`datasets()`", { - skip_on_cran() - # Bounded to a few known sites so the recorded fixture stays small; the - # assertions below only need a handful of sites/collunits/datasets to hold. - dls <- get_sites(c(24, 1001, 2001)) %>% - get_downloads() - sumDl <- summary(dls) - ids <- getids(dls) - dss <- datasets(dls) - cus <- collunits(dls) - testthat::expect_identical(sum(sumDl$n_datasets), nrow(ids)) - testthat::expect_identical(length(unique(sumDl$siteid)), length(dls)) - testthat::expect_true(all(sumDl$collunit_name %in% cus$handle)) - testthat::expect_true(all(cus$handle %in% sumDl$collunit_name)) -}) + test_that("`datasets()`", { + skip_on_cran() + # Bounded to a few known sites so the recorded fixture stays small; the + # assertions below only need a handful of sites/collunits/datasets to hold. + dls <- get_sites(c(24, 1001, 2001)) %>% + get_downloads() + sum_dl <- summary(dls) + ids <- getids(dls) + dss <- datasets(dls) + cus <- collunits(dls) + testthat::expect_identical(sum(sum_dl$n_datasets), nrow(ids)) + testthat::expect_identical(length(unique(sum_dl$siteid)), length(dls)) + testthat::expect_true(all(sum_dl$collunit_name %in% cus$handle)) + testthat::expect_true(all(cus$handle %in% sum_dl$collunit_name)) + }) }) ## A site does not have to carry datasets. `get_sites()` returns collection @@ -30,7 +30,8 @@ test_that("summary() reports one row per site when there are no datasets", { with_cu <- set_site(siteid = 2, sitename = "Collection unit, no datasets") with_cu@collunits <- methods::new("collunits", - collunits = list(set_collunit(handle = "CU1"))) + collunits = list(set_collunit(handle = "CU1")) + ) for (s in list(bare, with_cu)) { result <- summary(methods::new("sites", sites = list(s))) diff --git a/tests/testthat/test_taxa.R b/tests/testthat/test_taxa.R index ba3b979b..718c6436 100644 --- a/tests/testthat/test_taxa.R +++ b/tests/testthat/test_taxa.R @@ -11,4 +11,4 @@ test_that("taxa() returns only unique results", { df <- taxa(mydataset) testthat::expect_false(any(duplicated(df))) testthat::expect_is(df, "data.frame") -}) \ No newline at end of file +}) diff --git a/tests/testthat/test_toWide.R b/tests/testthat/test_toWide.R index 3c708168..39893a1e 100644 --- a/tests/testthat/test_toWide.R +++ b/tests/testthat/test_toWide.R @@ -5,51 +5,56 @@ library("httptest") context("Apply a similar version to `tidyr::toWide` for `neotoma2` samples dataframes.") httptest::with_mock_api({ -test_that("`toWide()` on a samples dataframe.", { - skip_on_cran() - fauna1 <- samples(get_downloads(4716)) - fauna1t <- toWide(fauna1, - ecologicalgroups = c("AVES", "CARN", "PRIM", "RODE"), - elementtype = c("bone/tooth/shell", "bone/bill", "bone/tooth"), - unit = "present/absent", - operation="presence") - testthat::expect_true(is.data.frame(fauna1t), single_w) - fauna2 <- samples(get_downloads(21007)) - fauna2t <- toWide(fauna2, - ecologicalgroups = c("RODE", "ARTI", "SORI"), - elementtype = c("bone/tooth"), - unit = "present/absent", operation="presence") - testthat::expect_true(is.data.frame(fauna2t), TRUE) -}) + test_that("`toWide()` on a samples dataframe.", { + skip_on_cran() + fauna1 <- samples(get_downloads(4716)) + fauna1t <- toWide(fauna1, + ecologicalgroups = c("AVES", "CARN", "PRIM", "RODE"), + elementtype = c("bone/tooth/shell", "bone/bill", "bone/tooth"), + unit = "present/absent", + operation = "presence" + ) + testthat::expect_true(is.data.frame(fauna1t), single_w) + fauna2 <- samples(get_downloads(21007)) + fauna2t <- toWide(fauna2, + ecologicalgroups = c("RODE", "ARTI", "SORI"), + elementtype = c("bone/tooth"), + unit = "present/absent", operation = "presence" + ) + testthat::expect_true(is.data.frame(fauna2t), TRUE) + }) -test_that("`toWide()` proportions calculation.", { - skip_on_cran() - alex <- samples(get_downloads(24)) - alext <- toWide(alex, - unit = "NISP", - operation = "prop") - nuph4129 <- alex %>% - dplyr::filter(variablename == "Nuphar", age == 4129) - # calculate the proportion manually from alex - total_nisp_4129 <- sum(alex$value[alex$age == 4129 & alex$unit == "NISP"], na.rm = TRUE) - nuphprop_4129 <- sum(nuph4129$value, na.rm = TRUE) / total_nisp_4129 - # extract the proportion from the wide data frame - nuphprop_wide_4129 <- alext$Nuphar[alext$age == 4129] - testthat::expect_equal(nuphprop_4129, nuphprop_wide_4129) -}) + test_that("`toWide()` proportions calculation.", { + skip_on_cran() + alex <- samples(get_downloads(24)) + alext <- toWide(alex, + unit = "NISP", + operation = "prop" + ) + nuph4129 <- alex %>% + dplyr::filter(variablename == "Nuphar", age == 4129) + # calculate the proportion manually from alex + at_4129 <- alex$age == 4129 & alex$unit == "NISP" + total_nisp_4129 <- sum(alex$value[at_4129], na.rm = TRUE) + nuphprop_4129 <- sum(nuph4129$value, na.rm = TRUE) / total_nisp_4129 + # extract the proportion from the wide data frame + nuphprop_wide_4129 <- alext$Nuphar[alext$age == 4129] + testthat::expect_equal(nuphprop_4129, nuphprop_wide_4129) + }) -test_that("`toWide()` sum operation works", { - skip_on_cran() - alex <- samples(get_downloads(24)) - alext <- toWide(alex, - unit = "NISP", - operation = "sum") - nuph4129 <- alex %>% - dplyr::filter(variablename == "Nuphar", age == 4129) - # calculate the sum manually from alex - nuph_sum_4129 <- sum(nuph4129$value, na.rm = TRUE) - # extract the sum from the wide data frame - nuph_sum_wide_4129 <- alext$Nuphar[alext$age == 4129] - testthat::expect_equal(nuph_sum_4129, nuph_sum_wide_4129) + test_that("`toWide()` sum operation works", { + skip_on_cran() + alex <- samples(get_downloads(24)) + alext <- toWide(alex, + unit = "NISP", + operation = "sum" + ) + nuph4129 <- alex %>% + dplyr::filter(variablename == "Nuphar", age == 4129) + # calculate the sum manually from alex + nuph_sum_4129 <- sum(nuph4129$value, na.rm = TRUE) + # extract the sum from the wide data frame + nuph_sum_wide_4129 <- alext$Nuphar[alext$age == 4129] + testthat::expect_equal(nuph_sum_4129, nuph_sum_wide_4129) + }) }) -}) \ No newline at end of file diff --git a/vignettes/neotoma2-package.Rmd b/vignettes/neotoma2-package.Rmd index c8f06686..c4430d6a 100644 --- a/vignettes/neotoma2-package.Rmd +++ b/vignettes/neotoma2-package.Rmd @@ -21,8 +21,10 @@ library(neotoma2) > Users can run all examples locally after installation. ```{r setOpts, include = FALSE} -knitr::opts_chunk$set(eval = FALSE, - error = TRUE) +knitr::opts_chunk$set( + eval = FALSE, + error = TRUE +) ``` ```{r setup_md, include=FALSE} @@ -111,7 +113,7 @@ alex Neotoma uses a Postgres Database to manage data. Postgres uses the `%` sign as a general wildcard, so we can use the `%` in the `sitename` argument operator to help us find sites when we're not sure the exact match. Note that the search is case **insensitive** so a search for `alex%` or `Alex%` will return the same results. ```{r sitewithwildcardname} -alex <- get_sites(sitename = 'Alex%') +alex <- get_sites(sitename = "Alex%") alex ``` @@ -128,8 +130,10 @@ We offer several methods of searching because different users have different req We can see how these age bounds differ: ```{r agebounds} -# Note, we are using the `all_data = TRUE` flag here to avoid the default limit of 25 records, discussed below. -# Because these queries are searching through every record they are slow and and are not +# Note, we are using the `all_data = TRUE` flag here to avoid the default limit +# of 25 records, discussed below. +# Because these queries are searching through every record they are slow and and +# are not # run in knitting this vignette. get_sites(ageof = 8200, all_data = TRUE) %>% length() get_sites(ageyounger = 5000, ageolder = 8000, all_data = TRUE) %>% length() @@ -162,7 +166,8 @@ alex[[1]]$area # Modify a value using [<- assignment: alex[[1]]["area"] <- 30 alex[[1]]$area -# alex[[1]][7] <- 30 This fails because the `Notes` field expects a character string. +# alex[[1]][7] <- 30 This fails because the `Notes` field expects a character +# string. ``` Using assignment, we can add information programmatically, for example, by working interactively with a digital elevation model or hydrographic data to obtain lake area measurements. Although not currently implemented, the goal is to support direct upload of updated information by users. @@ -172,10 +177,12 @@ Using assignment, we can add information programmatically, for example, by worki As explained above, a `site` is the fundamental unit of the Neotoma Database. If you are working with your own data, you might want to create a `site` object to allow it to interact with other data within Neotoma. You can create a site with the `set_site()` function. It will ask you to provide important information such as `sitename`, `lat`, and `long` attributes. ```{r setsitefunction} -my_site <- set_site(sitename = "My Lake", - geography = st_sf(a = 3, st_sfc(st_point(1:2))), - description = "my lake", - altitude = 30) +my_site <- set_site( + sitename = "My Lake", + geography = st_sf(a = 3, st_sfc(st_point(1:2))), + description = "my lake", + altitude = 30 +) my_site ``` @@ -232,12 +239,13 @@ It can be computationally intensive to obtain the full set of records for `sites We can use that `all_data = TRUE` in R in the following way: ```{r all_data} -allSites_dt <- get_sites(datasettype = "diatom") -allSites_dt_all <- get_sites(datasettype = "diatom", all_data = TRUE) +all_sites_dt <- get_sites(datasettype = "diatom") +all_sites_dt_all <- get_sites(datasettype = "diatom", all_data = TRUE) # Because we used the `all_data = TRUE` flag, there will be more sites -# in allSites_dt_all, because it represents all sites containing diatom datasets. -length(allSites_dt_all) > length(allSites_dt) +# in all_sites_dt_all, because it represents all sites containing diatom +# datasets. +length(all_sites_dt_all) > length(all_sites_dt) ``` ### Spatial Searches @@ -247,7 +255,7 @@ You can get the coordinates to create a GeoJson bounding box from [here](https:/ Accessing datasets by bounding box: ```{r boundingBox} -brazil <- '{"type": "Polygon", +brazil <- '{"type": "Polygon", "coordinates": [[ [-73.125, -9.102], [-56.953, -33.138], @@ -277,12 +285,13 @@ plotLeaflet(brazil_datasets) Sometimes we take a large number of records, do some analysis, and then choose to select a subset. For example, we may want to select all sites in a region, and then subset those by dataset type. If we want to look at only the geochronological datasets from Brazil, we can start with the set of records returned from our `get_datasets()` query, and then use the `filter` function in `neotoma2` to select only those datasets that are geochronologic: ```{r filterBrazil} - -brazil_dates <- neotoma2::filter(brazil_datasets, - datasettype == "geochronologic") +brazil_dates <- neotoma2::filter( + brazil_datasets, + datasettype == "geochronologic" +) # or: brazil_dates <- brazil_datasets %>% - neotoma2::filter(datasettype == "geochronologic") + neotoma2::filter(datasettype == "geochronologic") # With boolean operators: brazil_space <- brazil_datasets %>% neotoma2::filter(lat > -18 & lat < -16) @@ -306,7 +315,7 @@ Once we have the set of records we wish to examine, we then want to recover the Assuming we continue with our example from Brazil, we want to extract records from the country, filter to only pollen records with samples covering the last 10,000 years, and then look at the relative frequency of taxa across sites. We might do something like this: ```{r filterAndShowTaxa} -brazil <- '{"type": "Polygon", +brazil <- '{"type": "Polygon", "coordinates": [[ [-73.125, -9.102], [-56.953, -33.138], @@ -319,9 +328,11 @@ brazil <- '{"type": "Polygon", # functionality of the `sf` package. brazil_sf <- geojsonsf::geojson_sf(brazil) -brazil_records <- get_datasets(loc = brazil_sf, all_data=TRUE) %>% - neotoma2::filter(datasettype == "pollen" & age_range_young <= 1000 & age_range_old >= 10000) %>% - get_downloads() +brazil_records <- get_datasets(loc = brazil_sf, all_data = TRUE) %>% + neotoma2::filter( + datasettype == "pollen" & age_range_young <= 1000 & age_range_old >= 10000 + ) %>% + get_downloads() count_by_site <- samples(brazil_records) %>% @@ -331,7 +342,6 @@ count_by_site <- samples(brazil_records) %>% group_by(variablename) %>% summarise(n = n()) %>% arrange(desc(n)) - ``` In this code chunk we define the bounding polygon for our sites, filter by time and dataset type, and then return the full records for those sites. We get a `sites` object with dataset and sample information (because we used `get_downloads()`). We execute the `samples()` function to extract all the samples from the `sites` objects, and then filter the resulting `data.frame` to pull only pollen (a pollen dataset may contain spores and other elements that are not, strictly speaking, pollen) that are counted using the number of identified specimens (or NISP). We then `group_by()` the unique site identifiers (`siteid`) and the taxa (`variablename`) to get a count of the number of times each taxon appears in each site. We then want to `summarize()` to a higher level, just trying to understand how many sites each taxon appears in. After that we `arrange()` so that the records show the most common taxa first in the resulting variable `count_by_site`. @@ -376,10 +386,10 @@ We can also use search elements to search for publications. The `get_publicatio * `offset` ```{r fulltestPubSearch} -michPubs <- get_publications(search = "Michigan", limit = 2) +mich_pubs <- get_publications(search = "Michigan", limit = 2) ``` -This results in a set of `r tryCatch(length(michPubs), error = function(e) "N/A")` publications from Neotoma, equal to the `limit`. If the number of matching publications is less than the limit then the `length()` will be smaller. +This results in a set of `r tryCatch(length(mich_pubs), error = function(e) "N/A")` publications from Neotoma, equal to the `limit`. If the number of matching publications is less than the limit then the `length()` will be smaller. Text matching in Neotoma is approximate, meaning it is a measure of the overall similarity between the search string and the set of article titles. This means that using a nonsense string may still return results results: @@ -401,10 +411,10 @@ We can select an array of `publication` objects using the `[[` method, either as ```{r subsetPubs} # Select publications with Neotoma Publication IDs 1 - 10. -pubArray <- get_publications(1:10) +pub_array <- get_publications(1:10) # Select the first five publications: -subPub <- pubArray[[1:5]] -subPub +sub_pub <- pub_array[[1:5]] +sub_pub ``` #### Create (or Import) New Publications @@ -413,9 +423,11 @@ Just as we can use the `set_sites()` function to set new site information, we ca ```{r setNewPub} new_pub <- set_publication( -articletitle = "Myrtle Lake: a late- and post-glacial pollen diagram from northern Minnesota", -journal = "Canadian Journal of Botany", -volume = 46) + articletitle = paste("Myrtle Lake: a late- and post-glacial pollen diagram", + "from northern Minnesota"), + journal = "Canadian Journal of Botany", + volume = 46 +) ``` A `publication` has a large number of slots that can be defined. These may be left blank, they may be set directly after the publication is defined: