diff --git a/.Rbuildignore b/.Rbuildignore index a2134bb..3054053 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 0000000..93e892a --- /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/NAMESPACE b/NAMESPACE index 0c1bfd6..6ae993f 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 891a7de..e6029f4 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/01_classDefinitions.R b/R/01_classDefinitions.R index 9b34421..36e2aca 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 3858977..83eac68 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 5bd9cd9..6de06f5 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 0e0a349..7df9f6b 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 97e6b0c..54403df 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 0f2f09a..44342c9 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 2b14113..1859bbf 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 8bd745c..55df90f 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 f58f77c..953cd7c 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 a960571..beb5e6c 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 e574210..25a6c67 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 4e0b41c..a0f0bab 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 0742dfd..cbd01da 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 282a844..0151376 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 7d3fd19..31ed228 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 991b3fd..37c0c31 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 8d97a9f..95d06d5 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 6c93b9a..b76d2ed 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 d42e1f1..d0c3ecc 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 3f67002..028dcfe 100644 --- a/R/get_datasets.R +++ b/R/get_datasets.R @@ -29,15 +29,20 @@ #' 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 #' 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). @@ -58,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": [[ @@ -81,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 @@ -104,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 @@ -114,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 } } @@ -128,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( @@ -147,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 } } @@ -158,65 +174,54 @@ 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) + output } #' @rdname get_datasets #' @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))), - !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 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) + 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 9828d35..8ff8859 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 46b3202..1e4861b 100644 --- a/R/get_downloads.R +++ b/R/get_downloads.R @@ -15,8 +15,16 @@ #' 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 +#' 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), @@ -50,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": [[ @@ -63,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 @@ -76,29 +90,86 @@ 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) { + 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( - parseURL(baseURL), - error = function(e2) { - stop("API call failed: ", e2$message) - } + do.call(parseURL, c(list(base_url), 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) + output } else { - return(NULL) + NULL } } @@ -106,13 +177,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) } @@ -121,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 95bdb4a..9089f94 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 0ce26a9..dc9e325 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 0eb7ed4..8917e57 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 3575445..9f0fc71 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 @@ -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 @@ -30,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. @@ -47,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 @@ -64,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": [[ @@ -93,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 @@ -103,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 } } @@ -128,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 } } @@ -156,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 8aa5819..9400dda 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 d4f4181..a621b1c 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 3c747c1..f98dcf9 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 ca54655..d8bcec4 100644 --- a/R/get_table.R +++ b/R/get_table.R @@ -5,15 +5,24 @@ #' 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. -#' someSpec <- get_table('specimens') +#' someSpec <- get_table("specimens") #' } #' @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/R/get_taxa.R b/R/get_taxa.R index e5f4349..8012d2f 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,81 @@ 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 3ab83d9..05fc047 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), "int"), - 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 @@ -65,7 +66,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 @@ -75,25 +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( - parseURL(baseURL, ...), + 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 } } } @@ -102,23 +108,36 @@ 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) } - baseURL <- paste0("data/taxa/", taxa_id) + 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. + base_url <- paste0("data/taxa/", taxa_id) result <- tryCatch( - parseURL(baseURL, ...), + parseURL(base_url, ...), error = function(e) { stop("API call failed: ", e$message) NULL } ) - result_length <- length(result[2]$data) + 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: ", taxa_id) - return(NULL) + message( + "No taxon data found for taxon ID: ", + substr(taxa_id, 1, 60), if (nchar(taxa_id) > 60) "..." + ) + NULL } -} \ No newline at end of file +} diff --git a/R/getids.r b/R/getids.r index 05a3327..a99c42c 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 d1ec7f3..763e65c 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 8e9b7c5..811627a 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 51c97d5..efc0a61 100644 --- a/R/parseURL.R +++ b/R/parseURL.R @@ -13,10 +13,68 @@ neotoma_baseurl <- function(use = "neotoma") { use <- apipoint } switch(use, - "dev" = "http://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 +#' @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", "")) + 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, ")") + } } #' @title neotoma_headers @@ -28,10 +86,12 @@ neotoma_baseurl <- function(use = "neotoma") { #' @noRd neotoma_headers <- function(json = FALSE) { if (json) { - add_headers("User-Agent" = "neotoma2 R package", - "Content-Type" = "application/json") + 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 +143,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 +159,98 @@ 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 +267,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 +286,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,26 +317,29 @@ 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)) { + error = function(e) e + ) + 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)) { - 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) @@ -228,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" + ) } } ) @@ -243,8 +378,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 +390,234 @@ 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_retry("POST", url, + body = body, encode = "raw", + 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. @@ -353,35 +625,27 @@ neotoma_post_ids <- function(baseurl, x, query, chunk = 50) { #' @noRd 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)) - } + path = file.path("v2.0", x), + query = query[setdiff(names(query), "loc")] + ) - 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)) + collapse = "/" + )) + 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 @@ -420,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) @@ -437,6 +703,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 +744,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/R/parse_speleothem.R b/R/parse_speleothem.R index cf98faf..c62b281 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 9cada98..c9341c0 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 2b180a7..7721807 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 81dbee0..9629ee8 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 9f03751..2a6fea8 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 7b1145c..19c21d2 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 b118c0a..6d87ae0 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 f095506..6103dcc 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 acd4a25..a06d5a5 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 1ae8ed9..c3a0ebd 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 cb017c0..a79efcb 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 c2ed7ec..012f545 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 6264f1d..e4089cb 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 ff0e2a1..3e3c2cf 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 08c0223..d990243 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 8aa918a..c6a186b 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 316b68f..54c8de2 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 8ff7a5e..32d3017 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 24027c7..d1e4764 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 84f35af..a732261 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 b90bf4d..2787f46 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 12d803f..5ac73d4 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 8134e11..6e31e85 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 57771c8..78ddc1c 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 6c35d3d..6298f62 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 ab887c4..1193110 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 e401623..cf53ec4 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 56a9045..e141440 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 c74756a..dfd608a 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 084d8bc..c2ebbfe 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 3d925b9..5b23c4e 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 ccf0698..be18ee8 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 a823f46..f28ce94 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{ @@ -89,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": [[ @@ -109,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 f36e1e9..476942b 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 7e750bc..b7597d9 100644 --- a/man/get_downloads.Rd +++ b/man/get_downloads.Rd @@ -69,15 +69,26 @@ 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{ # 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": [[ @@ -86,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 e021385..548ed6a 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 efa11cd..58c4e77 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 34d375c..5dc2ffd 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{ @@ -90,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 f9702f4..40dffa1 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 ba80d05..4c32f43 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 66a341a..378ecc8 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. @@ -24,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/get_taxa.Rd b/man/get_taxa.Rd index 33177ce..64c0ffe 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{ diff --git a/man/plotLeaflet-sites-method.Rd b/man/plotLeaflet-sites-method.Rd index 4be5e23..9e778fc 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 63562a5..b415e6e 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 20fe608..a2e0d8a 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 cc80936..24a8ee9 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 07746cb..8c347d6 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 97653d4..d10bf0f 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 7683bf2..af1c9fe 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 92dcc29..97cdfbe 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 ae6457d..a2c1541 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 6d05d9c..c174109 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 1f8d296..07ba07e 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 d43f2d7..7f01e17 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 f06c1bb..608c1ca 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 f74a08a..a340ed1 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 5c3ee59..3d5a62a 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 215f583..cf16264 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 01d18a7..789b245 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 abef5dd..1ddd4a8 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 5bf8194..c2c2157 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 8fc0d16..ea6f9df 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 4802a02..16d094b 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 23a2c1c..76377ee 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 e4e2322..9867987 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 b110141..fb10277 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 cb57548..5f54e16 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 6f28151..9462661 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,19 +65,23 @@ 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', - 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))), - 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) + 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 +91,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 +99,113 @@ 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_manual.R b/tests/testthat/test_get_manual.R index 26188fc..d6f8384 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 e879d05..6ece5aa 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 059d016..989f167 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 b42164d..d35cbff 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 da3b938..0bbc5c0 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 5cad27c..f7a77f3 100644 --- a/tests/testthat/test_get_table.R +++ b/tests/testthat/test_get_table.R @@ -16,19 +16,88 @@ 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) -}) \ 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_get_taxa.R b/tests/testthat/test_get_taxa.R index 0ba0c59..b3f62d8 100644 --- a/tests/testthat/test_get_taxa.R +++ b/tests/testthat/test_get_taxa.R @@ -11,10 +11,185 @@ 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') + 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))) -}) \ 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 451ff73..1c46a46 100644 --- a/tests/testthat/test_get_taxon.R +++ b/tests/testthat/test_get_taxon.R @@ -6,9 +6,123 @@ 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) +}) diff --git a/tests/testthat/test_getids.R b/tests/testthat/test_getids.R index b30c76f..d855a9f 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 048957a..2527ef0 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 24d6813..b0b69a8 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 3c2e58a..7c45574 100644 --- a/tests/testthat/test_parseURL.R +++ b/tests/testthat/test_parseURL.R @@ -4,26 +4,27 @@ 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"), - "http://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) }) -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") @@ -33,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) { - structure(list(url = "https://api.neotomadb.org/v2.0/data/sites", - status_code = as.integer(status), - headers = list(), - all_headers = list(), - content = raw(0), - request = list(), - date = Sys.time(), - times = numeric(0)), - class = "response") +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" + ) } ## A stub for neotoma_fetch() that serves `total` records `limit` at a time and @@ -58,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" + ) } } @@ -69,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) @@ -81,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)) @@ -95,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)) @@ -107,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) @@ -122,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) }) @@ -143,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) @@ -171,22 +202,104 @@ 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("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(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, 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(502) + fake_response(500) + }, neotoma_wait = function(response, attempt) { + stop("must not wait for a 500") }, .package = "neotoma2") - response <- neotoma2:::neotoma_retry("GET", api_url, times = 3) + response <- neotoma2:::neotoma_retry("POST", api_url, times = 4) - expect_equal(attempts, 3) - expect_equal(response$status_code, 502) + 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", { @@ -240,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") @@ -250,6 +365,353 @@ 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))) +}) + + +## 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") }) diff --git a/tests/testthat/test_parse_location.R b/tests/testthat/test_parse_location.R index 280293a..328e828 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 4aecaf9..36d8d35 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 3336752..f122f73 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 ce4481e..3f7e1c1 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 410f6a3..98681ff 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 b622ac7..e0f57d0 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 6d66f27..746fe8a 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 3714a2e..bb96ddd 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 4eae5a6..76d126a 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 ff71831..6d807be 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 32d6b41..657ab29 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 2b265d8..d79dfdb 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 cd57d89..805ced9 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 556f7f0..2d9ec8a 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 cfe5bd7..b8c423d 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 baea362..cf870cb 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 99886fe..4f8ed28 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 6a00ec6..f505d73 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 6bf6e6e..62cb132 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 2fef65b..ee77a2f 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 ba3b979..718c643 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 3c70816..39893a1 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 c8f0668..c4430d6 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: