diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 27d45283..f9cb681d 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -4,9 +4,10 @@ on: push: branches: [main, master] pull_request: - branches: [main, master] -name: test-coverage +name: test-coverage.yaml + +permissions: read-all jobs: test-coverage: @@ -15,7 +16,7 @@ jobs: GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} steps: - - uses: actions/checkout@v3 + - uses: actions/checkout@v4 - uses: r-lib/actions/setup-r@v2 with: @@ -23,28 +24,39 @@ jobs: - uses: r-lib/actions/setup-r-dependencies@v2 with: - extra-packages: any::covr + extra-packages: any::covr, any::xml2 needs: coverage - name: Test coverage run: | - covr::codecov( + cov <- covr::package_coverage( quiet = FALSE, clean = FALSE, install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") ) + print(cov) + covr::to_cobertura(cov) shell: Rscript {0} + - uses: codecov/codecov-action@v5 + with: + # Fail if error if not on PR, or if on PR and token is given + fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }} + files: ./cobertura.xml + plugins: noop + disable_search: true + token: ${{ secrets.CODECOV_TOKEN }} + - name: Show testthat output if: always() run: | ## -------------------------------------------------------------------- - find ${{ runner.temp }}/package -name 'testthat.Rout*' -exec cat '{}' \; || true + find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true shell: bash - name: Upload test results if: failure() - uses: actions/upload-artifact@v3 + uses: actions/upload-artifact@v4 with: name: coverage-test-failures - path: ${{ runner.temp }}/package + path: ${{ runner.temp }}/package \ No newline at end of file diff --git a/.gitignore b/.gitignore index 04e7b6ad..fcb38c10 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,5 @@ docs/* /Meta/ docs SECRETS.txt +.secure-credentials +/TEST-SENSITIVE-DATA \ No newline at end of file diff --git a/DESCRIPTION b/DESCRIPTION index 97cda488..b8a98704 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: galah Type: Package Title: Biodiversity Data from the GBIF Node Network -Version: 2.1.2 +Version: 2.2.0 Authors@R: c(person(given = "Martin", family = "Westgate", @@ -11,13 +11,13 @@ Authors@R: family = "Kellie", email = "dax.kellie@csiro.au", role = "aut"), + person(given = "Shandiya", + family = "Balasubramaniam", + email = "shandiya.balasubramaniam@csiro.au", + role = "ctb"), person(given = "Matilda", family = "Stevenson", - role = "aut"), - person(given = "Peggy", - family = "Newman", - email = "peggy.newman@csiro.au", - role = "aut")) + role = "ctb")) Description: The Global Biodiversity Information Facility ('GBIF', ) sources data from an international network of data providers, known as 'nodes'. Several of these nodes - the "living @@ -62,6 +62,7 @@ BugReports: https://github.com/AtlasOfLivingAustralia/galah-R/issues Maintainer: Martin Westgate LazyLoad: yes VignetteBuilder: knitr -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 Encoding: UTF-8 Roxygen: list(markdown = TRUE) +Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index 2fcfc069..a24ad62f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,51 +1,86 @@ # Generated by roxygen2: do not edit by hand +S3method(add_count,data_request) S3method(arrange,data_request) S3method(arrange,metadata_request) +S3method(capture,data_request) +S3method(capture,files_request) +S3method(capture,list) +S3method(capture,metadata_request) S3method(collapse,data_request) S3method(collapse,files_request) S3method(collapse,metadata_request) +S3method(collapse,prequery) +S3method(collapse,query) +S3method(collapse,query_set) S3method(collect,computed_query) S3method(collect,data_request) S3method(collect,files_request) S3method(collect,metadata_request) +S3method(collect,prequery) S3method(collect,query) +S3method(collect,query_set) +S3method(compound,data_request) +S3method(compound,files_request) +S3method(compound,metadata_request) +S3method(compound,prequery) +S3method(compound,query) +S3method(compound,query_set) S3method(compute,data_request) S3method(compute,files_request) S3method(compute,metadata_request) +S3method(compute,prequery) S3method(compute,query) +S3method(compute,query_set) S3method(count,data_request) +S3method(distinct,data_request) S3method(filter,data_request) S3method(filter,files_request) S3method(filter,metadata_request) +S3method(glimpse,data_request) S3method(group_by,data_request) S3method(identify,data_request) S3method(identify,metadata_request) S3method(print,computed_query) +S3method(print,data_filter) S3method(print,data_request) +S3method(print,files_filter) S3method(print,files_request) S3method(print,galah_config) +S3method(print,metadata_filter) S3method(print,metadata_request) +S3method(print,occurrences_glimpse) +S3method(print,predicates_filter) +S3method(print,prequery) S3method(print,query) S3method(print,query_set) S3method(select,data_request) +S3method(select,metadata_request) S3method(slice_head,data_request) S3method(slice_head,metadata_request) S3method(st_crop,data_request) +export(add_count) export(apply_profile) export(arrange) +export(as_data_filter) +export(as_files_filter) +export(as_metadata_filter) +export(as_predicates_filter) export(atlas_citation) export(atlas_counts) export(atlas_media) export(atlas_occurrences) export(atlas_species) export(atlas_taxonomy) +export(authenticate) +export(capture) export(collapse) export(collect) export(collect_media) +export(compound) export(compute) export(count) -export(desc) +export(distinct) export(filter) export(galah_apply_profile) export(galah_bbox) @@ -59,6 +94,7 @@ export(galah_polygon) export(galah_radius) export(galah_select) export(geolocate) +export(glimpse) export(group_by) export(identify) export(read_zip) @@ -75,6 +111,7 @@ export(search_fields) export(search_identifiers) export(search_licences) export(search_lists) +export(search_media) export(search_profiles) export(search_providers) export(search_ranks) @@ -87,6 +124,7 @@ export(show_all_apis) export(show_all_assertions) export(show_all_atlases) export(show_all_collections) +export(show_all_config) export(show_all_datasets) export(show_all_fields) export(show_all_licences) @@ -99,123 +137,22 @@ export(show_values) export(slice_head) export(st_crop) export(unnest) -importFrom(cli,cli_div) -importFrom(cli,cli_end) -importFrom(cli,cli_text) -importFrom(cli,col_magenta) -importFrom(cli,col_yellow) importFrom(crayon,make_style) -importFrom(crayon,silver) -importFrom(dplyr,all_of) -importFrom(dplyr,any_of) +importFrom(dplyr,add_count) importFrom(dplyr,arrange) -importFrom(dplyr,bind_cols) -importFrom(dplyr,bind_rows) -importFrom(dplyr,c_across) -importFrom(dplyr,case_match) importFrom(dplyr,collapse) importFrom(dplyr,collect) importFrom(dplyr,compute) importFrom(dplyr,count) -importFrom(dplyr,desc) +importFrom(dplyr,distinct) importFrom(dplyr,filter) -importFrom(dplyr,full_join) +importFrom(dplyr,glimpse) importFrom(dplyr,group_by) -importFrom(dplyr,join_by) -importFrom(dplyr,last_col) -importFrom(dplyr,mutate) -importFrom(dplyr,pull) -importFrom(dplyr,relocate) -importFrom(dplyr,rename) -importFrom(dplyr,right_join) -importFrom(dplyr,rowwise) importFrom(dplyr,select) -importFrom(dplyr,slice) importFrom(dplyr,slice_head) -importFrom(dplyr,starts_with) -importFrom(dplyr,ungroup) -importFrom(glue,glue) -importFrom(glue,glue_collapse) -importFrom(glue,glue_data) importFrom(graphics,identify) -importFrom(httr2,req_body_raw) -importFrom(httr2,req_error) -importFrom(httr2,req_headers) -importFrom(httr2,req_perform) -importFrom(httr2,req_timeout) -importFrom(httr2,request) -importFrom(httr2,resp_body_json) -importFrom(httr2,resp_body_string) -importFrom(httr2,url_build) -importFrom(httr2,url_parse) -importFrom(jsonlite,fromJSON) -importFrom(jsonlite,toJSON) -importFrom(jsonlite,unbox) importFrom(lifecycle,badge) -importFrom(lifecycle,deprecate_stop) -importFrom(lifecycle,deprecate_warn) -importFrom(potions,brew) -importFrom(potions,pour) -importFrom(purrr,list_flatten) -importFrom(purrr,list_transpose) -importFrom(purrr,map) -importFrom(purrr,pluck) -importFrom(purrr,pluck_depth) -importFrom(purrr,rate_backoff) -importFrom(purrr,rate_delay) -importFrom(purrr,rate_sleep) importFrom(rlang,.data) -importFrom(rlang,abort) -importFrom(rlang,as_label) -importFrom(rlang,as_name) -importFrom(rlang,as_quosure) -importFrom(rlang,as_string) +importFrom(rlang,`:=`) importFrom(rlang,caller_env) -importFrom(rlang,enquo) -importFrom(rlang,enquos) -importFrom(rlang,eval_tidy) -importFrom(rlang,expr_text) -importFrom(rlang,f_lhs) -importFrom(rlang,f_rhs) -importFrom(rlang,format_error_bullets) -importFrom(rlang,get_env) -importFrom(rlang,get_expr) -importFrom(rlang,inform) -importFrom(rlang,is_bare_environment) -importFrom(rlang,is_empty) -importFrom(rlang,is_list) -importFrom(rlang,is_quosure) -importFrom(rlang,is_string) -importFrom(rlang,is_syntactic_literal) -importFrom(rlang,new_quosure) -importFrom(rlang,parse_expr) -importFrom(rlang,quo_get_env) -importFrom(rlang,quo_get_expr) -importFrom(rlang,quo_is_call) -importFrom(rlang,quo_is_symbol) -importFrom(rlang,quo_squash) -importFrom(rlang,try_fetch) -importFrom(rlang,warn) -importFrom(sf,st_as_sf) -importFrom(sf,st_as_sfc) -importFrom(sf,st_as_text) -importFrom(sf,st_bbox) -importFrom(sf,st_cast) -importFrom(sf,st_coordinates) importFrom(sf,st_crop) -importFrom(sf,st_crs) -importFrom(sf,st_geometry) -importFrom(sf,st_geometry_type) -importFrom(sf,st_is_empty) -importFrom(sf,st_is_simple) -importFrom(sf,st_is_valid) -importFrom(stringr,str_detect) -importFrom(stringr,str_extract) -importFrom(stringr,str_remove) -importFrom(stringr,str_replace) -importFrom(stringr,str_replace_all) -importFrom(stringr,str_split) -importFrom(stringr,str_to_title) -importFrom(stringr,str_trim) -importFrom(tibble,as_tibble) -importFrom(tibble,tibble) diff --git a/NEWS.md b/NEWS.md index 1f9ca50b..dba0a332 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,35 @@ +# galah 2.2.0 + +### Improved organisational support +* Flemish living atlas and Kew Gardens Data Portal added (#256, #271). +* Authentication supported for ALA users, with associated vignette (#189). +* All GBIF data queries now use predicates. `filter()` builds predicate queries natively when atlas is set to `GBIF` using an object-oriented workflow (#272). +* Re-downloading a file via its' DOI now supported for `GBIF` (#272). +* `search_identifiers()` and `tibble`-based searching via `search_taxa()` now supported for `GBIF` + +### New functions +* `dplyr::distinct()` can be used to find grouped data and summaries, generalising `atlas_species()` (#284). +* `dplyr::glimpse()` can be used to see what the resulting query will look like. +* New functions `capture()` and `compound()` as prequels to `collapse()` (#278). + +## Changes to metadata functions +* All metadata requests now accept `select()`. +* Metadata types that support `unnest()` now also support `filter()`, even when `unnest()` is not supplied. +* All `show_all()` and `search_all()` functions gain an `all_fields` argument. +* Metadata now supports list-columns where the API returns nested data. +* Metadata functions now return columns names in `snake_case` rather than `camelCase`. +* All metadata functions support caching, and are affected by re-introduced `caching` argument in `galah_config()` (set to `TRUE` by default #282). +* Media metadata now uses a different API to return more relevant information. + +### Minor improvements and bug fixes +* `galah_call()` is now synonmous with `request_data()` rather than wrapping all `request_` functions; `method` argument is removed. +* Move to `testthat` 3rd edition for improved test functionality. +* Move to `{cli}` for `print()` calls, not `cat()`. +* Reduce usage of `@importFrom` in favour of `pkg::fun()` syntax, as per R style guide. +* `basisOfRecord` now included as default field (i.e. with `select(group = "basic")`). (#281) +* `query` objects now have a `request` slot showing the request that generated them . + + # galah 2.1.2 ### Minor improvements diff --git a/R/atlas_citation.R b/R/atlas_citation.R index be45f5aa..26df89a4 100644 --- a/R/atlas_citation.R +++ b/R/atlas_citation.R @@ -17,7 +17,6 @@ #' atlas_citation(x) #' } #' @export - atlas_citation <- function(data) { # get basic information from file modified_date <- attributes(data)$modified_date @@ -34,15 +33,15 @@ atlas_citation <- function(data) { r_citation <- citation() |> print(style = 'text') |> utils::capture.output() |> - glue_collapse(sep = " ") + glue::glue_collapse(sep = " ") galah_citation <- c("Westgate M, Kellie D, Stevenson M & Newman P (2025):", "_galah: Biodiversity Data from the GBIF Node Network_.", - "R package version 2.1.1.", + "R package version 2.2.0.", "doi: 10.32614/CRAN.package.galah") |> - glue_collapse(sep = " ") + glue::glue_collapse(sep = " ") # ask users to cite galah and R - suffix_text <- glue(" + suffix_text <- glue::glue(" Please consider citing R & galah, in addition to your dataset: @@ -54,8 +53,8 @@ atlas_citation <- function(data) { # set case when DOI is missing if(!is.null(doi)) { # ALA - if(grepl("10.26197/ala.", doi)){ - result <- glue(" + if(stringr::str_detect(doi, "10.26197/ala.")){ + result <- glue::glue(" The citation for this dataset is: Atlas of Living Australia ({modified_date}) Occurrence download {doi} @@ -66,8 +65,8 @@ atlas_citation <- function(data) { cli::cli_text(result) invisible(result) # GBIF - }else if(grepl("10.15468/dl.", doi)){ - result <- glue(" + }else if(stringr::str_detect(doi, "10.15468/dl.")){ + result <- glue::glue(" The citation for this dataset is: GBIF.org ({modified_date}) GBIF Occurrence Download {doi} @@ -88,7 +87,7 @@ atlas_citation <- function(data) { } }else{ if(!is.null(citation)){ - result <- glue(" + result <- glue::glue(" The citation for this dataset is: {citation} diff --git a/R/atlas_counts.R b/R/atlas_counts.R index e4f4c424..4521d0f3 100644 --- a/R/atlas_counts.R +++ b/R/atlas_counts.R @@ -7,14 +7,13 @@ #' @param type `string`: one of `"occurrences"` or `"species"`. #' Defaults to `"occurrences"`, which returns the number of records #' that match the selected criteria; alternatively returns the number of -#' species. Formerly accepted arguments (`"records"` or `"species"`) are -#' deprecated but remain functional. +#' species. #' @export atlas_counts <- function(request = NULL, identify = NULL, filter = NULL, geolocate = NULL, - data_profile = NULL, + apply_profile = NULL, group_by = NULL, limit = NULL, type = c("occurrences", "species") @@ -22,11 +21,8 @@ atlas_counts <- function(request = NULL, # capture supplied arguments args <- as.list(environment()) args$type <- match.arg(type) - dr <- check_atlas_inputs(args) # convert to `data_request` object - # check for outdated naming conventions - if(dr$type == "record"){dr$type <- "occurrences"} - # pass to collect etc - dr |> + # convert to `data_request` object, collect + check_atlas_inputs(args) |> count() |> slice_head(n = limit) |> collect() diff --git a/R/atlas_media.R b/R/atlas_media.R index 5bcc39d0..87516696 100644 --- a/R/atlas_media.R +++ b/R/atlas_media.R @@ -1,36 +1,20 @@ #' @rdname atlas_ #' @order 4 -#' @importFrom dplyr any_of -#' @importFrom dplyr relocate -#' @importFrom dplyr right_join -#' @importFrom dplyr join_by -#' @importFrom glue glue -#' @importFrom httr2 url_build -#' @importFrom httr2 url_parse -#' @importFrom potions pour -#' @importFrom purrr pluck -#' @importFrom rlang abort -#' @importFrom stringr str_remove +#' @param all_fields `r lifecycle::badge("experimental")` If `TRUE`, +#' `show_values()` also returns all columns available from the media metadata +#' API, rather than the 'default' columns traditionally provided via galah. #' @export atlas_media <- function(request = NULL, identify = NULL, filter = NULL, select = NULL, geolocate = NULL, - data_profile = NULL + apply_profile = NULL, + all_fields = FALSE ) { - atlas <- pour("atlas", "region", .pkg = "galah") - supported_atlases <- c("Australia", - "Austria", # not currently working - "Brazil", - "Guatemala", - "Sweden", - "Spain", - "United Kingdom") - if(!(atlas %in% supported_atlases)){ - abort(glue("`atlas_media` is not supported for atlas = {atlas}")) - } + # check media is available + media_supported() # capture supplied arguments args <- as.list(environment()) @@ -40,13 +24,13 @@ atlas_media <- function(request = NULL, # ensure a filter is present (somewhat redundant with `collapse`) if(is.null(.query$filter)){ - abort("You must specify a valid `filter()` to use `atlas_media()`") + cli::cli_abort("You must specify a valid `filter()` to use `atlas_media()`") } # ensure media columns are present in `select` if(is.null(.query$select)){ - .query <- update_data_request(.query, - select = galah_select(group = c("basic", "media"))) + .query <- .query |> + dplyr::select(group = c("basic", "media")) present_fields <- image_fields() present_fields <- present_fields[present_fields != "multimedia"] # check these fields for Spain query_collapse <- collapse(.query) @@ -56,10 +40,10 @@ atlas_media <- function(request = NULL, # now check whether valid fields are present selected_fields <- x$url |> - url_parse() |> - pluck("query", "fields") |> + httr2::url_parse() |> + purrr::pluck("query", "fields") |> strsplit(split = ",") |> - pluck(!!!list(1)) + purrr::pluck(!!!list(1)) # `multimedia` should be in `select`, but not `filter` image_select <- image_fields() @@ -67,10 +51,10 @@ atlas_media <- function(request = NULL, # abort if no fields are given to `select` if(!any(selected_fields %in% image_select)){ - selected_text <- paste(selected_fields, collapse = ", ") - bullets <- c("No media fields requested by `select()`", - i = glue("try `galah_select({selected_text}, group = 'media')` instead")) - abort(bullets) + selected_text <- glue::glue_collapse(selected_fields, sep = ", ") + c("No media fields requested by `select()`", + i = "try `galah_select({selected_text}, group = 'media')` instead") |> + cli::cli_abort() }else{ present_fields <- selected_fields[selected_fields %in% image_select] query_collapse <- x @@ -80,63 +64,59 @@ atlas_media <- function(request = NULL, # add media content to filters if(length(present_fields) > 0){ # do region-specific filter parsing - media_fq <- parse_regional_media_filters(present_fields) + media_fq <- image_filters(present_fields) # add back to source object if(length(media_fq) > 1){ - media_fq <- glue("({glue_collapse(media_fq, ' OR ')})") + media_fq <- glue::glue("({glue::glue_collapse(media_fq, ' OR ')})") } - url <- url_parse(query_collapse$url) - url$query$fq <- paste0(url$query$fq, " AND ", media_fq) - query_collapse$url <- url_build(url) + url <- httr2::url_parse(query_collapse$url) + url$query$fq <- glue::glue("{url$query$fq}AND{media_fq}") + query_collapse$url <- httr2::url_build(url) } - # get occurrences + # get occurrences, expand to one row per media entry occ <- query_collapse |> collect(wait = TRUE) |> - tidyr::unnest_longer(col = any_of(present_fields)) - - if(!any(colnames(occ) == "all_image_url")){ - occ$media_id <- build_media_id(occ) - } + build_media_id(media_fields = present_fields) # collect media metadata - media <- request_metadata() |> - filter(media == occ) |> - collect() + media_query <- request_metadata() |> + filter(media == dplyr::pull(occ, "media_id")) + if(isTRUE(all_fields)){ + media_query <- media_query |> + dplyr::select(tidyselect::everything()) + } + media <- collect(media_query) # join and return - if(any(colnames(occ) == "all_image_url")){ - occ <- rename(occ, "media_id" = "all_image_url") - } - occ_media <- right_join(occ, - media, - by = join_by("media_id" == "image_id")) - relocate(occ_media, "media_id", 1) + dplyr::right_join(occ, + media, + by = dplyr::join_by("media_id")) } -#' Set filters that work for media in each atlas -#' @importFrom glue glue -#' @importFrom stringr str_remove +#' Internal function to get media metadata, and create a valid file name #' @noRd #' @keywords Internal -parse_regional_media_filters <- function(present_fields){ - - atlas <- pour("atlas", "region") - switch(atlas, - "Austria" = "(all_image_url:*)", - "Australia" = glue("({present_fields}:*)"), - "Brazil" = "(all_image_url:*)", - "Guatemala" = "(all_image_url:*)", - "Portugal" = "(all_image_url:*)", - "Spain" = {filter_fields <- present_fields |> - str_remove("s$") |> - paste0("IDsCount") - glue("{filter_fields}:[1 TO *]")}, - "Sweden" = {filter_fields <- present_fields |> - str_remove("s$") |> - paste0("IDsCount") - glue("{filter_fields}:[1 TO *]")}, - "United Kingdom" = "(all_image_url:*)", # !is.na(all_image_url), - abort(glue("`atlas_media` is not supported for atlas = {atlas}")) - ) +build_media_id <- function(df, media_fields){ + if(any(colnames(df) == "all_image_url")){ + df |> + dplyr::mutate("media_id" = .data$all_image_url, + "media_type" = "images", + .before = 1) |> + dplyr::select(-"all_image_url") + }else{ + purrr::map(media_fields, .f = \(a){ + df |> + tidyr::unnest_longer(col = tidyselect::any_of(a)) |> + dplyr::mutate(media_id = as.character(.data[[a]]), + media_type = as.character(a), + .before = 1) |> + dplyr::filter(!is.na(.data$media_id)) |> + dplyr::select(- tidyselect::any_of(media_fields)) + # break pipe at this point because tidyselect can't handle -any_of() + # keep_cols <- colnames(result)[!(colnames(result) %in% media_fields)] + # dplyr::select(result, tidyselect::any_of(keep_cols)) + }) |> + dplyr::bind_rows() + } } \ No newline at end of file diff --git a/R/atlas_occurrences.R b/R/atlas_occurrences.R index 7b8738ac..349577ad 100644 --- a/R/atlas_occurrences.R +++ b/R/atlas_occurrences.R @@ -23,7 +23,7 @@ #' @param identify `tibble`: generated by a call to [galah_identify()]. #' @param filter `tibble`: generated by a call to [galah_filter()] #' @param geolocate `string`: generated by a call to [galah_geolocate()] -#' @param data_profile `string`: generated by a call to [galah_apply_profile()] +#' @param apply_profile `string`: generated by a call to [galah_apply_profile()] #' @param select `tibble`: generated by a call to [galah_select()] #' @param mint_doi `logical`: by default no DOI will be generated. Set to #' `TRUE` if you intend to use the data in a publication or similar. @@ -104,7 +104,7 @@ atlas_occurrences <- function(request = NULL, identify = NULL, filter = NULL, geolocate = NULL, - data_profile = NULL, + apply_profile = NULL, select = NULL, mint_doi = FALSE, doi = NULL, @@ -117,7 +117,8 @@ atlas_occurrences <- function(request = NULL, }else{ args <- as.list(environment()) # capture supplied arguments check_atlas_inputs(args) |> # convert to `data_request` object - collect(wait = TRUE, + collect(mint_doi = mint_doi, + wait = TRUE, file = file) } } \ No newline at end of file diff --git a/R/atlas_species.R b/R/atlas_species.R index a73a45d3..178d4e24 100644 --- a/R/atlas_species.R +++ b/R/atlas_species.R @@ -1,12 +1,11 @@ #' @rdname atlas_ #' @order 3 -#' @importFrom potions pour #' @export atlas_species <- function(request = NULL, identify = NULL, filter = NULL, geolocate = NULL, - data_profile = NULL + apply_profile = NULL ) { # capture supplied arguments @@ -18,9 +17,24 @@ atlas_species <- function(request = NULL, }else{ args <- c(list(type = "species"), args) } - + # convert to `data_request` object check_atlas_inputs(args) |> + check_distinct_for_atlas_species() |> collapse() |> collect() +} + +#' Internal micro-function to ensure that grouping is always applied, +#' but can also be overruled by the user +#' @noRd +#' @keywords Internal +check_distinct_for_atlas_species <- function(.query){ + if(is.null(.query$distinct)){ + .query |> + distinct(species_facets(), .keep_all = TRUE) + }else{ + .query$distinct$keep_all <- TRUE + .query + } } \ No newline at end of file diff --git a/R/atlas_taxonomy.R b/R/atlas_taxonomy.R index 02036342..055ed731 100644 --- a/R/atlas_taxonomy.R +++ b/R/atlas_taxonomy.R @@ -5,14 +5,6 @@ #' authoritative sources. Default is `"biodiversity.org.au"` for Australia, #' which is the infix common to National Species List IDs; use #' `NULL` to suppress source filtering. Regular expressions are supported. -#' @importFrom dplyr bind_rows -#' @importFrom dplyr filter -#' @importFrom dplyr mutate -#' @importFrom dplyr select -#' @importFrom potions pour -#' @importFrom purrr list_flatten -#' @importFrom purrr pluck_depth -#' @importFrom stringr str_to_title #' @keywords internal #' @export atlas_taxonomy <- function(request = NULL, @@ -36,51 +28,47 @@ atlas_taxonomy <- function(request = NULL, identify(.query$identify$search_term) |> collect() start_row <- taxa_info |> - mutate(name = str_to_title(taxa_info$scientific_name), - parent_taxon_concept_id = NA) |> - select("name", - "rank", - "taxon_concept_id", - "parent_taxon_concept_id") + dplyr::mutate(name = stringr::str_to_title(taxa_info$scientific_name), + parent_taxon_concept_id = NA) |> + dplyr::select("name", + "rank", + "taxon_concept_id", + "parent_taxon_concept_id") # build then flatten a tree taxonomy_tree <- drill_down_taxonomy(start_row, down_to = .query$filter$value, constrain_ids = constrain_ids) - for(i in seq_len(pluck_depth(taxonomy_tree))){ - taxonomy_tree <- list_flatten(taxonomy_tree) + for(i in seq_len(purrr::pluck_depth(taxonomy_tree))){ + taxonomy_tree <- purrr::list_flatten(taxonomy_tree) } - result <- bind_rows(taxonomy_tree) + result <- dplyr::bind_rows(taxonomy_tree) # remove rows with ranks that are too low index <- rank_index(result$rank) down_to_index <- rank_index(.query$filter$value) result |> - filter({{index}} <= {{down_to_index}} | is.na({{index}})) |> - select("name", - "rank", - "parent_taxon_concept_id", - "taxon_concept_id") + dplyr::filter({{index}} <= {{down_to_index}} | is.na({{index}})) |> + dplyr::select("name", + "rank", + "parent_taxon_concept_id", + "taxon_concept_id") } #' Internal function to check whether constraints have been passed -#' @importFrom potions pour #' @noRd #' @keywords Internal check_constraints <- function(args, call){ if(any(names(call) == "constrain_ids")){ # i.e. if user specifies an argument call$constrain_ids }else{ # if NULL only occurs because no argument is set - if(pour("atlas", "region") == "Australia"){ + if(potions::pour("atlas", "region") == "Australia"){ "biodiversity.org.au" } } } #' Internal recursive function to get child taxa -#' @importFrom dplyr mutate -#' @importFrom dplyr select -#' @importFrom rlang .data #' @noRd #' @keywords Internal drill_down_taxonomy <- function(df, @@ -98,19 +86,16 @@ drill_down_taxonomy <- function(df, if(nrow(children) < 1){ return(df) }else{ - result <- children |> - mutate(name = str_to_title(children$name), - taxon_concept_id = children$guid, - parent_taxon_concept_id = children$parentGuid) |> - select("name", "rank", "taxon_concept_id", "parent_taxon_concept_id") - if(!is.null(constrain_ids)){ - result <- result |> + if(is.null(constrain_ids)){ + result <- children + }else{ + result <- children |> constrain_id(constrain_to = constrain_ids) } if(nrow(result) < 1){ return(df) }else{ - result_list <- lapply( + result_list <- purrr::map( split(result, seq_len(nrow(result))), function(a){drill_down_taxonomy(a, down_to, @@ -122,70 +107,66 @@ drill_down_taxonomy <- function(df, } #' Internal function to check `identify` term is specified correctly -#' @importFrom rlang abort #' @noRd #' @keywords Internal -check_identify <- function(.query, error_call = caller_env()){ +check_identify <- function(.query, + error_call = rlang::caller_env()){ if(is.null(.query$identify)){ - bullets <- c( - "Argument `identify` is missing, with no default.", - i = "Did you forget to specify a taxon?") - abort(bullets, call = error_call) + c("Argument `identify` is missing, with no default.", + i = "Did you forget to specify a taxon?") |> + cli::cli_abort(call = error_call) } if(nrow(.query$identify) > 1){ number_of_taxa <- nrow(.query$identify) - bullets <- c( - "Can't provide tree more than one taxon to start with.", + c("Can't provide tree more than one taxon to start with.", i = "atlas_taxonomy` only accepts a single taxon at a time.", - x = glue("`identify` has length of {number_of_taxa}.") - ) - abort(bullets, call = error_call) + x = "`identify` has length of {number_of_taxa}.") |> + cli::cli_abort(call = error_call) } } #' Internal function to check `identify` term is specified correctly -#' @importFrom rlang abort #' @noRd #' @keywords Internal -check_down_to <- function(.query, error_call = caller_env()){ +check_down_to <- function(.query, + error_call = rlang::caller_env()){ if (is.null(.query$filter$value)) { - bullets <- c( - "Argument `rank` is missing, with no default.", + c("Argument `rank` is missing, with no default.", i = "Use `show_all(ranks)` to display valid ranks", i = "Use `filter(rank == chosen_rank)` to specify a rank" ) - abort(bullets, call = error_call) + cli::cli_abort(call = error_call) } down_to <- tolower(.query$filter$value) if(!any(show_all_ranks()$name == down_to)){ - bullets <- c( - "Invalid taxonomic rank provided.", + c("Invalid taxonomic rank provided.", i = "The rank provided to `rank` must be a valid taxonomic rank.", - x = glue("{down_to} is not a valid rank.") - ) - abort(bullets, call = error_call) + x = "{down_to} is not a valid rank.") |> + cli::cli_abort(call = error_call) } } #' Internal function to only return GUIDs that match particular criteria -#' @importFrom purrr list_transpose -#' @importFrom dplyr filter #' @noRd #' @keywords Internal constrain_id <- function(df, constrain_to){ - check_list <- lapply(constrain_to, function(a){grepl(a, df$taxon_concept_id)}) - check_result <- lapply(list_transpose(check_list), any) |> + check_list <- purrr::map(constrain_to, + function(a){grepl(a, df$taxon_concept_id)}) + check_result <- purrr::map(purrr::list_transpose(check_list), any) |> unlist() - df |> filter(check_result) + df |> + dplyr::filter(check_result) } # Return the index of a taxonomic rank- # lower index corresponds to higher up the tree +#' @noRd +#' @keywords Internal rank_index <- function(x) { all_ranks <- show_all_ranks() - lapply(x, function(a){ + purrr::map(x, function(a){ if (a %in% all_ranks$name) { return(all_ranks$id[all_ranks$name == a]) }else{ diff --git a/R/authenticate.R b/R/authenticate.R new file mode 100644 index 00000000..208d59d2 --- /dev/null +++ b/R/authenticate.R @@ -0,0 +1,35 @@ +#' Set up authentication +#' +#' Add an authentication slot to a query. That slot is then used by later +#' code to determine whether to add an OAuth workflow. It is triggered +#' automatically within [capture()] if the `authenticate` argument +#' of [galah_config()] is set to `TRUE`, but only for occurrence queries +#' to the Atlas of Living Australia. +#' `r lifecycle::badge("experimental")`. +#' @param .data An object of class `data_request` or `metadata_request` +#' @param cache_disk (logical) Should JWT tokens be cached to disk? Defaults +#' to `FALSE` +#' @returns An object of the same class as supplied, but with an added +#' `authenticate` slot. +#' @examples \dontrun{ +#' # use `galah_config()` to set for all occurrence queries +#' galah_config(authenticate = TRUE) +#' +#' x <- galah_call() |> +#' identify("Wollemia nobilis") |> +#' collect() +#' +#' # use in-pipe for more control +#' x <- galah_call() |> +#' identify("Wollemia nobilis") |> +#' authenticate() |> +#' collect() +#' } +#' @export +authenticate <- function(.data, + cache_disk = FALSE){ + update_request_object(.data, + authenticate = list(use_jwt = TRUE, + use_apikey = FALSE, # not supported yet + cache_disk = cache_disk)) +} \ No newline at end of file diff --git a/R/build_checks.R b/R/build_checks.R deleted file mode 100644 index 907442d6..00000000 --- a/R/build_checks.R +++ /dev/null @@ -1,62 +0,0 @@ -#' Internal function to build necessary metadata into a single object -#' I.e. to parse a `query_set` object within `collapse()` -#' @noRd -#' @keywords Internal -build_checks <- function(.query){ - # get basic description of `query_set` object - n <- length(.query) - names_vec <- unlist(lapply(.query, function(a){a$type})) - # look for any `data` - data_lookup <- grepl("^data", names_vec) - if(any(data_lookup)){ - data_names <- names_vec[data_lookup] - # parse any `metadata` - metadata_results <- parse_metadata(names_vec, .query) - # parse `data`, including supplied metadata - # this assumes only one `data` field is available per `query_set` - .query[[which(data_lookup)]] |> - add_metadata(metadata_results) - }else if(any(names_vec %in% c("metadata/fields-unnest", - "metadata/profiles-unnest", - "metadata/taxa-unnest"))){ - # this code accounts for `unnest` functions that require lookups - # metadata/fields-unnest calls check_fields(), requiring fields and assertions - # metadata/profiles-unnest calls profile_short_name(), which requires profiles - if(length(.query) > 1){ - metadata_results <- parse_metadata(names_vec, .query) - .query[[2]] |> - add_metadata(metadata_results) - }else{ - .query[[1]] - } - }else{ - # if no metadata are needed, return .query unaltered - .query[[1]] - } -} - -#' Internal function to parse metadata -#' @noRd -#' @keywords Internal -parse_metadata <- function(names_vec, .query){ - metadata_lookup <- grepl("^metadata", names_vec) & - !grepl("-unnest$", names_vec) # unnest functions only parse in collect() - if(any(metadata_lookup)){ - metadata_names <- names_vec[metadata_lookup] - metadata_results <- lapply(.query[which(metadata_lookup)], collect) - names(metadata_results) <- metadata_names - metadata_results - }else{ - NULL - } -} - -#' Internal function to pass metadata to `collapse()` functions -#' called by `compute.query_set()` -#' @noRd -#' @keywords Internal -add_metadata <- function(query, meta){ - result <- c(query, meta) - class(result) <- "query" - return(result) -} \ No newline at end of file diff --git a/R/build_predicates.R b/R/build_predicates.R index 24b0344f..b7e44f02 100644 --- a/R/build_predicates.R +++ b/R/build_predicates.R @@ -1,64 +1,109 @@ -#' Build predicates -#' -#' predicates are JSON scripts for passing to GBIF offline downloads API. -#' https://www.gbif.org/developer/occurrence -#' @importFrom potions pour -#' @importFrom jsonlite toJSON -#' @importFrom jsonlite unbox +#' join all queries +#' NOTE: There is a maximum of 101k entries in total. Should be possible to enforce that here +#' @param an object of class `query_set` #' @noRd #' @keywords Internal -build_predicates <- function( - df, # where df is returned by galah_filter() - location, - format = "SIMPLE_CSV" -){ - if(nrow(df) < 1){ - return(NULL) +build_predicates <- function(x){ + x$filter |> + join_predicates(parse_predicates_identify(x$identify)) |> + join_predicates(parse_predicates_location(x$geolocate)) + +} + +#' Internal function to join predicates together +#' @param a predicate +#' @param ... two or more predicates to join to x +#' @noRd +#' @keywords Internal +join_predicates <- function(x, y = NULL){ + + if(is.null(y)){ + x + }else{ + # for `and` queries, we extract everything, add new content, then rebuild + + if(is_and_query(x)){ + x <- x$predicates + } + + # add content together + filters_list <- c(check_predicate_wrapping(x), + check_predicate_wrapping(y)) + names(filters_list) <- NULL + list(type = "and", + predicates = filters_list) } +} - predicates_list <- c( - parse_predicates(df), - parse_predicates_spatial(location)) - - if(length(predicates_list) > 1){ - predicates_list <- list( - type = unbox("and"), - predicates = predicates_list - ) +#' simple check for whether predicates begin with `and` +#' @noRd +#' @keywords Internal +is_and_query <- function(x){ + if(purrr::pluck_exists(x, "type")){ + if(purrr::pluck(x, "type") == "and"){ + TRUE + }else{ + FALSE + } + }else{ + FALSE + } +} + +#' simple check to ensure lists are joined correctly +#' @noRd +#' @keywords Internal +check_predicate_wrapping <- function(x){ + if(length(x) > 2 & + any(names(x) %in% c("in", "key", "value"))){ + list(x) + }else{ + x } - - data_list <- list( - creator = unbox(pour("user", "username", .pkg = "galah")), - notificationAddresses = pour("user", "email", .pkg = "galah"), - sendNotification = unbox(pour("package", "send_email", .pkg = "galah")), - format = unbox(format), - predicate = predicates_list - ) +} - toJSON(data_list) +#' handle taxonomic queries +#' @noRd +#' @keywords Internal +parse_predicates_identify <- function(x){ + if(!is.null(x)){ + result <- purrr::map(x$taxon_concept_id, + \(a){list(type = "equals", + key = "TAXON_KEY", + value = a)}) + if(length(result) > 1){ + list(type = "or", + result) + }else{ + result + } + }else{ + NULL + } } -#' most code borrowed from `build_query_gbif()` +#' handle spatial queries +#' NOTE: There is a limit of 10k points in geometry; should be possible to enforce that here #' @noRd #' @keywords Internal -parse_predicates_spatial <- function(location){ +parse_predicates_location <- function(location){ if(!is.null(location)) { # if location is for a point radius vs polygon/bbox if(!is.null(names(location))){ if(all(!is.null(location$radius))) { # `galah_radius()` will always pass radius argument - list(type = unbox("geoDistance"), - latitude = unbox(location$lat), - longitude = unbox(location$lon), - distance = unbox(paste0(location$radius, "km"))) |> + list(type = "geoDistance", + latitude = location$lat, + longitude = location$lon, + distance = glue::glue("{location$radius} km")) |> list() }else{ - list(type = unbox("within"), - geometry = unbox(location)) |> + list(type = "within", + geometry = location) |> list() } }else{ - list(type = unbox("within"), - geometry = unbox(location)) |> + list(type = "within", + geometry = location) |> list() } }else{ @@ -66,36 +111,26 @@ parse_predicates_spatial <- function(location){ } } -#' parse galah_filter result into predicate format -#' @importFrom jsonlite unbox +#' handle `group_by` in predicates #' @noRd #' @keywords Internal -parse_predicates <- function(df){ - json_text <- lapply( - split(df, seq_len(nrow(df))), - function(a){ - list( - type = unbox(switch(a$logical, - "==" = "equals", - "<" = "lessThan", - "<=" = "lessThanOrEquals", - ">" = "greaterThan", - ">=" = "greaterThanOrEquals", - "!=" = "not" - )), - key = unbox(gbif_upper_case(a$variable)), - value = unbox(a$value) - ) - }) - names(json_text) <- NULL - return(json_text) +parse_predicates_groupby <- function(groupby){ + if(!is.null(groupby)){ + array(data = gbif_upper_case(groupby$name), + dim = length(groupby$name), + dimnames = NULL) + }else{ + NULL + } } -# NOTE: currently missing: `or`, `in`, `isNull`, `isNotNull` -# test object: -# df <- galah_filter(year == 1850) -# df <- galah_filter(catalogNumber == 217880) - -gbif_upper_case <- function(string){ - gsub("(?=[[:upper:]])", "_", string, perl = TRUE) |> toupper() +#' clean up a list +#' @noRd +#' @keywords Internal +remove_nulls_from_list <- function(x){ + if(length(x) < 1){ + NULL + }else{ + x[!unlist(purrr::map(x, is.null))] + } } \ No newline at end of file diff --git a/R/build.R b/R/build_query.R similarity index 58% rename from R/build.R rename to R/build_query.R index d819390c..0f062990 100644 --- a/R/build.R +++ b/R/build_query.R @@ -3,30 +3,15 @@ #' @keywords Internal build_headers <- function(){ list("User-Agent" = galah_version_string()) - ## Below code adds API keys (not yet implemented) - ## Add these as optional - # if(pour("atlas", "acronym") == "ALA"){ - # list( - # "User-Agent" = galah_version_string(), - # "x-api-key" = pour("user", "api_key") - ## if(){ # something about if we're using JWT tokens - ## list( - ## "User-Agent" = galah_version_string(), - ##. "Authorization" = paste("Bearer", access_token)) - ## } - # }else{ - # list("User-Agent" = galah_version_string()) - # } } #' Build query list from constituent arguments #' @noRd #' @keywords Internal -#' @importFrom potions pour build_query <- function(identify = NULL, filter = NULL, location = NULL, - data_profile = NULL) { + apply_profile = NULL) { if(is.null(identify)) { taxa_query <- NULL } else { # assumes a tibble or data.frame has been given @@ -41,7 +26,7 @@ build_query <- function(identify = NULL, filter_query <- NULL } else { if(!inherits(filter, "data.frame")){ - abort("`filter` must be a `data.frame` or `tibble`") + cli::cli_abort("`filter` must be a `data.frame` or `tibble`") } if (nrow(filter) == 0) { filter_query <- NULL @@ -67,57 +52,15 @@ build_query <- function(identify = NULL, query$wkt <- location } } - # add profiles information (ALA only) - if(!is.null(data_profile)) { - query$qualityProfile <- data_profile - } else { - query$disableAllQualityFilters <- "true" - } - build_single_fq(query) -} - -#' Build query list from constituent arguments for GBIF only -#' @importFrom glue glue_data -#' @importFrom potions pour -#' @noRd -#' @keywords Internal -build_query_gbif <- function(identify = NULL, - filter = NULL, - location = NULL){ - if(is.null(identify)) { - taxa_query <- list(taxonKey = 1) - }else{ - taxa_query <- list(taxonKey = "`TAXON_PLACEHOLDER`") - } - # filter - if(is.null(filter)) { - filter_query <- NULL - }else{ - if(!inherits(filter, "data.frame")){ - abort("`filter` must be a `data.frame` or `tibble`") - } - if(nrow(filter) == 0) { - filter_query <- NULL - }else{ - filter_query <- build_filter_query(filter) - } - } - # merge - query <- c(taxa_query, filter_query) - # geographic stuff - if (!is.null(location)) { - # if location is for a point radius vs polygon/bbox - if(!is.null(names(location))){ - if(all(!is.null(location$radius))) { # `galah_radius()` will always pass radius argument - query$geoDistance <- glue_data(location, - "{lat},{lon},{radius}km") - }else - query$geometry <- location + # add profiles information (ALA only) + if(profiles_supported()){ + if(!is.null(apply_profile)) { + query$qualityProfile <- apply_profile } else { - query$geometry <- location - } + query$disableAllQualityFilters <- "true" + } } - query + build_single_fq(query) } #' collapse multiple fq args into one @@ -133,14 +76,14 @@ build_single_fq <- function(query){ !grepl("assertions", fq) & # assertions don't need additional brackets !grepl("^-\\(", fq) # negative query already has brackets if(any(missing_brackets)){ - fq[missing_brackets] <- paste0("(", fq[missing_brackets], ")") + fq[missing_brackets] <- glue::glue("({fq[missing_brackets]})") } # add brackets to non-negative AND statements # (adding additional brackets to negative statements breaks them) if(any(!grepl("^-\\(", fq))) { - fq_single <- glue::glue_collapse(glue("{fq}"), "AND") + fq_single <- glue::glue_collapse(glue::glue("{fq}"), "AND") } else { - fq_single <- glue::glue_collapse(glue("({fq})"), "AND") + fq_single <- glue::glue_collapse(glue::glue("({fq})"), "AND") } c(fq = fq_single, query[names(query) != "fq"]) }else{ @@ -170,8 +113,6 @@ build_filter_query <- function(filters) { } #' Sub-function to `build_query()` for taxa -#' @importFrom glue glue -#' @importFrom glue glue_collapse #' @noRd #' @keywords Internal build_taxa_query <- function(ids) { @@ -181,10 +122,10 @@ build_taxa_query <- function(ids) { }else{ wrapped_ids <- paste0("\"", ids, "\"") id_tag <- "lsid" - glue( + glue::glue( "({id_tag}:", - glue_collapse(wrapped_ids, - sep = glue(" OR {id_tag}:")), + glue::glue_collapse(wrapped_ids, + sep = glue::glue(" OR {id_tag}:")), ")") } } @@ -194,12 +135,11 @@ build_taxa_query <- function(ids) { #' It is pretty messy, as: #' 1. ALA returns empty lists and NULL values in some fields, and #' 2. tibble() and friends don't handle list-columns well -#' @importFrom tibble as_tibble #' @noRd #' @keywords Internal build_tibble_from_nested_list <- function(result){ # handle normal columns - source_tibble <- lapply(result, function(a){ + source_tibble <- purrr::map(result, function(a){ if(is.null(a)){ as.character(NA) }else if(length(a) > 1){ @@ -210,10 +150,10 @@ build_tibble_from_nested_list <- function(result){ a } }) |> - as_tibble() + tibble::as_tibble() # handle nested columns - list_cols <- lapply(result, - function(a){is.list(a) & length(a) > 0}) |> + list_cols <- purrr::map(result, + function(a){is.list(a) & length(a) > 0}) |> unlist() if(any(list_cols)){ list_data <- result[list_cols] @@ -232,24 +172,18 @@ build_tibble_from_nested_list <- function(result){ #' Build a valid wkt string from a spatial polygon #' Internal function to `galah_bbox` and `galah_polygon()` -#' @importFrom sf st_as_text -#' @importFrom sf st_cast -#' @importFrom sf st_geometry -#' @importFrom sf st_geometry_type -#' @importFrom sf st_is_simple #' @noRd #' @keywords Internal -build_wkt <- function(polygon, error_call = caller_env()) { - if (st_geometry_type(polygon) == "POLYGON") { - polygon <- st_cast(polygon, "MULTIPOLYGON") +build_wkt <- function(polygon, + error_call = caller_env()) { + if (sf::st_geometry_type(polygon) == "POLYGON") { + polygon <- sf::st_cast(polygon, "MULTIPOLYGON") } - if (!st_is_simple(polygon)) { - bullets <- c( - "The area provided to `galah_bbox` is too complex. ", - i = "See `?sf::st_simplify` for how to simplify geospatial objects." - ) - abort(bullets, call = caller_env()) + if (!sf::st_is_simple(polygon)) { + c("The area provided to `galah_bbox` is too complex. ", + i = "See `?sf::st_simplify` for how to simplify geospatial objects.") |> + cli::cli_abort(call = error_call) } - wkt <- st_as_text(st_geometry(polygon)) + wkt <- sf::st_as_text(sf::st_geometry(polygon)) wkt } \ No newline at end of file diff --git a/R/build_query_set.R b/R/build_query_set.R deleted file mode 100644 index 6ff20c79..00000000 --- a/R/build_query_set.R +++ /dev/null @@ -1,199 +0,0 @@ -#' Build a query set -#' -#' This function is designed to be called before `collapse()`. Primarily used -#' internally and for debugging, it shows the maximum set of APIs that need -#' to be evaluated to answer the question posed by the user. -#' @param x An object of class `data_request`, `metadata_request` or -#' `files_request` (see `galah_call()`). -#' @param mint_doi `logical`: by default no DOI will be generated. Set to -#' `TRUE` if you intend to use the data in a publication or similar. Only -#' applies to occurrence downloads. -#' @param thumbnail Logical: should thumbnail-size images be returned? Defaults -#' to `FALSE`, indicating full-size images are required. Only applies to image -#' downloads. -#' @param ... Arguments passed to other methods. -#' @returns An object of class `query_set` -#' @noRd -#' @keywords Internal -build_query_set <- function(x, mint_doi, thumbnail, ...){ - switch(class(x), - "data_request" = { - if(x$type == "distributions"){ - build_query_set_distributions(x) - }else{ - build_query_set_data(x, mint_doi = mint_doi, ...) - } - }, - "metadata_request" = build_query_set_metadata(x), - "files_request" = build_query_set_files(x, thumbnail = thumbnail, ...), - abort("unknown object class") - ) -} - -#' Internal function to build a `query_set` object -#' for object of class `data_request` -#' @noRd -#' @keywords Internal -build_query_set_data <- function(x, mint_doi, ...){ - if(!missing(mint_doi)){ - x$mint_doi <- mint_doi - } - # x$type <- check_type(x$type) # needed? - # handle sending dois via `filter()` - # important this happens first, as it affects `type` which affects later code - variables <- x$filter$variable - if(!is.null(variables)){ - if(length(variables) == 1 & variables[1] == "doi"){ - x$type <- "occurrences-doi" - } - } - # handle `run_checks` - fields_absent <- lapply( - x[c("arrange", "filter", "select", "group_by")], - is.null - ) |> - unlist() - if (pour("package", "run_checks") & x$type != "occurrences-doi"){ - # add check here to see whether any filters are specified - # it is possible to only call `identify()`, for example - if (any(!fields_absent) | x$type %in% c("species-count", "species")) { - result <- list(collapse_fields(), collapse_assertions()) - } else { - # for living atlases, we need `collapse_fields()` to check the `lsid` field - # this isn't required for GBIF which doesn't use `fq` for taxon queries - if(!is.null(x$identify) &!is_gbif()){ - result <- list(collapse_fields()) - }else{ - result <- list() - } - } - if (x$type %in% c("occurrences", "media", "species") & - atlas_supports_reasons_api()) { - result[[(length(result) + 1)]] <- collapse_reasons() - } - } else { # if select is required, we need fields even if `run_checks == FALSE` - if(!fields_absent[["select"]] | x$type %in% c("occurrences", "species")){ - result <- list(collapse_fields(), collapse_assertions()) - }else{ - result <- list() - } - } - # handle `identify()` - if(!is.null(x$identify) & x$type != "occurrences-doi"){ - result[[(length(result) + 1)]] <- collapse_taxa(list(identify = x$identify)) - } - # handle `apply_profile()` - if(!is.null(x$data_profile)){ - result[[(length(result) + 1)]] <- collapse_profiles() - } - # handle query - result[[(length(result) + 1)]] <- switch( - x$type, - "occurrences" = { - if(is.null(x$group_by)){ - collapse_occurrences(x) - }else{ - collapse_species(x) - } - }, - "occurrences-count" = collapse_occurrences_count(x), - "occurrences-doi" = collapse_occurrences_doi(x), - "species" = collapse_species(x), - "species-count" = collapse_species_count(x), - abort("unrecognised 'type'")) - class(result) <- "query_set" - result -} - -#' Internal function to build a `query_set` object -#' for object of class `data_request` when `type = distributions` -#' @noRd -#' @keywords Internal -build_query_set_distributions <- function(x, ...){ - if(is.null(x$identify) & is.null(x$filter)){ - # find all expert distributions - result <- list( - collapse_distributions_metadata(), - collapse_distributions(x) - ) - }else{ - if(!is.null(x$identify)){ - result <- list( - collapse_taxa(list(identify = x$identify)) - ) - result[[2]] <- collapse_distributions(x) - }else{ - # i.e. !is.null(x$filter) - result <- list(collapse_distributions(x)) - } - } - class(result) <- "query_set" - result -} - -#' Internal function to build a `query_set` object -#' for object of class `metadata_request` -#' @noRd -#' @keywords Internal -build_query_set_metadata <- function(x, ...){ - if(pour("package", "run_checks")){ - result <- switch(x$type, - "fields-unnest" = list(collapse_fields()), - "profiles-unnest" = list(collapse_profiles()), - list()) - }else{ - result <- list() - } - if(grepl("-unnest$", x$type)){ - if(x$type == "taxa-unnest"){ - # identify() calls must be parsed, irrespective of `run_checks` (which is parsed above) - if(!is.null(x$identify)){ - result[[(length(result) + 1)]] <- collapse_taxa(x) - } - if(is.null(x$identify) & is.null(x$filter)){ - abort("Requests of type `taxa-unnest` must also supply one of `filter()` or `identify()`.") - } - }else if(is.null(x$filter)){ - current_type <- x$type - bullets <- glue("Requests of type `{current_type}` containing `unnest` must supply `filter()`.") - abort(bullets) - } - } - result[[(length(result) + 1)]] <- switch(x$type, - "apis" = collapse_apis(), - "assertions" = collapse_assertions(), - "atlases" = collapse_atlases(), - "collections" = collapse_collections(x), - "datasets" = collapse_datasets(x), - "distributions" = collapse_distributions_metadata(x), - "fields" = collapse_fields(), - "fields-unnest" = collapse_fields_unnest(x), - "licences" = collapse_licences(), - "lists" = collapse_lists(x), - "lists-unnest" = collapse_lists_unnest(x), - "media" = collapse_media(x), - "profiles" = collapse_profiles(), - "profiles-unnest" = collapse_profiles_unnest(x), - "providers" = collapse_providers(x), - "ranks" = collapse_ranks(), - "reasons" = collapse_reasons(), - "taxa" = collapse_taxa(x), - "taxa-unnest" = collapse_taxa_unnest(x), - "identifiers" = collapse_identifiers(x), - abort("unrecognised 'type'") - ) - class(result) <- "query_set" - result -} - -#' Internal function to build a `query_set` object -#' for object of class `files_request` -#' @noRd -#' @keywords Internal -build_query_set_files <- function(x, ..., thumbnail){ - result <- list(switch(x$type, - "media" = collapse_media_files(x, thumbnail = thumbnail) - )) - class(result) <- "query_set" - result -} \ No newline at end of file diff --git a/R/capture.R b/R/capture.R new file mode 100644 index 00000000..4ea1fcf1 --- /dev/null +++ b/R/capture.R @@ -0,0 +1,412 @@ +#' Capture a request +#' +#' @description +#' The first step in evaluating a request is to capture and parse the +#' information it contains. The resulting object has class `prequery` +#' for those requiring further processing or `query` for those that don't. +#' A `prequery` object shows the basic structure of what has been requested by +#' a user in a given [galah_call()]. +#' +#' @name capture.data_request +#' @param x A `_request` object to convert to a `prequery`. +#' @param ... Other arguments, currently ignored +#' @details +#' `galah` uses an object-based pipeline to convert piped requests into +#' valid queries, and to enact those queries with the specified organisation. +#' Typically, requests open with [galah_call()] - though [request_metadata()] +#' and [request_files()] are also valid - and end with +#' \code{\link[=collect.data_request]{collect()}}. Under the hood, +#' the sequence of functions is as follows: +#' +#' [capture()] → [compound()] → +#' \code{\link[=collapse.data_request]{collapse()}} → +#' \code{\link[=compute.data_request]{compute()}} → +#' \code{\link[=collect.data_request]{collect()}} +#' +#' [capture()] is the first of the [galah_call()] workflow, and it parses the +#' basic structure of a user request, returned as a `prequery` object. +#' A `prequery` object shows what has been requested, before those +#' calls are built by [compound()] and evaluated by +#' \code{\link[=collapse.data_request]{collapse()}}. +#' For simple cases, this gives the same result as running +#' \code{\link[=collapse.data_request]{collapse()}} while the `run_checks` +#' argument of [galah_config()] is set to `FALSE`, but is slightly faster. +#' In complex cases, it is simply a precursor to [compound()]. +#' +#' @order 1 +#' @return Either an object of class `prequery` when further processing is +#' required; or `query` when it is not. Both classes are structurally identical, +#' being list-like and containing at the following slots: +#' +#' - `type`: The type of query, serves as a lookup to the corresponding field in `show_all(apis)` +#' - `url`: Either: +#' - a length-1 character giving the API to be queried; or +#' - a `tibble()` containing at least the field `url` and optionally others +#' - `request`: captures the preceeding `_request` object (see [galah_call()]) +#' +#' @seealso To open a piped query, see [galah_call()]. For alternative +#' operations on `_request` objects, see [compound()], +#' \code{\link[=collapse.data_request]{collapse()}}, +#' \code{\link[=compute.data_request]{compute()}} or +#' \code{\link[=collect.data_request]{collect()}}. +#' @export +capture <- function(x, ...){ + UseMethod("capture") +} + +#' @rdname capture.data_request +#' @param mint_doi Logical: should a DOI be minted for this download? Only +#' applies to `type = "occurrences"` when atlas chosen is "ALA". +#' @order 2 +#' @export +capture.data_request <- function(x, + mint_doi = FALSE, + ...){ + x <- x |> + check_authentication() |> + check_doi() |> + check_distinct_count_groupby() |> + check_glimpse() |> + check_slice_arrange() |> + enforce_select_query() + switch(x$type, + "occurrences" = capture_occurrences(x, mint_doi = mint_doi), + "occurrences-count" = capture_occurrences_count(x), + "occurrences-doi" = capture_occurrences_doi(x), + "occurrences-glimpse" = capture_occurrences_glimpse(x), + "species" = capture_species(x), + "species-count" = capture_species_count(x), + "distributions" = capture_distributions_data(x), + cli::cli_abort("Unrecognised 'type'")) |> + add_request(x) +} + +#' @rdname capture.data_request +#' @order 3 +#' @export +capture.metadata_request <- function(x, ...){ + x <- x |> + check_authentication() |> + enforce_select_query() + switch(x$type, + "apis" = capture_apis(x), + "assertions" = capture_assertions(x), + "atlases" = capture_atlases(x), + "collections" = capture_collections(x), + "config" = capture_config(x), + "datasets" = capture_datasets(x), + "distributions" = capture_distributions_metadata(x), + "fields" = capture_fields(x), + "fields-unnest" = capture_fields_unnest(x), + "licences" = capture_licences(x), + "lists" = capture_lists(x), + "lists-unnest" = capture_lists_unnest(x), + "media" = capture_media_metadata(x), + "profiles" = capture_profiles(x), + "profiles-unnest" = capture_profiles_unnest(x), + "providers" = capture_providers(x), + "ranks" = capture_ranks(x), + "reasons" = capture_reasons(x), + "taxa" = capture_taxa(x), + "taxa-unnest" = capture_taxa_unnest(x), + "identifiers" = capture_identifiers(x), + cli::cli_abort("Unrecognised 'type'") + ) |> + add_request(x) + # FIXME: If authentication is added, this should change from being a `query` to a `prequery` +} + +#' @rdname capture.data_request +#' @param thumbnail Logical: should thumbnail-size images be returned? Defaults +#' to `FALSE`, indicating full-size images are required. +#' @order 4 +#' @export +capture.files_request <- function(x, + thumbnail = FALSE, + ...){ + # NOTE: switch is technically superfluous right now, but could be useful + # for future file types + + # This code is identical to `collapse.files_request()` + switch(x$type, + "media" = capture_media_files(x, + thumbnail = thumbnail), + cli::cli_abort("Unrecognised 'type'")) |> + add_request(x) +} + +#' @rdname capture.data_request +#' @order 5 +#' @export +capture.list <- function(x, ...){ + as_prequery(x) +} + +#' Internal function to enforce class `query` +#' @noRd +#' @keywords Internal +as_query <- function(x){ + structure(x, class = c("query", "list")) +} + +#' Internal function to enforce class `prequery` +#' @noRd +#' @keywords Internal +as_prequery <- function(x){ + structure(x, class = c("prequery", "list")) +} + +#' Internal function to ensure that DOIs are parsed properly +#' @noRd +#' @keywords Internal +check_doi <- function(x){ + if(x$type == "occurrences"){ + if(is_gbif()){ + variables <- unlist(x$filter) + if(any(variables == "DOI")){ + x$type <- "occurrences-doi" + } + }else{ + # handle sending dois via `filter()` + # important this happens first, as it affects `type`, which affects later code + variables <- purrr::pluck(x, "filter", "variable") + if(!is.null(variables)){ + if(length(variables) == 1 & variables[1] == "doi"){ + x$type <- "occurrences-doi" + } + } + } + + } + x +} + +#' Internal function to check behaviour of `distinct()`, `group_by()` etc. +#' called by `capture()` +#' @noRd +#' @keywords Internal +check_distinct_count_groupby <- function(x){ + + if(x$type == "occurrences-doi"){ + return(x) + } + + # get basic info + has_group_by <- !is.null(x$group_by) + has_count <- !is.null(x$count) + has_distinct <- !is.null(x$distinct) + has_select <- !is.null(x$select) + + # if type is 'species', ensure `distinct` is added + # this is clunky, but backwards compatible + if(x$type == "species" & !has_distinct){ + if(has_count){ + x <- x |> distinct(species_facets(), .keep_all = FALSE) + }else{ + x <- x |> distinct(species_facets(), .keep_all = TRUE) + } + has_distinct <- TRUE + } + + # first handle case when distinct() is supplied + if(has_distinct){ + has_distinct_name <- !is.na(x$distinct$name) + keep_all <- x$distinct$keep_all + if(has_distinct_name){ + if(keep_all){ + update_request_object(x, type = "species") + }else{ # keep_all is FALSE + if(has_group_by){ + x |> + update_request_object(type = "species-count") + }else{ + if(has_count){ + # counts the number of facets + x |> + update_request_object(type = "species-count") + }else{ + # designed to be equivalent to `show_values()` + x |> + update_request_object(type = "occurrences-count") |> + dplyr::select(-dplyr::any_of(c("label", "i18nCode", "fq", "count"))) + } + } + } + }else{ # no distinct name + if(has_group_by){ + if(keep_all){ + x <- update_request_object(x, type = "species") + if(has_count){ + count_switch(x) + }else{ + x + } + }else{ + x <- update_request_object(x, type = "occurrences-count") + if(has_select){ + if(has_count){ + x + }else{ + dplyr::select(x, -dplyr::any_of("count")) + } # end has_count + }else{ # end has_select + if(has_count){ + dplyr::select(x, -dplyr::any_of(c("label", "i18nCode", "fq"))) + }else{ + dplyr::select(x, -dplyr::any_of(c("label", "i18nCode", "fq", "count"))) + } + } # end has_select + } # end keep_all = FALSE + }else{ # no group_by() AND empty call distinct() + if(has_count){ + count_switch(x) + }else{ + x + } + } # end has_group_by + } # end has_distinct_name + }else{ # no distinct() call + if(has_select){ + if(has_count){ + count_switch(x) + }else{ + x + } + }else{ # no select + if(has_count){ + x |> + count_switch() |> + dplyr::select(-dplyr::any_of(c("label", "i18nCode", "fq"))) + }else{ + dplyr::select(x, group = "basic") # assumes type = "occurrences" + } + } # end has_select + } # end has_distinct +} # end function + +#' Internal function called by `capture()` +#' @noRd +#' @keywords Internal +count_switch <- function(x){ + x$type <- switch(x$type, + "occurrences" = "occurrences-count", + "occurrences-count" = "occurrences-count", + "species" = "species-count", + "species-count" = "species-count", + "media" = cli::cli_abort("type = 'media' is not supported by `count()`"), + cli::cli_abort("`count()` only supports `type = 'occurrences' or` `'species'`")) + x +} + +#' Internal function to capture `glimpse()` calls +#' @noRd +#' @keywords Internal +check_glimpse <- function(x){ + if(!is.null(x$glimpse)){ + if(x$type == "occurrences"){ + x$type <- "occurrences-glimpse" + x + }else{ + cli::cli_inform("`glimpse()` is only supported for `type =\"occurrences\"") + x + } + }else{ + x + } +} + +#' Internal function to check `slice` and `arrange` for counts +#' @keywords Internal +#' @noRd +check_slice_arrange <- function(x){ + if(!stringr::str_detect(x$type, "-count$")){ + x + }else{ + if(is.null(x$slice)){ + # limits to 10,000 rows + # TODO: This should ultimately be set by `slice` or `atlas_counts(limit = )`, not internally. + # Will need updating to avoid hidden limit setting here & in `compute_occurrences_count()` + slice <- tibble::tibble(slice_n = 1e4, slice_called = FALSE) + }else{ + slice <- x$slice + } + if(is.null(x$arrange)){ + arrange <- tibble::tibble(variable = "count", + direction = "descending") + }else{ + arrange <- x$arrange + } + x$slice_arrange <- dplyr::bind_cols(slice, arrange) + x$arrange <- NULL + x$slice <- NULL + x + } +} + +#' Internal function to enforce `select()` for metadata queries. Basically just +#' supplies defaults. This is the *setup* phase as is usually called by +#' `capture()` +#' @noRd +#' @keywords Internal +enforce_select_query <- function(x){ + # note: UseMethod() would be tidier, but seems to need to be exported to work? + switch(class(x)[1], + "metadata_request" = enforce_select_query_metadata(x), + "data_request" = enforce_select_query_data(x), + x) +} + +#' sub-function to `enforce_select_query()` +#' @noRd +#' @keywords Internal +enforce_select_query_metadata <- function(x){ + # if `select()` is given, we simply pass it on + # if missing, we have to apply some logic + if(is.null(x$select)){ + specific_type <- x |> + purrr::pluck("type") |> + stringr::str_remove("^metadata/") + # see whether `lookup_select_columns()` returns anything + chosen_columns <- lookup_select_columns(specific_type) + # some `unnest` queries internally rename the lead column to the name of the supplied field + if(is.null(chosen_columns) & + stringr::str_detect(specific_type, "-unnest$")){ + chosen_columns <- x$filter |> + purrr::pluck("value") + } + # if we have, after 2 attempts, found some chosen_columns, use them + if(!is.null(chosen_columns)){ + x <- dplyr::select(x, tidyselect::any_of({{chosen_columns}})) + # if *still* null, choose `everything()` + }else{ + x <- dplyr::select(x, tidyselect::everything()) + } + }else{ + x + } +} + +#' sub-function to `enforce_select_query()` +#' @noRd +#' @keywords Internal +enforce_select_query_data <- function(x){ + if(is.null(x$select)){ + switch(x$type, + "occurrences" = dplyr::select(x, group = "basic"), + "occurrences-count" = dplyr::select(x, -dplyr::any_of(c("label", "i18nCode", "fq"))), + "species" = dplyr::select(x, group = "taxonomy"), + # NOTE: further exceptions may be needed for type = "species" + dplyr::select(x, tidyselect::everything()) # useful for type = "occurrences-doi" + ) + }else{ + x + } +} + +#' @noRd +#' @keywords Internal +add_request <- function(new_obj, source_obj){ + new_class <- class(new_obj) + new_obj$request <- source_obj + structure(new_obj, class = new_class) +} \ No newline at end of file diff --git a/R/capture_distributions.R b/R/capture_distributions.R new file mode 100644 index 00000000..7d33404e --- /dev/null +++ b/R/capture_distributions.R @@ -0,0 +1,41 @@ +#' Internal function to run `capture()` for type `data/distributions` +#' @noRd +#' @keywords Internal +capture_distributions_data <- function(.query, + error_call = rlang::caller_env()){ + identify_supplied <- !is.null(.query$identify) + filter_supplied <- !is.null(.query$filter) + if(identify_supplied & filter_supplied){ + cli::cli_abort("`collapse(type = 'distributions')` only accepts one of `filter()` or `identify()`, not both", + call = error_call) + } + if(identify_supplied){ + url <- url_lookup("data/distributions-taxa", + lsid = "`TAXON_PLACEHOLDER`") + }else if(filter_supplied){ + values <- strsplit(.query$filter$value, "\\|")[[1]] + urls <- purrr::map(values, \(x){ + url_lookup("data/distributions-id", id = x)}) |> + unlist() + url <- tibble::tibble(url = urls) + }else{ # i.e. neither supplied, get all distributions via ID column + url <- url_lookup("data/distributions-id") + } + result <- list(type = "data/distributions", + url = url, + headers = build_headers()) + class(result) <- "query" + return(result) +} + +#' Internal function to create a distributions query +#' @noRd +#' @keywords Internal +capture_distributions_metadata <- function(.query){ + url <- url_lookup("metadata/distributions") + result <- list(type = "metadata/distributions", + url = url, + headers = build_headers()) + class(result) <- "query" + return(result) +} \ No newline at end of file diff --git a/R/capture_files.R b/R/capture_files.R new file mode 100644 index 00000000..0fe0f02b --- /dev/null +++ b/R/capture_files.R @@ -0,0 +1,84 @@ +#' Internal version of `capture()` for `request_files(type = "media")` +#' @param .query An object of class `files_request` (from `request_files()`) +#' @noRd +#' @keywords Internal +capture_media_files <- function(.query, + thumbnail = FALSE, + error_call = rlang::caller_env() + ){ + # handle filters + if(is.null(.query$filter)){ + cli::cli_abort("`This function requires a `filter()` argument", + call = error_call) + }else if(!inherits(.query$filter, "files_filter")){ + cli::cli_abort("Downloading media files requires a `filter()` query to work", + call = error_call) + } + df <- .query$filter$data + + # find unique identifiers anywhere you can + if(any(colnames(df) == "media_id")){ + identifiers <- df$media_id + }else if(any(colnames(df) == "image_id")){ + identifiers <- df$image_id + }else{ + cli::cli_abort("No valid identifiers found in supplied data.", + call = error_call) + } + + # create output + list(type = "files/media", + url = build_media_tibble(identifiers, + df$mime_type, + thumbnail), + headers = build_headers()) |> + as_query() + +} + +#' Internal function to create API urls AND file paths +#' @noRd +#' @keywords Internal +build_media_tibble <- function(identifiers, + mimetype, + thumbnail = FALSE){ + # create a `size` vector + # this is complicated because thumbnails fail for sounds + size_vec <- rep( + ifelse(thumbnail, "thumbnail", "original"), + length(identifiers)) + image_lookup <- mimetype %in% c("image/jpg", "image/jpeg", "image/png") + if(any(!image_lookup) & isTRUE(thumbnail)){ + size_vec[!image_lookup] <- "original" + } + + # return a result + tibble::tibble( + url = url_lookup("files/media", + id = identifiers, + size = size_vec), + path = build_file_path(ids = identifiers, + types = mimetype) + ) +} + +#' build file paths that include 1. path, 2. file name, 3. correct extension +#' @noRd +#' @keywords Internal +build_file_path <- function(ids, types){ + path <- potions::pour("package", "directory", .pkg = "galah") + ext <- dplyr::case_match(types, + "image/jpg" ~ "jpg", + "image/jpeg" ~ "jpg", + "image/png" ~ "png", + "audio/mpeg" ~ "mpg", + "audio/x-wav" ~ "wav", + "audio/mp4" ~ "mp4", + "image/gif" ~ "gif", + "video/3gpp" ~ "3gp", + "video/quicktime" ~ "mov", + "audio/vnd.wave" ~ "wav") + glue::glue("{path}/{ids}.{ext}") |> + as.character() +} + diff --git a/R/capture_metadata.R b/R/capture_metadata.R new file mode 100644 index 00000000..2e803810 --- /dev/null +++ b/R/capture_metadata.R @@ -0,0 +1,323 @@ +# These functions are called by `capture.metadata_request()` + +# Utility functions to build default forms of query + +#' Internal function to define a standard query +#' @param query_type the sting used to define that query type; see `show_all_apis()` +#' @noRd +#' @keywords Internal +default_query <- function(query_type){ + list(type = query_type, + url = url_lookup(query_type), + headers = build_headers()) +} + +#' Ditto for cache +#' @noRd +#' @keywords Internal +default_cache <- function(query_type){ + specific_type <- stringr::str_remove(query_type, "^metadata/") + list(type = query_type, + data = glue::glue("galah:::retrieve_cache(\"{specific_type}\")")) +} + +#' Modified version of `default_query()` that supports filtering +#' @noRd +#' @keywords Internal +filtered_query <- function(query_type, .query){ + url <- query_type |> + url_lookup() |> + httr2::url_parse() + url$query <- list(q = .query$filter$value[1]) + list(type = query_type, + url = httr2::url_build(url), + headers = build_headers()) +} + +# Actual functions called to build those queries + +#' Internal function get a tibble of APIs +#' @noRd +#' @keywords Internal +capture_apis <- function(x){ + list(type = "metadata/apis", + data = "galah:::node_config") |> + as_query() +} + +#' Internal function to create an assertions query +#' NOTE: API doesn't accept any arguments - could post-filter for search +#' @noRd +#' @keywords Internal +capture_assertions <- function(x){ + query_type <- "metadata/assertions" + if(is_gbif()){ + result <- list(type = query_type, + data = "galah:::gbif_internal_archived$assertions") + }else{ + if(check_if_cache_update_needed("assertions")){ + result <- default_query(query_type) + }else{ + result <- default_cache(query_type) + } + } + result |> + as_query() +} + +#' Internal function to create an atlases query +#' @noRd +#' @keywords Internal +capture_atlases <- function(x){ + list(type = "metadata/atlases", + data = "galah:::node_metadata") |> + as_query() +} + +#' Internal function to create a collections query +#' @noRd +#' @keywords Internal +capture_collections <- function(x){ + # set `type` + query_type <- "metadata/collections" + # If `filter()` is supplied, we always need a query + if(is_gbif() & !missing(x)){ + if(!is.null(x$filter)){ + result <- filtered_query(query_type, x) + }else{ + result <- default_query(query_type) + } + # If no `filter()`, check cache instead + }else{ + if(check_if_cache_update_needed("collections")){ + result <- default_query(query_type) + }else{ + result <- default_cache(query_type) + } + } + result |> + as_query() +} +# NOTE: LA collectory functions do not accept `max` or `offset` +# Therefore they cannot be paginated. GBIF collectory funs can. + +#' Internal function to create an auth-config query +#' @noRd +#' @keywords Internal +capture_config <- function(x){ + query_type <- "metadata/config" + if(check_if_cache_update_needed("config")){ + result <- default_query(query_type) + }else{ + result <- default_cache(query_type) + } + result |> + as_query() +} + +#' Internal function to create a datasets query +#' @noRd +#' @keywords Internal +capture_datasets <- function(x){ + # set `type` + query_type <- "metadata/datasets" + # If `filter()` is supplied, we always need a query + if(is_gbif() & !missing(x)){ + if(!is.null(x$filter)){ + result <- filtered_query(query_type, x) + }else{ + result <- default_query(query_type) + } + # If no `filter()`, check cache instead + }else{ + if(check_if_cache_update_needed("datasets")){ + result <- default_query(query_type) + }else{ + result <- default_cache(query_type) + } + } + result |> + as_query() +} + +#' Internal function to create a fields query +#' @noRd +#' @keywords Internal +capture_fields <- function(x){ + query_type <- "metadata/fields" + if(check_if_cache_update_needed("fields")){ + default_query(query_type) |> as_query() + }else{ + default_cache(query_type) |> as_query() + } +} + +#' Internal function to create a licences query +#' @noRd +#' @keywords Internal +capture_licences <- function(x){ + query_type <- "metadata/licences" + if(check_if_cache_update_needed("licences")){ + default_query(query_type) |> as_query() + }else{ + default_cache(query_type) |> as_query() + } +} + +#' Internal function to create a lists query +#' @noRd +#' @keywords Internal +capture_lists <- function(x, + error_call = rlang::caller_env()){ + query_type <- "metadata/lists" + # if filter is supplied, lookup a specified list by dr number + if(!is.null(x$filter)){ + dr_lookup <- stringr::str_detect(x$filter$value, "^dr") + if(any(dr_lookup)){ + dr_values <- x$filter$value[dr_lookup] + base_url <- url_lookup(query_type) + url <- glue::glue("{base_url}/{dr_values}") + if(length(url) > 1){ + result <- list(type = query_type, + url = tibble::tibble(url = url), # note: tibbles are used to skip pagination in `collapse()` + headers = build_headers()) + }else{ + result <- list(type = query_type, + url = url, + headers = build_headers()) + } + }else{ + cli::cli_abort(c("`filter()` arguments to `lists` only accept a data resource number", + i = "e.g. request_metadata() |> filter(lists == 'dr656')"), + call = error_call) + } + # if filter isn't supplied, check cache etc + }else{ + if(check_if_cache_update_needed("lists")){ + url <- url_lookup(query_type) |> + httr2::url_parse() + url$query <- list(max = 10000) + if(!missing(x)){ + if(!is.null(x$slice)){ + url$query <- list(max = x$slice$slice_n) + } + } + result <- list(type = query_type, + url = httr2::url_build(url), + headers = build_headers()) + }else{ + result <- default_cache(query_type) + } + } + result |> + as_query() +} + +#' Internal version of `capture()` for `request_metadata(type = "media")` +#' @param .query An object of class `metadata_request` (from `request_metadata()`) +#' @noRd +#' @keywords Internal +capture_media_metadata <- function(.query, + error_call = rlang::caller_env()){ + # NOTE: + # this function currently assumes that the user has passed an occurrence + # tibble verbatim to filter, i.e. + # `request_metadata() |> filter(media = occurrences) |> collapse()` + # It may be useful to support passing of media_ids directly, e.g. + # `request_metadata() |> filter(media = occurrences$images`) |> collapse() + if(is.null(.query$filter)){ + cli::cli_abort("Requests for metadata of type = \"media\" must have information passed via `filter()`", + call = error_call) + } + + ## Move this to `atlas_media()` + # occ <- .query$filter$data + # if(any(colnames(occ) %in% c("images", "videos", "sounds"))){ # Australia, Sweden, Spain + # media_cols <- which(colnames(occ) %in% c("images", "videos", "sounds")) + # media_ids <- do.call(c, occ[, media_cols]) |> + # unlist() + # media_ids <- media_ids[!is.na(media_ids)] + # names(media_ids) <- NULL + # }else if(any(colnames(occ) == "all_image_url")){ # Austria, Sweden, UK + # media_ids <- dplyr::pull(occ, "all_image_url") + # media_ids <- media_ids[!is.na(media_ids)] + # names(media_ids) <- NULL + # }else{ + # cli::cli_abort("Media metadata not found in supplied tibble", + # call = error_call) + # } + list(type = "metadata/media", + url = tibble::tibble(url = url_lookup("metadata/media", + id = .query$filter$value)), + headers = build_headers()) |> + as_query() + +} + +#' Internal function to create a profiles query +#' @noRd +#' @keywords Internal +capture_profiles <- function(x){ + query_type <- "metadata/profiles" + if(check_if_cache_update_needed("profiles")){ + result <- default_query(query_type) + }else{ + result <- default_cache(query_type) + } + result |> + as_query() +} + +#' Internal function to create a providers query +#' @noRd +#' @keywords Internal +capture_providers <- function(x){ + # set `type` + query_type <- "metadata/providers" + # If `filter()` is supplied, we always need a query + if(is_gbif() & !missing(x)){ + if(!is.null(x$filter)){ + result <- filtered_query(query_type, x) + }else{ + result <- default_query(query_type) + } + # If no `filter()`, check cache instead + }else{ + if(check_if_cache_update_needed("providers")){ + result <- default_query(query_type) + }else{ + result <- default_cache(query_type) + } + } + result |> + as_query() +} + +#' Internal function to create a reasons query +#' @noRd +#' @keywords Internal +capture_reasons <- function(x){ + query_type <- "metadata/reasons" + if(check_if_cache_update_needed("reasons")){ + result <- default_query(query_type) + }else{ + result <- default_cache(query_type) + } + result |> + as_query() +} + +#' Internal function to create a ranks query +#' @noRd +#' @keywords Internal +capture_ranks <- function(x){ + if(is_gbif()){ + result <- list(type = "metadata/ranks", + data = "galah:::gbif_internal_archived$ranks") + }else{ + result <- list(type = "metadata/ranks", + data = "galah:::galah_internal_archived$ranks") + } + result |> + as_query() +} \ No newline at end of file diff --git a/R/capture_metadata_unnest.R b/R/capture_metadata_unnest.R new file mode 100644 index 00000000..c27188ad --- /dev/null +++ b/R/capture_metadata_unnest.R @@ -0,0 +1,64 @@ +#' Internal function to run `capture()` for +#' `request_metadata(type = "fields") |> unnest()` +#' @noRd +#' @keywords Internal +capture_fields_unnest <- function(.query){ + url <- url_lookup("metadata/fields-unnest") |> + httr2::url_parse() + if(is_gbif()){ + url$query <- list(limit = 0, + facet = .query$filter$value[1], # note: facet (singular), not facets (plural) + facetLimit = 10^4) + }else{ + url$query <- list(facets = .query$filter$value[1], + flimit = 10^4) + } + list(type = "metadata/fields-unnest", + url = httr2::url_build(url)) |> + as_prequery() +} + +#' Internal function to run `capture()` for +#' `request_metadata(type = "lists") |> unnest()` +#' @noRd +#' @keywords Internal +capture_lists_unnest <- function(.query){ + # get list lookup url + url <- url_lookup("metadata/lists-unnest", + list_id = .query$filter$value[1]) |> + httr2::url_parse() + # set a default query + url$query <- list(max = -1, # remove max limit + includeKVP = TRUE) # add name & status columns + # create object + list(type = "metadata/lists-unnest", + url = httr2::url_build(url)) |> + as_query() +} + +#' Internal function to run `capture()` for +#' `request_metadata(type = "profiles") |> unnest()` +#' @noRd +#' @keywords Internal +capture_profiles_unnest <- function(.query){ + list(type = "metadata/profiles-unnest", + url = url_lookup("metadata/profiles-unnest", + profile = .query$filter$value[1])) |> + as_prequery() +} + +#' Internal function to `capture()` for +#' `request_metadata(type = "taxa") |> unnest()` +#' @noRd +#' @keywords Internal +capture_taxa_unnest <- function(.query){ + if(!is.null(.query$filter)){ + id <- .query$filter$value[1] + }else if(!is.null(.query$identify)){ + id <- "`TAXON_PLACEHOLDER`" + } + list(type = "metadata/taxa-unnest", + url = url_lookup("metadata/taxa-unnest", id = id), + headers = build_headers()) |> + as_prequery() +} diff --git a/R/capture_occurrences.R b/R/capture_occurrences.R new file mode 100644 index 00000000..333d1eb6 --- /dev/null +++ b/R/capture_occurrences.R @@ -0,0 +1,162 @@ +#' Internal function to convert `data_request` with `type = "occurrences"` to a `query` +#' @noRd +#' @keywords Internal +capture_occurrences <- function(.query, + ..., + error_call = rlang::caller_env()){ + if(is.null(.query$filter) & + is.null(.query$identify) & + is.null(.query$geolocate)){ + cli::cli_abort("No filters supplied to `capture()` with `type = \"occurrences\"`", + call = error_call) + } + switch(potions::pour("atlas", "region"), + "Global" = capture_occurrences_gbif(.query, ...), + capture_occurrences_la(.query, ...)) +} + +#' calculate the query to be returned for GBIF +#' @noRd +#' @keywords Internal +capture_occurrences_gbif <- function(.query, + format = "SIMPLE_CSV", + ...){ + # get user string + username <- potions::pour("user", "username", .pkg = "galah") + password <- potions::pour("user", "password", .pkg = "galah") + user_string <- glue::glue("{username}:{password}") + + # build object + list(type = "data/occurrences", + url = url_lookup("data/occurrences"), + headers = list( + `User-Agent` = galah_version_string(), + `X-USER-AGENT` = galah_version_string(), + `Content-Type` = "application/json", + Accept = "application/json"), + options = list( + httpauth = 1, + userpwd = user_string), + body = list(filter = .query$filter, + identify = .query$identify, + geolocate = .query$geolocate, + format = "SIMPLE_CSV")) |> + as_prequery() +} + +#' calculate the query to be returned for a given living atlas +#' @param .query An object of class `data_request()` +#' @noRd +#' @keywords Internal +capture_occurrences_la <- function(.query, + mint_doi = FALSE){ + # build a query + query <- c(build_query(identify = .query$identify, + filter = .query$filter, + location = .query$geolocate, + apply_profile = .query$apply_profile), + fields = "`SELECT_PLACEHOLDER`", + qa = "`ASSERTIONS_PLACEHOLDER`", + facet = "false", + sourceTypeId = {potions::pour("atlas", "region") |> + source_type_id_lookup()}, + reasonTypeId = potions::pour("user", "download_reason_id"), + dwcHeaders = "true") |> + add_email_notify() |> + add_email_address(query = .query) |> + add_doi_request(mint_doi = mint_doi) + + # build url + url <- url_lookup("data/occurrences") |> + httr2::url_parse() + url$query <- query + + # build output + list(type = "data/occurrences", + url = httr2::url_build(url), + headers = build_headers()) |> + as_prequery() +} + +#' Internal function to convert `data_request` with `type = "doi"` to a `query` +#' @noRd +#' @keywords Internal +capture_occurrences_doi <- function(.query, + error_call = rlang::caller_env()){ + # check for a doi filter + if(is.null(.query$filter)){ + cli::cli_abort("A DOI must be specified using `filter(doi == \"my-doi-here\")`.", + call = error_call) + } + + # check that doi is supplied 'correctly' + if(inherits(.query$filter, "predicates_filter")){ + doi_missing_check <- .query$filter$key != "DOI" + }else{ + doi_missing_check <- is.null(.query$filter$variable) && .query$filter$variable != "doi" + } + + # check atlas is ok + atlas <- potions::pour("atlas", "acronym") + if(!(atlas %in% c("ALA", "GBIF"))){ + c( + "DOI downloads not supported by selected atlas.", + i = "`request_data(type = \"occurrences-doi\")` has only been implemented for ALA & GBIF") |> + cli::cli_abort(call = error_call) + } + + # get doi + doi <- .query$filter$value[[1]] + + # remove "https://" if present + if (stringr::str_detect(doi, "^(http|https)://doi.org/")) { + doi <- stringr::str_remove(doi, "^(http|https)://doi.org/") + } + + # extract useful part of DOI + + if(atlas == "ALA"){ + doi <- stringr::str_split(doi, "ala.")[[1]][2] + if(is.na(doi)){ + c("DOI has not been generated by the ALA.", + i = "DOIs created by the ALA have a prefix of 10.26197/ala.") |> + cli::cli_abort(call = error_call) + } + } + + # build an object + list(type = "data/occurrences-doi", + url = url_lookup("data/occurrences-doi", + doi_string = doi), + headers = build_headers(), + download = TRUE) |> + as_query() +} + +#' Internal function to convert `data_request` with `type = "occurrences-glimpse"` to a `query` +#' @noRd +#' @keywords Internal +capture_occurrences_glimpse <- function(.query){ + if(is_gbif()){ + result <- capture_occurrences_count(.query) + result$body$limit <- 3 + result$type <- "data/occurrences-glimpse" + as_prequery(result) + }else{ + result <- capture_occurrences_la(.query) + url <- httr2::url_parse(result$url) + + # replace path with count API + url$path <- url_lookup("data/occurrences-count") |> + httr2::url_parse() |> + purrr::pluck("path") + + # add a pageSize arg + url$query$pageSize <- 3 + + # rebuild and ship + result$url <- httr2::url_build(url) + result$type <- "data/occurrences-glimpse" + as_prequery(result) + } +} \ No newline at end of file diff --git a/R/capture_occurrences_count.R b/R/capture_occurrences_count.R new file mode 100644 index 00000000..c2762323 --- /dev/null +++ b/R/capture_occurrences_count.R @@ -0,0 +1,127 @@ +#' capture() for type = "occurrences-count" +#' @keywords Internal +#' @param .query an object of class `data_request` +#' @noRd +capture_occurrences_count <- function(.query){ + # NOTE: This is quite weird syntax; consider revising + if(is_gbif()){ + function_name <- "capture_occurrences_count_gbif" + arg_names <- names(formals(capture_occurrences_count_gbif)) + }else{ + function_name <- "capture_occurrences_count_atlas" + arg_names <- names(formals(capture_occurrences_count_atlas)) + } + custom_call <- .query[names(.query) %in% arg_names] + class(custom_call) <- "data_request" + do.call(function_name, custom_call) +} + +#' capture() for counts on LAs +#' @keywords Internal +#' @noRd +capture_occurrences_count_atlas <- function(identify = NULL, + filter = NULL, + geolocate = NULL, + apply_profile = NULL, + group_by = NULL, + distinct = NULL, + slice_arrange = NULL +){ + query <- build_query(identify, + filter, + geolocate, + apply_profile = apply_profile) + # set behaviour depending on `group_by()` + if(is.null(group_by) & is.null(distinct)){ + url <- url_lookup("data/occurrences-count") |> + httr2::url_parse() + url$query <- c(query, pageSize = 0) + result <- list(type = "data/occurrences-count", + url = httr2::url_build(url), + headers = build_headers()) + }else{ + url <- url_lookup("data/occurrences-count-groupby") |> + httr2::url_parse() + if(!is.null(group_by)){ + facets <- group_by$name + }else{ + facets <- distinct$name + } + names(facets) <- rep("facets", length(facets)) + url$query <- c(query, facets, parse_slice_arrange(slice_arrange)) + result <- list(type = "data/occurrences-count-groupby", + url = httr2::url_build(url), + headers = build_headers()) + } + as_prequery(result) +} + +#' Internal function to parse `slice` and `arrange` for counts +#' @keywords Internal +#' @noRd +parse_slice_arrange <- function(df){ + if(df$variable == "count"){ # arranged in descending order by default + if(df$direction == "ascending"){ + list(fsort = "count", flimit = 0) + }else{ + list(fsort = "count", flimit = df$slice_n) + } + }else{ # non-count fields are arranged in ascending order by default + if(df$direction == "ascending"){ + list(fsort = "index", flimit = df$slice_n) + }else{ + list(fsort = "index", flimit = 0) + } + } +} + +#' capture() for counts on GBIF +#' @keywords Internal +#' @noRd +capture_occurrences_count_gbif <- function(identify = NULL, + filter = NULL, + geolocate = NULL, + group_by = NULL, + slice = NULL # probably broken + ){ + # compile supplied arguments into a list + # honestly this is a little messy, but the alternative is to call + # [build_predicates()], which is messier as taxonomic info hasn't yet been + # parsed. Instead we call [build_predicates()] during [collapse_query()]. + predicates_info <- list(identify = identify, + filter = filter, + geolocate = geolocate, + group_by = group_by, + slice = ifelse(is.null(slice), + tibble::tibble(slice_n = 30, slice_called = FALSE), + slice), + limit = 0) + + # get strings + username <- potions::pour("user", "username", .pkg = "galah") + password <- potions::pour("user", "password", .pkg = "galah") + user_string <- glue::glue("{username}:{password}") + + # handle type + if(is.null(group_by)){ + data_type <- "data/occurrences-count" + }else{ + data_type <- "data/occurrences-count-groupby" + } + + # build object + ## Note that unlike with other atlases, parsing of `group_by` is handled + ## by `collapse()` rather than here. + list(type = data_type, + url = url_lookup("data/occurrences-count"), + headers = list( + `User-Agent` = galah_version_string(), + `X-USER-AGENT` = galah_version_string(), + `Content-Type` = "application/json", + Accept = "application/json"), + options = list( + httpauth = 1, + userpwd = user_string), + body = predicates_info) |> + as_prequery() +} diff --git a/R/capture_species.R b/R/capture_species.R new file mode 100644 index 00000000..e323bcce --- /dev/null +++ b/R/capture_species.R @@ -0,0 +1,102 @@ +#' Internal function to run capture() for type = "species" +#' @noRd +#' @keywords Internal +capture_species <- function(.query){ + if(is_gbif()){ + result <- capture_occurrences_gbif(.query, + format = "SPECIES_LIST") + result$type <- "data/species" + result + }else{ + capture_species_atlas(.query) + } +} + +#' calculate the query to be returned for a given living atlas +#' @noRd +#' @keywords Internal +capture_species_atlas <- function(.query){ + # set default columns + if(is.null(.query$select)){ + .query <- .query |> select(group = "taxonomy") + } + + # determine whether to use `distinct()` or `species_facets()` + if(is.null(.query$distinct)){ + .query$distinct <- tibble::tibble(name = species_facets(), + type = "field") + }else{ + if(is.na(.query$distinct$name)){ + if(!is.null(.query$group_by)){ + .query$distinct$name <- .query$group_by$name + }else{ + cli::cli_abort("No variable supplied to `distinct()`") + } + } + } + + # build a query + query <- c( + build_query(.query$identify, + .query$filter, + .query$geolocate, + .query$apply_profile), + sourceTypeId = 2004, + reasonTypeId = potions::pour("user", "download_reason_id"), + facets = .query$distinct$name, + parse_select_species(.query$select)) |> + add_email_address(query = .query) |> + add_email_notify() + + # build url + url <- url_lookup("data/species") |> + httr2::url_parse() + url$query <- query + # build output + list(type = "data/species", + url = httr2::url_build(url), + headers = build_headers(), + download = TRUE) |> + as_prequery() +} + +#' parse `select()` for `atlas_species()` +#' @noRd +#' @keywords Internal +parse_select_species <- function(.select){ + # parse labels for supplied field names + if(length(.select$quosure) > 0){ + named_fields <- purrr::map(.select$quosure, rlang::as_label) |> + unlist() + }else{ + named_fields <- NULL + } + + # create output + result <- list( + lookup = "false", + count = "false", + synonym = "false", + lists = "false") + # fill list with correct results + if(!is.null(.select$group)){ + if(any(.select$group == "taxonomy")){ + result$lookup <- "true" + } + } + if(!is.null(named_fields)){ + # check for unexpected names + name_check <- !(named_fields %in% c("counts", "synonyms", "lists")) + if(any(name_check)){ + unexpected_names <- glue::glue_collapse(named_fields[name_check], last = " and ") + c("When type = 'species', `select()` only accepts 'counts', 'synonyms' or 'lists' as valid fields.", + i = glue::glue("Unexpected fields: {unexpected_names}")) |> + cli::cli_warn() + } + # parse 'correct' names + if(any(named_fields == "counts")){result$count <- "true"} + if(any(named_fields == "synonyms")){result$synonym <- "true"} + if(any(named_fields == "lists")){result$lists <- "true"} + } + result +} diff --git a/R/capture_species_count.R b/R/capture_species_count.R new file mode 100644 index 00000000..9c2ca51b --- /dev/null +++ b/R/capture_species_count.R @@ -0,0 +1,66 @@ +#' capture() for type = "species-count" +#' @keywords Internal +#' @param .query an object of class `data_request` +#' @noRd +capture_species_count <- function(.query, + error_call = rlang::caller_env()){ + if(is_gbif()){ + cli::cli_abort("`count()` is not supported for GBIF with type = 'species'", + call = error_call) + }else{ + function_name <- "capture_species_count_atlas" + arg_names <- names(formals(capture_species_count_atlas)) + } + custom_call <- .query[names(.query) %in% arg_names] + class(custom_call) <- "data_request" + do.call(function_name, custom_call) +} + +#' collapse for counts on LAs +#' @keywords Internal +#' @noRd +capture_species_count_atlas <- function(identify = NULL, + filter = NULL, + geolocate = NULL, + apply_profile = NULL, + group_by = NULL, + distinct = NULL, + slice_arrange = NULL +){ + # determine facets + if(is.null(distinct)){ + facet_variable <- species_facets() + }else{ + facet_variable <- distinct$name[[1]] + } + + # get url + url <- url_lookup("data/species-count") |> + httr2::url_parse() + query <- build_query(identify, + filter, + geolocate, + apply_profile = apply_profile) + + # set behaviour depending on `group_by()` + if(is.null(group_by)){ + url$query <- c(query, + list(flimit = 1, + facets = facet_variable)) + result <- list(type = "data/species-count", + url = httr2::url_build(url), + headers = build_headers()) + }else{ + facets <- c(as.list(group_by$name), + facet_variable) + names(facets) <- rep("facets", length(facets)) + url$query <- c(query, + facets, + parse_slice_arrange(slice_arrange), + list(flimit = -1)) + result <- list(type = "data/species-count", + url = httr2::url_build(url), + headers = build_headers()) + } + as_prequery(result) +} diff --git a/R/capture_taxa.R b/R/capture_taxa.R new file mode 100644 index 00000000..b6d9a040 --- /dev/null +++ b/R/capture_taxa.R @@ -0,0 +1,130 @@ +#' Internal function to run `capture()` for `type = "taxa"`, `method = "metadata` +#' @noRd +#' @keywords Internal +capture_taxa <- function(.query){ + if(is.null(.query$identify)){ + result <- list(type = "metadata/taxa") + }else{ + if(ncol(.query$identify) > 1 | + colnames(.query$identify)[1] != "search_term"){ + result <- capture_taxa_multiple(.query) + }else{ + result <- capture_taxa_single(.query) + } + } + result |> + as_query() +} + +#' Internal function to `capture()` for a single taxonomic name +#' @noRd +#' @keywords Internal +capture_taxa_single <- function(.query){ + terms <- .query$identify$search_term + list(type = "metadata/taxa-single", + url = tibble::tibble(url = url_lookup("metadata/taxa-single", + name = terms), + search_term = terms), + headers = build_headers()) +} + +#' Internal function to `collapse()` where multiple taxonomic levels are given +#' @noRd +#' @keywords Internal +capture_taxa_multiple <- function(.query){ + # get a data.frame, enforce use of accepted taxon levels + identify_df <- .query$identify + colnames(identify_df) <- colnames(identify_df) |> + tolower() + identify_df <- identify_df |> + dplyr::select(dplyr::any_of(accepted_ranks())) + + # split into one query per row + split_list <- split(.query$identify, + seq_len(nrow(.query$identify))) + base_url <- url_lookup("metadata/taxa-multiple") |> + httr2::url_parse() + urls <- purrr::map(split_list, + function(a, base_url){ + base_url$query <- as.list(a) + httr2::url_build(base_url) + }, + base_url = base_url) |> + unlist() + search_terms <- purrr::map(split_list, + function(a){glue::glue_collapse(a, sep = "_")}) |> + unlist() + + # build object and return + list(type = "metadata/taxa-multiple", + url = tibble::tibble(url = urls, + search_term = search_terms), + headers = build_headers()) +} + +#' Internal function to create an identifiers query +#' @noRd +#' @keywords Internal +capture_identifiers <- function(.query){ + if(is.null(.query$filter)){ + url_list <- url_lookup("metadata/identifiers") + names(url_list) <- "no-name-supplied" + }else{ + search_terms <- .query$filter$value + query <- as.list(search_terms) + base_url <- url_lookup("metadata/identifiers") + # create query urls + if(grepl("api.gbif.org", base_url)){ + base_url <- utils::URLdecode(base_url) + urls <- glue::glue(base_url, id = query) |> + unlist() + }else{ + base_url <- httr2::url_parse(base_url) + urls <- purrr::map(query, + function(a, base_url){ + names(a) <- "taxonID" + base_url$query <- as.list(a) + httr2::url_build(base_url) + }, + base_url = base_url) |> + unlist() + } + } + # build object and return + list(type = "metadata/identifiers", + url = tibble::tibble(url = urls, + search_term = search_terms), + headers = build_headers()) |> + as_query() +} + +#' Internal function to accept only specific taxon ranks for searching +#' @noRd +#' @keywords Internal +accepted_ranks <- function(){ + if(is_gbif()){ + # https://techdocs.gbif.org/en/openapi/v1/species#/Searching%20names/matchNames + c("kingdom", + "phylum", + "class", + "order", + "superfamily", + "family", + "subfamily", + "tribe", + "subtribe", + "genus", + "species") + }else{ + # https://docs.ala.org.au/openapi/index.html?urls.primaryName=namematching#/Taxonomy%20search/match_2 + c("kingdom", + "phylum", + "class", + "order", + "superfamily", + "family", + "genus", + "specificEpithet", + "infraspecificEpithet") + } +} diff --git a/R/check.R b/R/check.R index 5af19d91..5205e157 100644 --- a/R/check.R +++ b/R/check.R @@ -2,27 +2,48 @@ #' Called exclusively by `atlas_` functions #' @noRd #' @keywords Internal -check_atlas_inputs <- function(args){ +check_atlas_inputs <- function(args, + error_call = rlang::caller_env()){ if(!is.null(args$request)){ - check_data_request(args$request) - update_data_request(args$request, args[-1]) + if(!inherits(args$request, "data_request")){ + c("Argument `.query` requires an object of type `data_request`.", + i = "You can create this object using `galah_call()`.", + i = "Did you specify the incorrect argument?") |> + cli::cli_abort(call = error_call) + } + request_obj <- args$request }else{ - do.call(galah_call, args) + request_obj <- galah_call() } + added_arguments <- args[-1] + added_arguments <- added_arguments[!(purrr::map(added_arguments, is.null) |> unlist())] + if(length(added_arguments) > 0){ + for(i in seq_along(added_arguments)){ + request_obj <- do.call(update_request_object, + append(list(x = request_obj), added_arguments[i])) + } + } + request_obj } -#' Internal function to check for `data_request`s +#' Internal function to lookup requests for authentication +#' Note this is currently only called on `data_request` objects, and +#' then only before parsing #' @noRd #' @keywords Internal -check_data_request <- function(request, error_call = caller_env()){ - if(!inherits(request, "data_request")){ - bullets <- c( - "Argument `.query` requires an object of type `data_request`.", - i = "You can create this object using `galah_call()`.", - i = "Did you specify the incorrect argument?" - ) - abort(bullets, call = caller_env()) - } +check_authentication <- function(x){ + if(is.null(x$authenticate) & + isTRUE(potions::pour("user", "authenticate", .pkg = "galah")) & + x$type %in% c("occurrences")){ + x <- x |> authenticate() + } + atlas <- potions::pour("atlas", "region", .pkg = "galah") + if(atlas != "Australia" & + !is.null(x$authenticate)){ + cli::cli_warn("Authentication not supported for atlas {atlas}: skipping") + x$authenticate <- NULL + } + x } #' Internal function to check that the specified path exists, and if not, @@ -51,65 +72,99 @@ check_directory <- function(x){ #' Internal function to ensure a download file is given #' @noRd #' @keywords Internal -check_download_filename <- function(file, ext = "zip"){ +check_download_filename <- function(file, + ext = "zip"){ if(!is.null(file)){ # is `file` present - expected_suffix <- paste0(".", ext, "$") + expected_suffix <- glue::glue(".{ext}$") if(!grepl(expected_suffix, file)){ # expected suffix is missing if(grepl("\\.[[:alpha:]]{2,4}$", file)){ # does it have a different suffix? file <- gsub("\\.[[:alpha:]]{2,4}$", sub("\\$$", "", expected_suffix), file) # replace }else{ - file <- paste0(file, ".zip") # append + file <- glue::glue("{file}.zip") } } # no else{}, as all good here }else{ - current_time <- Sys.time() |> format("%Y-%m-%d_%H-%M-%S") - file <- paste0('data_', current_time, ".", ext) + current_time <- Sys.time() |> + format("%Y-%m-%d_%H-%M-%S") + file <- glue::glue("data_{current_time}.{ext}") } - cache_directory <- pour("package", "directory", .pkg = "galah") - glue("{cache_directory}/{file}") |> + cache_directory <- potions::pour("package", "directory", + .pkg = "galah") + glue::glue("{cache_directory}/{file}") |> as.character() # check_path()? # currently commented out in check.R } #' Subfunction to `check_login()` -#' @importFrom jsonlite fromJSON #' @noRd #' @keywords Internal -check_email <- function(.query){ +check_email <- function(.query, + call = rlang::caller_env()){ if(is_gbif()){ - email_text <- fromJSON(.query$body)$notificationAddresses + # actually we check the userpwd entry here + email_text <- .query$options$userpwd + if(email_text == ":"){ + abort_email_missing(error_call = call) + } }else{ - email_text <- url_parse(.query$url)$query$email - } - if(is.null(email_text)) { - abort_email_missing() - }else if(email_text == ""){ - abort_email_missing() + # use purrr::pluck() to search for named slots + # base parsing captures `email_notify` and is therefore unrelable + email_text <- httr2::url_parse(.query$url) |> + purrr::pluck("query", "email") + # set criteria for missingness + email_text_missing <- if(is.null(email_text)){ + TRUE + }else if(email_text == ""){ + TRUE + }else{ + FALSE + } + # authentication only acceptable alternative to email for ALA + if(is_ala()){ + authentication_missing <- is.null(.query$authenticate) + if(email_text_missing & authentication_missing){ + abort_email_missing(error_call = call) + } + }else{ + if(email_text_missing){ + abort_email_missing(error_call = call) + } + } } .query } #' Check files are filtered properly -#' @importFrom rlang abort #' @noRd #' @keywords Internal -check_files_filter <- function(x){ +check_files_filter <- function(x, + error_call = rlang::caller_env() + ){ if(!(x$variable %in% c("media"))){ - abort("Variable name must be a valid `type` accepted by `request_files()`.") + cli::cli_abort("Variable name must be a valid `type` accepted by `request_files()`.", + call = error_call) + } + if(is.null(x$data)){ + c("rhs must be a `tibble` containing media information.", + i = "at least, this tibble should contain `media_id` and `mime_type` columns.") |> + cli::cli_abort(call = error_call) } if(!inherits(x$data, "data.frame")){ - abort("rhs must be a `tibble` containing media information") + c("rhs must be a `tibble` containing media information.", + i = "at least, this tibble should contain `media_id` and `mime_type` columns.") |> + cli::cli_abort(call = error_call) } } #' check that objects passed within `galah_filter` have correct structure -#' @importFrom rlang abort #' @noRd #' @keywords Internal -check_filter_tibbles <- function(x){ # where x is a list of tibbles - syntax_valid <- lapply(x, function(a){ +check_filter_tibbles <- function(x, # where x is a list of tibbles + error_call = rlang::caller_env() + ){ + syntax_valid <- purrr::map(x, \(a){ if(length(colnames(a)) == 4){ all(colnames(a) %in% c("variable", "logical", "value", "query")) }else{ @@ -119,22 +174,18 @@ check_filter_tibbles <- function(x){ # where x is a list of tibbles unlist() |> all() if(!syntax_valid){ - abort("There was a problem with `filter`, did you use correct syntax?") + cli::cli_abort("There was a problem with `filter`, did you use correct syntax?", + call = error_call) } } #' Internal function to check whether fields are valid -#' @importFrom dplyr bind_rows -#' @importFrom dplyr pull -#' @importFrom glue glue_collapse -#' @importFrom glue glue_data -#' @importFrom httr2 url_parse -#' @importFrom rlang format_error_bullets #' @noRd #' @keywords Internal -check_fields <- function(.query) { +check_fields <- function(.query, + error_call = rlang::caller_env()) { - if(pour("package", "run_checks")){ + if(potions::pour("package", "run_checks")){ if(is_gbif()){ if(.query$type == "data/occurrences"){ check_result <- check_fields_gbif_predicates(.query) @@ -147,33 +198,42 @@ check_fields <- function(.query) { # error message if(any(!is.na(check_result))) { - returned_invalid <- tibble( - function_name = c("`galah_filter()`", "`galah_group_by()`"), + returned_invalid <- tibble::tibble( + function_name = c("`filter()`", "`group_by()`"), fields = check_result) |> tidyr::drop_na() glue_template <- "{returned_invalid$function_name}: {returned_invalid$fields}" - invalid_fields_message <- glue_data(returned_invalid, glue_template, .na = "") + invalid_fields_message <- glue::glue_data(returned_invalid, glue_template, .na = "") bullets <- c( "Can't use fields that don't exist.", i = "Use `search_all(fields)` to find a valid field ID.", - x = glue("Can't find field(s) in"), - glue(" ", format_error_bullets(invalid_fields_message)) + x = glue::glue("Can't find field(s) in"), + glue::glue(" ", + rlang::format_error_bullets(invalid_fields_message), + call = error_call) ) - abort(bullets) + cli::cli_abort(bullets) } } .query } #' Check whether fields match those requested, and if not, inform the user -#' @importFrom rlang warn -#' @importFrom rlang caller_env #' @noRd #' @keywords Internal -check_field_identities <- function(df, .query){ - if(!is.null(.query$fields) & pour("package", "run_checks")){ +check_field_identities <- function(df, + .query, + error_call = rlang::caller_env()){ + if(!is.null(.query$fields) & + potions::pour("package", "run_checks", .pkg = "galah") & + potions::pour("atlas", "region", .pkg = "galah") %in% c("Australia", "Spain", "Sweden") + # NOTE: last line included because the remaining atlases use different + # architecture which tends to mean queries are sent with non-DwC terms, + # but return DwC terms. This triggers warnings that are technically + # correct, but practically misleading. + ){ # get basic info n_fields <- length(.query$fields) field_names <- colnames(df) @@ -184,84 +244,99 @@ check_field_identities <- function(df, .query){ if(any(missing_check)){ missing_fields <- .query$fields[missing_check] names(missing_fields) <- rep("*", length(missing_fields)) - bullets <- c("The following fields, requested in your query, were not downloaded:", - missing_fields) - warn(bullets) + c("The following fields, requested in your query, were not downloaded:", + missing_fields) |> + cli::cli_warn(call = error_call) } # check for additions added_check <- !(field_names %in% .query$fields) if(any(added_check)){ added_fields <- field_names[added_check] - names(added_fields) <- rep("*", length(added_fields)) - bullets <- c("The following fields were downloaded, but weren't requested in your query:", - added_fields) - warn(bullets) + # if authentication has occurred, remove `sensitive_` fields + if(!is.null(.query$request$request$authenticate)){ + added_fields <- added_fields[!stringr::str_detect(added_fields, "^sensitive")] + } + # then, if any remain, warn + if(length(added_fields) > 0){ + names(added_fields) <- rep("*", length(added_fields)) + c("The following fields were downloaded, but weren't requested in your query:", + added_fields) |> + cli::cli_warn(call = error_call) + } } } df } #' sub-function to `check_fields()` for GBIF -#' @importFrom jsonlite fromJSON -#' @importFrom purrr pluck #' @noRd #' @keywords Internal check_fields_gbif_counts <- function(.query){ - # set fields to check against - valid_fields <- .query[["metadata/fields"]]$id + + # First get filters + # set fields that can be queried using predicates or downloaded + valid_download_fields <- .query[["metadata/fields"]] |> + dplyr::filter(.data$download_field == TRUE) |> + dplyr::pull("id") valid_assertions <- .query[["metadata/assertions"]]$id - valid_any <- c(valid_fields, valid_assertions) - url <- url_parse(.query$url[1]) - - # get fields from url - skip_fields <- c("limit", "facet", "facetLimit", - "taxonKey", "geometry", "geoDistance") # GBIF-specific fields - query_names <- names(url$query) - fields <- query_names[!(query_names %in% skip_fields)] - # check invalid fields + valid_any <- c(valid_download_fields, valid_assertions) + + # check for invalid fields in predicates + filter_vec <- unlist(.query$body$filter) + filter_keys <- stringr::str_detect(names(filter_vec), "key$") filter_invalid <- NA - if (length(fields) > 0) { + if(any(filter_keys)){ + fields <- filter_vec[filter_keys] |> + snake_to_camel_case() if (!all(fields %in% valid_any)) { invalid_fields <- fields[!(fields %in% valid_any)] - filter_invalid <- glue_collapse(invalid_fields, sep = ", ") + filter_invalid <- glue::glue_collapse(invalid_fields, sep = ", ") } } - - # check for invalid facets + + # then facets + # first extract facets group_by_invalid <- NA - if(any(query_names == "facet")){ - fields <- unlist(url$query[which(query_names == "facet")]) - if (!all(fields %in% valid_any)) { - invalid_fields <- fields[!(fields %in% valid_any)] - group_by_invalid <- glue_collapse(invalid_fields, sep = ", ") - } + if(!is.null(.query$body$group_by)){ + facets <- .query$body$group_by$name + # check for invalid facets + valid_search_fields <- .query[["metadata/fields"]] |> + dplyr::filter(.data$search_field == TRUE) |> + dplyr::pull("id") + if (!all(facets %in% valid_search_fields)) { + invalid_facets <- facets[!(facets %in% valid_search_fields)] + group_by_invalid <- glue::glue_collapse(invalid_facets, sep = ", ") + } } c(filter_invalid, group_by_invalid) } #' sub-function to `check_fields()` for GBIF -#' @importFrom jsonlite fromJSON -#' @importFrom purrr pluck #' @noRd #' @keywords Internal check_fields_gbif_predicates <- function(.query){ + # set fields to check against valid_fields <- .query[["metadata/fields"]]$id valid_assertions <- .query[["metadata/assertions"]]$id valid_any <- c(valid_fields, valid_assertions) |> camel_to_snake_case() |> toupper() + # extract fields - fields <- .query$body |> - fromJSON() |> - pluck("predicate", "predicates", "key") + predicates <- .query |> + purrr::pluck("body", "filter") |> + unlist() + keys <- grepl(".key$", names(predicates)) + fields <- predicates[keys] + # check invalid filter_invalid <- NA if (length(fields) > 0) { if (!all(fields %in% valid_any)) { invalid_fields <- fields[!(fields %in% valid_any)] - filter_invalid <- glue_collapse(invalid_fields, sep = ", ") + filter_invalid <- glue::glue_collapse(invalid_fields, sep = ", ") } } c(filter_invalid, NA) @@ -295,7 +370,7 @@ check_fields_la <- function(.query){ if (length(filters) > 0) { if (!all(filters %in% valid_any)) { invalid_fields <- filters[!(filters %in% valid_any)] - filter_invalid <- glue_collapse(invalid_fields, sep = ", ") + filter_invalid <- glue::glue_collapse(invalid_fields, sep = ", ") } } } @@ -303,9 +378,9 @@ check_fields_la <- function(.query){ # galah_group_by fields check group_by_invalid <- NA if(inherits(.query$url, "data.frame")){ - url <- url_parse(.query$url$url[1]) + url <- httr2::url_parse(.query$url$url[1]) }else{ - url <- url_parse(.query$url[1]) + url <- httr2::url_parse(.query$url[1]) } queries <- url$query if (!is.null(queries$facets)) { @@ -313,7 +388,7 @@ check_fields_la <- function(.query){ if (length(facets) > 0) { if (!all(facets %in% valid_any)) { invalid_fields <- facets[!(facets %in% valid_any)] - group_by_invalid <- glue_collapse(invalid_fields, sep = ", ") + group_by_invalid <- glue::glue_collapse(invalid_fields, sep = ", ") } } } @@ -323,8 +398,12 @@ check_fields_la <- function(.query){ # If no args are supplied, set default columns returned as group = "basic" +#' @param group supplied group names +#' @param n number of non-group arguments given +#' @noRd +#' @keywords Internal check_groups <- function(group, n){ - if(missing(group)){ + if(is.null(group)){ if(n < 1){ "basic" }else{ @@ -344,66 +423,28 @@ check_groups <- function(group, n){ #' function to replace search terms with identifiers via `search_taxa()` #' @noRd #' @keywords Internal -check_identifiers <- function(.query){ +check_identifiers <- function(.query, + error_call = rlang::caller_env()){ + # For GBIF, which uses predicates, we 'promote' taxonomic queries to 'predicates' if(is_gbif()){ - if(.query$type %in% c("data/occurrences", "data/species")){ - check_identifiers_gbif_predicates(.query) - }else{ - check_identifiers_gbif(.query) # mainly for `data/occurrences-count` - } + .query$body$identify <- .query$`metadata/taxa-single` + .query + # otherwise we replace "(`TAXON_PLACEHOLDER`)" }else{ - check_identifiers_la(.query) - } -} - -#' `check_identifiers()` for gbif -#' @noRd -#' @keywords Internal -check_identifiers_gbif <- function(.query){ - url <- url_parse(.query$url[1]) # FIXME: test if every >1 urls here - if(!is.null(url$query)){ - metadata_lookup <-grepl("metadata/taxa", names(.query)) - if(any(metadata_lookup)){ - identifiers <- .query[[which(metadata_lookup)[1]]] - taxon_query <- as.list(identifiers$taxon_concept_id) - names(taxon_query) <- rep("taxonKey", length(taxon_query)) - url$query <- c(taxon_query, - url$query[names(url$query) != "taxonKey"]) - .query$url[1] <- url_build(url) - } + check_identifiers_la(.query, error_call) } - .query -} - -#' `check_identifiers()` for gbif occurrences -#' @noRd -#' @keywords Internal -check_identifiers_gbif_predicates <- function(.query){ - if(!is.null(.query$body)){ - metadata_lookup <-grepl("metadata/taxa", names(.query)) - if(any(metadata_lookup)){ - identifiers <- .query[[which(metadata_lookup)[1]]] - .query$body <- sub("`TAXON_PLACEHOLDER`", - identifiers$taxon_concept_id[1], - .query$body) - } - } - .query } #' `check_identifiers()` for living atlases -#' @importFrom httr2 url_build -#' @importFrom httr2 url_parse -#' @importFrom rlang abort -#' @importFrom stringr str_replace_all #' @noRd #' @keywords Internal -check_identifiers_la <- function(.query, error_call = caller_env()){ +check_identifiers_la <- function(.query, + error_call = rlang::caller_env()){ # FIXME: test if every >1 urls here if(inherits(.query$url, "data.frame")){ - url <- url_parse(.query$url$url[1]) + url <- httr2::url_parse(.query$url$url[1]) }else{ - url <- url_parse(.query$url[1]) + url <- httr2::url_parse(.query$url[1]) } queries <- url$query if(!is.null(queries$fq)){ @@ -414,18 +455,20 @@ check_identifiers_la <- function(.query, error_call = caller_env()){ # End query early when no taxonomic search terms were matched if (nrow(identifiers) > 0 && !("taxon_concept_id" %in% colnames(identifiers))) { - abort("No valid taxonomic identifiers detected.", call = error_call) + cli::cli_abort("No valid taxonomic identifiers detected.", + call = error_call) } taxa_ids <- build_taxa_query(identifiers$taxon_concept_id) - queries$fq <- str_replace_all(queries$fq, - "\\(`TAXON_PLACEHOLDER`\\)", - taxa_ids) + queries$fq <- stringr::str_replace_all(queries$fq, + "\\(`TAXON_PLACEHOLDER`\\)", + taxa_ids) url$query <- queries - .query$url[1] <- url_build(url) + .query$url[1] <- httr2::url_build(url) }else{ # this only happens if there is a bug earlier in the code - abort("The query has a taxonomic placeholder, but no taxon search has been run.") + cli::cli_abort("The query has a taxonomic placeholder, but no taxon search has been run.", + call = error_call) } } }else{ @@ -435,10 +478,11 @@ check_identifiers_la <- function(.query, error_call = caller_env()){ if(any(metadata_lookup)){ identifiers <- .query[[which(metadata_lookup)[1]]] taxa_id <- utils::URLencode(identifiers$taxon_concept_id[1], - reserved = TRUE) + reserved = TRUE) .query$url[1] <- sub("%60TAXON_PLACEHOLDER%60", taxa_id, .query$url[1]) }else{ - abort("The query has a taxonomic placeholder, but no taxon search has been run.") + cli::cli_abort("The query has a taxonomic placeholder, but no taxon search has been run.", + call = error_call) } } } @@ -449,22 +493,24 @@ check_identifiers_la <- function(.query, error_call = caller_env()){ #' Called by `compute()` #' @noRd #' @keywords Internal -#' @importFrom rlang caller_env -check_login <- function(.query, error_call = caller_env()) { +check_login <- function(.query, + error_call = rlang::caller_env()) { # Check for valid email for occurrences or species queries for all providers - if(.query$type == "data/occurrences" | .query$type == "data/species"){ - switch(pour("atlas", "region"), - "United Kingdom" = {}, - "Global" = {check_email(.query); check_password(.query)}, - check_email(.query)) + if(is_gbif()){ + if(grepl("^data", .query$type)){ + check_email(.query, call = error_call) + check_password(.query, call = error_call) + } + }else{ + if(.query$type %in% c("data/occurrences", "data/species") & + is.null(.query$request$authenticate) # i.e. only validate if authenticate = FALSE + ){ + switch(potions::pour("atlas", "region"), + "United Kingdom" = {}, + check_email(.query, call = error_call)) + } } .query - # ALA requires an API key - # } else if (pour("atlas", "acronym") == "ALA") { - # if (is.null(.query$headers$`x-api-key`) | .query$headers$`x-api-key` == "") { - # abort_api_key_missing() - # } - # } } #' Internal function to convert multi-value media fields to list-columns @@ -491,19 +537,20 @@ check_media_cols <- function(.query){ #' @param .query a `query` object #' @noRd #' @keywords Internal -check_media_cols_present <- function(.query, error_call = caller_env()){ +check_media_cols_present <- function(.query, + error_call = rlang::caller_env()){ fields <- .query |> - pluck("url") |> - url_parse() |> - pluck("query", "fields") |> + purrr::pluck("url") |> + httr2::url_parse() |> + purrr::pluck("query", "fields") |> strsplit(",") |> - pluck(1) + purrr::pluck(1) fields_check <- image_fields() %in% fields if(!any(fields_check)){ - abort(c("No media fields requested.", - i = "Use `select()` to specify which media fields are required.", - i = "Valid fields are 'images', 'videos' and 'sounds'."), - call = error_call) + c("No media fields requested.", + i = "Use `select()` to specify which media fields are required.", + i = "Valid fields are 'images', 'videos' and 'sounds'.") |> + cli::cli_abort(call = error_call) }else{ image_fields()[fields_check] } @@ -512,63 +559,61 @@ check_media_cols_present <- function(.query, error_call = caller_env()){ #' Internal function called by `filter()` et al #' @noRd #' @keywords Internal -check_named_input <- function(dots){ +check_named_input <- function(dots, + error_call = rlang::caller_env()){ name_length <- any(length(names(dots) > 0)) & any(names(dots) != "") if(name_length){ - bullets <- c( - "We detected a named input.", - i = "This usually means that you've used `=` instead of `==`.") - abort(bullets) + c("We detected a named input.", + i = "This usually means that you've used `=` instead of `==`.") |> + cli::cli_abort(call = error_call) } } #' Check whether geolocate functions have >1 argument -#' @importFrom rlang warn #' @noRd #' @keywords Internal -check_n_inputs <- function(dots, error_call = caller_env()) { +check_n_inputs <- function(dots, + error_call = rlang::caller_env()) { if(length(dots) > 1){ n_geolocations <- length(dots) - bullets <- c( - "More than 1 spatial area provided.", - "*" = glue("Using first location, ignoring additional {n_geolocations - 1} location(s).") - ) - warn(bullets, call = error_call) + c("More than 1 spatial area provided.", + "*" = "Using first location, ignoring additional {n_geolocations - 1} location(s).") |> + cli::cli_warn(call = error_call) } } #' Internal function to ensure correct data extracted from API for LA/GBIF #' It makes all calls consistent so we only need one queue checking function -#' @importFrom stringr str_trim #' @noRd #' @keywords Internal -check_occurrence_response <- function(.query){ +check_occurrence_response <- function(.query, + error_call = rlang::caller_env()){ names(.query) <- camel_to_snake_case(names(.query)) if (!is.null(.query$status_code)) { error_type <- sub("\\:.*", "", .query$message) |> - str_trim() + stringr::str_trim() bullets <- c( "There was a problem with your query.", - "*" = glue("message: {.query$message}")) + "*" = glue::glue("message: {.query$message}")) switch(as.character(error_type), - "500" = {abort(bullets, - call = caller_env())}, - "403" = {abort(c(bullets, - i = "Is the email you provided to `galah_config()` registered with the selected atlas?"), - call = caller_env())}, - "404" = {abort(c(bullets, - i = "Is the email you provided to `galah_config()` registered with the selected atlas?"), - call = caller_env())}, - "504" = {abort(c(bullets, - i = "This usually means that the selected API is down.", - i = "If you continue to receive this error, please email support@ala.org.au"), - call = caller_env())}, - abort("Aborting for unknown reasons.", # FIXME - call = caller_env())) + "500" = {cli::cli_abort(bullets, + call = error_call)}, + "403" = {cli::cli_abort(c(bullets, + i = "Is the email you provided to `galah_config()` registered with the selected atlas?"), + call = error_call)}, + "404" = {cli::cli_abort(c(bullets, + i = "Is the email you provided to `galah_config()` registered with the selected atlas?"), + call = error_call)}, + "504" = {cli::cli_abort(c(bullets, + i = "This usually means that the selected API is down.", + i = "If you continue to receive this error, please email support@ala.org.au"), + call = error_call)}, + cli::cli_abort("Aborting for unknown reasons.", # FIXME + call = error_call)) } else { if (.query$status %in% c("finished", # ALA "SUCCEEDED") # GBIF @@ -586,8 +631,7 @@ check_occurrence_response <- function(.query){ } # convert `key` to `status_url` if(is.null(.query$status_url) & !is.null(.query$key)){ - .query$status_url <- paste0("https://api.gbif.org/v1/occurrence/download/", - .query$key) + .query$status_url <- glue::glue("https://api.gbif.org/v1/occurrence/download/{.query$key}") } # add `queue_size` if(is.null(.query$queue_size)){ @@ -600,7 +644,9 @@ check_occurrence_response <- function(.query){ #' @noRd #' @keywords Internal check_occurrence_status <- function(.query){ - list(url = .query$status_url) |> + list(type = "data/occurrences", + url = .query$status_url) |> + as_query() |> query_API() |> as.list() |> check_occurrence_response() @@ -619,10 +665,10 @@ check_occurrence_status <- function(.query){ #' @noRd #' @keywords Internal check_password <- function(.query, - error_call = caller_env()){ + call = rlang::caller_env()){ if (.query$options$userpwd == ":") { - abort("GBIF requires a username and password to download occurrences or species.", - call = error_call) + cli::cli_abort("GBIF requires a username and password to download occurrences or species.", + call = call) } } @@ -647,21 +693,19 @@ check_password <- function(.query, # } #' Internal function to check a supplied profile is valid -#' @importFrom glue glue -#' @importFrom rlang abort #' @noRd #' @keywords Internal -check_profiles <- function(.query, error_call = caller_env()){ +check_profiles <- function(.query, + error_call = rlang::caller_env()){ if(!inherits(.query$url, "data.frame")){ - query <- url_parse(.query$url[1])$query + query <- httr2::url_parse(.query$url[1])$query if(!is.null(query$qualityProfile)){ profile <- query$qualityProfile - if(!profile %in% .query[["metadata/profiles"]]$shortName){ - bullets <- c( - "Unrecognised profile requested.", + if(!profile %in% .query[["metadata/profiles"]]$short_name){ + c("Unrecognised profile requested.", i = "See `?show_all(profiles)` for valid profiles.", - x = glue("Can't find profile `{profile}` for specified atlas.")) - abort(bullets, call = error_call) + x = "Can't find profile `{profile}` for specified atlas.") |> + cli::cli_abort(call = error_call) }else{ .query } @@ -674,28 +718,27 @@ check_profiles <- function(.query, error_call = caller_env()){ } #' Internal function to check that a reason code is valid -#' @importFrom glue glue -#' @importFrom rlang abort #' @noRd #' @keywords Internal -check_reason <- function(.query, error_call = caller_env()){ - if(atlas_supports_reasons_api()) { +check_reason <- function(.query, + error_call = rlang::caller_env()){ + if(reasons_supported()) { if(.query$type %in% c("data/occurrences", "data/species")){ - query <- url_parse(.query$url)$query + query <- httr2::url_parse(.query$url)$query if(is.null(query$reasonTypeId)){ - bullets <- c("Missing a valid download reason.", - i = "See `show_all(reasons)`.", - i = "Use `galah_config(download_reason_id = ...)` to set a download reason.") - abort(bullets, call = error_call) + c("Missing a valid download reason.", + i = "See `show_all(reasons)`.", + i = "Use `galah_config(download_reason_id = ...)` to set a download reason.") |> + cli::cli_abort(call = error_call) }else{ user_reason <- query$reasonTypeId valid_reasons <- .query[["metadata/reasons"]]$id if(!(user_reason %in% valid_reasons)){ - bullets <- c( + c( "Invalid download reason ID.", i = "Use `show_all(reasons)` to see all valid reasons.", - x = glue("\"{user_reason}\" does not match an existing reason ID.")) - abort(bullets, call = error_call) + x = "\"{user_reason}\" does not match an existing reason ID.") |> + cli::cli_abort(call = error_call) } } } @@ -705,19 +748,17 @@ check_reason <- function(.query, error_call = caller_env()){ #' Check that `select()` quosures can be parsed correctly #' NOTE: much of this content was previously in `parse_select()` (defunct) -#' @importFrom dplyr all_of -#' @importFrom dplyr filter -#' @importFrom httr2 url_parse -#' @importFrom httr2 url_build -#' @importFrom rlang is_quosure #' @noRd #' @keywords Internal -check_select <- function(.query){ - if(any(names(.query) == "select")){ - if(is_gbif()){ - inform(c("skipping `select()`:", - i = "This function is not supported by the GBIF API v1")) - }else{ +check_select <- function(.query, + error_call = rlang::caller_env()){ + if(any(names(.query$request) == "select")){ + if(!(is_gbif() & stringr::str_detect(.query$type, "^data"))){ + # cli::cli({ + # cli::cli_text("Skipping `select()`.") + # cli::cli_bullets(c(i = "This function is not supported by the GBIF occurrences downloads API v1.")) + # }) + # }else{ # 1. build df to `select` from valid_fields <- .query[["metadata/fields"]]$id valid_assertions <- .query[["metadata/assertions"]]$id @@ -727,29 +768,34 @@ check_select <- function(.query){ as.data.frame() # 2. parse groups - group_initial <- .query$select$group + group_initial <- .query$request$select$group # new step to avoid calling `show_all_assertions()` internally group <- group_initial[group_initial != "assertions"] if(length(group) > 0){ - group_cols <- lapply(group, preset_groups) |> + group_cols <- purrr::map(group, preset_groups) |> unlist() - group_names <- tidyselect::eval_select(all_of(group_cols), data = df) |> + group_names <- tidyselect::eval_select(dplyr::all_of(group_cols), + data = df) |> names() # note: technically `group_names` and `group_cols` are identical # BUT `eval_select()` will fail if invalid columns are given }else{ group_names <- NULL } - + # 3. parse quosures to get list of field names - check_quosures <- lapply(.query$select, is_quosure) |> - unlist() - dots <- .query$select[check_quosures] - dot_names <- lapply(dots, function(a){ - tidyselect::eval_select(a, data = df) |> - names() - }) |> - unlist() + if(length(.query$request$select$quosure) > 0){ + dot_names <- purrr::map(.query$request$select$quosure, + function(a){ + tidyselect::eval_select(a, + data = df, + error_call = error_call) |> + names() + }) |> + unlist() + }else{ + dot_names <- c() + } # 3a: set 'identifier' column name id_col <- default_columns()[1] @@ -785,10 +831,10 @@ check_select <- function(.query){ # having e.g. media columns _before_ `recordID` causes the download to fail field_values <- unique(c(group_names, individual_cols)) if(is.null(field_values)){ - bullets <- c("No fields selected", - i = "Please specify a valid set of fields in `select()`", - i = "You can look up valid fields using `show_all(fields)`") - abort(bullets) + c("No fields selected", + i = "Please specify a valid set of fields in `select()`", + i = "You can look up valid fields using `show_all(fields)`") |> + cli::cli_abort(call = error_call) } if(any(field_values == id_col)){ field_values <- c(id_col, field_values[field_values != id_col]) # recordID needs to be first @@ -800,21 +846,21 @@ check_select <- function(.query){ assertion_text <- "includeall" }else{ if(any(is_assertion)){ - assertion_text <- paste(field_values[is_assertion], collapse = ",") + assertion_text <- glue::glue_collapse(field_values[is_assertion], + sep = ",") }else{ assertion_text <- "none" } } - field_text <- paste(field_values[!is_assertion], - collapse = ",") + field_text <- glue::glue_collapse(field_values[!is_assertion], + sep = ",") - # 7. replace `SELECT_PLACEHOLDER` with valid query + # 7. replace `SELECT_PLACEHOLDER` and `ASSERTIONS_PLACEHOLDER` with valid queries # located in .query$url in query/fields - url <- url_parse(.query$url) # note: this assumes a single url every time + url <- httr2::url_parse(.query$url) # note: this assumes a single url every time url$query$fields <- field_text url$query$qa <- assertion_text - .query$url <- url_build(url) - .query$select <- NULL + .query$url <- httr2::url_build(url) } } .query @@ -823,13 +869,13 @@ check_select <- function(.query){ #' Check for valid `type` #' @noRd #' @keywords Internal -check_type_valid <- function(type, valid, error_call = caller_env()) { +check_type_valid <- function(type, + valid, + error_call = rlang::caller_env()) { if(!any(valid == type)){ - bullets <- c( - glue("Unrecognised metadata requested."), + c("Unrecognised metadata requested.", i = "See `?show_all()` for a list of valid metadata types.", - x = glue("Can't find metadata type `{type}`.") - ) - abort(bullets, call = error_call) + x = "Can't find metadata type `{type}`.") |> + cli::cli_abort(call = error_call) } } diff --git a/R/check_internal_cache.R b/R/check_internal_cache.R deleted file mode 100644 index a6eb1fdc..00000000 --- a/R/check_internal_cache.R +++ /dev/null @@ -1,56 +0,0 @@ -#' Internal function to store objects generated from some `request_metadata` calls -#' -#' This increases speed by ensuring that the atlas is only queried when needed. -#' When run with no arguments, it returns a list with currently stored objects. -#' When a named field is given, it stores that field in options("galah_internal") -#' @noRd -#' @keywords Internal -#' @importFrom potions pour -check_internal_cache <- function(...){ - - # set all options - ala_option_name <- "check_internal_cache" - current_options <- getOption(ala_option_name) - atlas <- pour("atlas", "region") - user_options <- list(...) - - # load an archived version as the default - default_options <- galah_internal_cached # stored in R/sysdata.rda - # get0("galah_internal_cached", envir = asNamespace("galah")) # alternate code - - # deal with different kinds of query - if (length(user_options) == 0 && !is.null(current_options)) { - return(current_options) - } - if (is.null(current_options)) { - ## galah options have not been set yet, so set them to the defaults - current_options <- default_options - ## set the global option - temp <- list(current_options) - names(temp) <- ala_option_name - options(temp) - return(current_options) - } else { - # check all the options are valid, if so, set as options - for (x in names(user_options)) { - current_options[[x]] <- user_options[[x]] - } - ## set the global option - temp <- list(current_options) - names(temp) <- ala_option_name - } - options(temp) -} - -#' Internal function to decide whether to update the internal cache -#' @noRd -#' @keywords Internal -internal_cache_update_needed <- function(function_name){ - df <- check_internal_cache()[[function_name]] - is_local <- !is.null(attr(df, "ARCHIVED")) - is_wrong_atlas <- attr(df, "region") != pour("atlas", "region") - is_too_short <- nrow(df) < 10 - result <- is_local | is_wrong_atlas | is_too_short # if any, update is needed - if(length(result) < 1){result <- TRUE} # bug catcher - result -} \ No newline at end of file diff --git a/R/check_queue.R b/R/check_queue.R index f9e0f5a7..252c4aab 100644 --- a/R/check_queue.R +++ b/R/check_queue.R @@ -5,13 +5,12 @@ check_queue <- function(.query, wait = FALSE){ # process supplied object if(.query$status == "incomplete"){ download_response <- c(list(type = .query$type), - check_occurrence_status(.query)) - class(download_response) <- "computed_query" + check_occurrence_status(.query)) |> + structure(class = "computed_query") if(wait){ - download_response <- c(list(type = .query$type), - check_queue_loop(.query)) - class(download_response) <- "computed_query" - download_response + c(list(type = .query$type), + check_queue_loop(.query)) |> + structure(class = "computed_query") }else{ download_response } @@ -21,8 +20,6 @@ check_queue <- function(.query, wait = FALSE){ } #' Internal function to check queue status, with rate limiting -#' @importFrom purrr rate_delay -#' @importFrom purrr rate_sleep #' @noRd #' @keywords Internal check_queue_loop <- function(.query){ @@ -30,9 +27,10 @@ check_queue_loop <- function(.query){ current_queue <- .query$queue_size continue <- TRUE iter <- 1 - verbose <- pour("package", "verbose", .pkg = "galah") + verbose <- potions::pour("package", "verbose", .pkg = "galah") if(verbose){ - inform(glue("Current queue length: {current_queue}")) + position <- glue::glue("Current queue length: {current_queue}") + cli::cli_text(position) } while(continue == TRUE){ .query <- check_occurrence_status(.query) @@ -40,13 +38,16 @@ check_queue_loop <- function(.query){ if(continue){ iter <- iter + 1 if(iter > 99){ - inform(c("No data were returned after 100 tries.", - i = "If you have saved this output using e.g. `x <- collect(.query)`,", - i = "you can try again later using `collect(x)`")) + cli::cli({ + cli::cli_text("No data were returned after 100 tries.") + c(i = "If you have saved this output using e.g. `x <- collect(.query)`,", + i = "you can try again later using `collect(x)`") |> + cli::cli_bullets() + }) return(.query) }else{ current_queue <- check_queue_size(.query, current_queue) - rate_sleep(rate_object, quiet = verbose) + purrr::rate_sleep(rate_object, quiet = verbose) } }else{ return(.query) @@ -55,25 +56,24 @@ check_queue_loop <- function(.query){ } #' Internal function for rate limiting -#' @importFrom purrr rate_backoff #' @noRd #' @keywords Internal set_rate <- function(){ - rate_backoff(pause_base = 0.5, - pause_cap = 60, - max_times = 100, - jitter = FALSE) + purrr::rate_backoff(pause_base = 0.5, + pause_cap = 60, + max_times = 100, + jitter = FALSE) } #' Internal function to check queue size #' @noRd #' @keywords Internal check_queue_size <- function(.query, current_queue){ - verbose <- pour("package", "verbose", .pkg = "galah") + verbose <- potions::pour("package", "verbose", .pkg = "galah") if(.query$queue_size < current_queue & .query$queue_size > 0){ current_queue <- .query$queue_size if(verbose){ - inform(glue("Queue length: {current_queue}")) + cli::cli_text("Queue length: {current_queue}") } }else{ if(verbose){cat("-")} diff --git a/R/collapse.R b/R/collapse.R deleted file mode 100644 index c836e370..00000000 --- a/R/collapse.R +++ /dev/null @@ -1,71 +0,0 @@ -#' @title Generate a query -#' @description `collapse()` constructs a valid query so it can be -#' inspected before being sent. It typically occurs at the end of a pipe, -#' traditionally begun with `galah_call()`, that is used to define a query. -#' As of version 2.0, objects of class `data_request` (created using -#' `request_data()`), `metadata_request` (from `request_metadata()`) or -#' `files_request` (from `request_files()`) are all supported by `collapse()`. -#' Any of these objects can be created using `galah_call()` via the `method` -#' argument. -#' @name collapse.data_request -#' @order 1 -#' @param x An object of class `data_request`, `metadata_request` or -#' `files_request` -#' @param ... Arguments passed on to other methods -#' @param .expand Logical: should the `query_set` be returned? This object -#' shows all the requisite data needed to process the supplied query. Defaults -#' to `FALSE`; if `TRUE` will append the `query_set` to an extra slot in the -#' `query` object. -#' @param mint_doi Logical: should a DOI be minted for this download? Only -#' applies to `type = "occurrences"` when atlas chosen is "ALA". -#' @return An object of class `query`, which is a list-like object containing at -#' least the slots `type` and `url`. -#' @export -collapse.data_request <- function(x, ..., mint_doi, .expand = FALSE){ - query_set <- build_query_set(x, - mint_doi = mint_doi, - ...) - result <- query_set |> - build_checks() |> - parse_checks() |> - parse_query() - if(.expand){ - result$call <- query_set - } - result -} - -# if calling `collapse()` after `request_metadata()` -#' @rdname collapse.data_request -#' @order 2 -#' @export -collapse.metadata_request <- function(x, .expand = FALSE, ...){ - query_set <- build_query_set(x, ...) - result <- query_set |> - build_checks() |> - parse_checks() |> - parse_query() - if(.expand){ - result$call <- query_set - } - result -} - -# if calling `collapse()` after `request_files()` -#' @rdname collapse.data_request -#' @order 3 -#' @param thumbnail Logical: should thumbnail-size images be returned? Defaults -#' to `FALSE`, indicating full-size images are required. -#' @importFrom purrr pluck -#' @export -collapse.files_request <- function(x, - # prefix? could be useful for file names - thumbnail = FALSE, - ... - ){ - build_query_set(x, - thumbnail = thumbnail, - ...) |> - # note: files requests do not need to call build_checks() - pluck(!!!list(1)) -} diff --git a/R/collapse_checks.R b/R/collapse_checks.R new file mode 100644 index 00000000..56c6f2d3 --- /dev/null +++ b/R/collapse_checks.R @@ -0,0 +1,133 @@ +#' Internal function to build necessary metadata into a single object +#' I.e. to parse a `query_set` object within `collapse()` +#' @noRd +#' @keywords Internal +collapse_build_checks <- function(.query){ + # get basic description of `query_set` object + n <- length(.query) + names_vec <- purrr::map(.query, + \(a){purrr::pluck(a, "type")}) |> + unlist() + data_lookup <- stringr::str_detect(names_vec, "^data") + if(any(data_lookup)){ + data_names <- names_vec[data_lookup] + # parse any `metadata` + metadata_results <- collapse_run_metadata(names_vec, .query) + # parse `data`, including supplied metadata + # this assumes only one `data` field is available per `query_set` + .query[[which(data_lookup)]] |> + collapse_add_metadata(metadata_results) + }else if(any(names_vec %in% c("metadata/fields-unnest", + "metadata/profiles-unnest", + "metadata/taxa-unnest"))){ + # this code accounts for `unnest` functions that require lookups + # metadata/fields-unnest calls check_fields(), requiring fields and assertions + # metadata/profiles-unnest calls profile_short_name(), which requires profiles + if(length(.query) > 1){ + metadata_results <- collapse_run_metadata(names_vec, .query) + .query[[2]] |> + collapse_add_metadata(metadata_results) + }else{ + .query[[1]] + } + }else{ + # if no metadata are needed, return .query unaltered + .query[[1]] + } +} + +#' Internal function to run metadata checks +#' This is useful for testing, particularly in testing `galah_select()` +#' called by `collapse()` +#' @noRd +#' @keywords Internal +collapse_run_checks <- function(.query, + error_call = rlang::caller_env()){ + + # "data/" functions require pre-processing of metadata, + if(stringr::str_detect(.query$type, "^data/") & .query$type != "data/occurrences-doi"){ + # taxon concept ID must always be evaluated + .query <- check_identifiers(.query, error_call) + # login should only be evaluated for species and occurrence + if(.query$type %in% c("data/occurrences", "data/species")){ + .query <- check_login(.query, error_call) + } + + # check_select() is specifically for parsing fields into urls, + # should only be called for occurrences + if(.query$type %in% c("data/occurrences", "data/occurrences-glimpse")){ + .query <- check_select(.query, error_call) + } + # NOTE: the naming convention here is misleading; should probably be `parse_select()` + + # after checking, for type = "glimpse", we need to rename the fields query + if(.query$type == "data/occurrences-glimpse"){ + url <- httr2::url_parse(.query$url) + query_names <- names(url$query) + if(any(query_names == "fields")){ + names(url$query)[which(query_names == "fields")] <- "fl" + } + .query$url <- httr2::url_build(url) + } + + # run remaining checks, if requested by the user + if(potions::pour("package", "run_checks")) { + .query <- .query |> + check_reason(error_call) |> + check_fields(error_call) |> + check_profiles(error_call) + } + # as do `unnest()`/`show_values()` functions + }else if(stringr::str_detect(.query$type, "-unnest$")){ + # FIXME: decide which checks should be subject to `if(potions::pour("package", "run_checks"))` + .query <- .query |> + check_identifiers() |> + check_fields() + } + collapse_remove_metadata(.query) + # special cases: + # distributions + # if(.query$type == "data/distributions" & + # !is.null(.query[["metadata/distributions"]])){ + # .query$url <- tibble(url = glue(utils::URLdecode(.query$url), + # id = .query[["metadata/distributions"]]$id)) + # } +} + +#' Internal function to collapse metadata +#' @noRd +#' @keywords Internal +collapse_run_metadata <- function(names_vec, .query){ + metadata_lookup <- grepl("^metadata", names_vec) & + !grepl("-unnest$", names_vec) # unnest functions only parse in collect() + if(any(metadata_lookup)){ + metadata_names <- names_vec[metadata_lookup] + metadata_results <- purrr::map(.query[which(metadata_lookup)], collect) + names(metadata_results) <- metadata_names + metadata_results + }else{ + NULL + } +} + +#' Internal function to pass metadata to `collapse()` functions +#' called by `compute.query_set()` +#' @noRd +#' @keywords Internal +collapse_add_metadata <- function(query, meta){ + c(query, meta) |> + as_query() +} + +#' Internal function to reduce size of internally computed objects +#' called by `compute.query()` +#' @noRd +#' @keywords Internal +collapse_remove_metadata <- function(.query){ + names_lookup <- stringr::str_detect( names(.query), "^metadata/") + if(any(names_lookup)){ + as_query(.query[!names_lookup]) + }else{ + as_query(.query) + } +} \ No newline at end of file diff --git a/R/collapse_distributions.R b/R/collapse_distributions.R deleted file mode 100644 index 1fcc75aa..00000000 --- a/R/collapse_distributions.R +++ /dev/null @@ -1,27 +0,0 @@ -#' Internal function to `collapse` for type `data/distributions` -#' @importFrom rlang abort -#' @noRd -#' @keywords Internal -collapse_distributions <- function(.query){ - identify_supplied <- !is.null(.query$identify) - filter_supplied <- !is.null(.query$filter) - if(identify_supplied & filter_supplied){ - abort("`collapse(type = 'distributions')` only accepts one of `filter()` or `identify()`, not both") - } - if(identify_supplied){ - url <- url_lookup("data/distributions-taxa", lsid = "`TAXON_PLACEHOLDER`") - }else if(filter_supplied){ - values <- strsplit(.query$filter$value, "\\|")[[1]] - urls <- map(values, \(x){ - url_lookup("data/distributions-id", id = x)}) |> - unlist() - url <- tibble(url = urls) - }else{ # i.e. neither supplied, get all distributions via ID column - url <- url_lookup("data/distributions-id") - } - result <- list(type = "data/distributions", - url = url, - headers = build_headers()) - class(result) <- "query" - return(result) -} \ No newline at end of file diff --git a/R/collapse_media.R b/R/collapse_media.R deleted file mode 100644 index e9128a8b..00000000 --- a/R/collapse_media.R +++ /dev/null @@ -1,134 +0,0 @@ -#' Internal version of `collapse()` for `request_metadata(type = "media")` -#' @param .query An object of class `metadata_request` (from `request_metadata()`) -#' @importFrom jsonlite toJSON -#' @importFrom rlang abort -#' @importFrom tibble tibble -#' @noRd -#' @keywords Internal -collapse_media <- function(.query){ - # NOTE: - # this function currently assumes that the user has passed an occurrence - # tibble verbatim to filter, i.e. - # `request_metadata() |> filter(media = occurrences) |> collapse()` - # It may be useful to support passing of media_ids directly, e.g. - # `request_metadata() |> filter(media = occurrences$images`) |> collapse() - if(is.null(.query$filter)){ - abort("Requests for metadata of type = \"media\" must have information passed via `filter()`") - } - occ <- .query$filter$data - if(any(colnames(occ) %in% c("images", "videos", "sounds"))){ # Australia, Sweden, Spain - media_cols <- which(colnames(occ) %in% c("images", "videos", "sounds")) - media_ids <- do.call(c, occ[, media_cols]) |> - unlist() - media_ids <- media_ids[!is.na(media_ids)] - names(media_ids) <- NULL - }else if(any(colnames(occ) == "all_image_url")){ # Austria, Sweden, UK - media_ids <- pull(occ, "all_image_url") - media_ids <- media_ids[!is.na(media_ids)] - names(media_ids) <- NULL - }else{ - abort("Media metadata not found in supplied tibble") - } - - result <- list( - type = "metadata/media", - url = url_lookup("metadata/media"), - headers = build_headers(), - body = toJSON(list(imageIds = media_ids)), - filter = .query$filter) - class(result) <- "query" - return(result) -} - -#' Internal version of `collapse()` for `request_files(type = "media")` -#' @param .query An object of class `files_request` (from `request_files()`) -#' @importFrom rlang abort -#' @importFrom tibble tibble -#' @importFrom stringr str_detect -#' @noRd -#' @keywords Internal -collapse_media_files <- function(.query, - thumbnail = FALSE - ){ - # handle filters - if(is.null(.query$filter)){ - abort("`collapse()` requires a `filter()` argument to function.") - } - df <- .query$filter - if(any(colnames(df) == "media_id")){ - identifiers <- df$media_id - }else if(any(colnames(df) == "image_id")){ - identifiers <- df$image_id - }else{ - abort("No valid identifiers found in supplied data.") - } - path <- build_file_path(ids = identifiers, types = df$mimetype) - if(any(colnames(df) == "image_url")){ - url <- df$image_url - }else{ - url <- url_lookup("files/images", id = identifiers) - } - # handle thumbnails - if(thumbnail){ - url <- gsub("/original", "/thumbnail", url) - } - - # create result - result <- list( - type = "files/media", - url = tibble(url = url, path = path), - headers = build_headers()) - - class(result) <- "query" - return(result) -} - -#' Internal function to get media metadata, and create a valid file name -#' @noRd -#' @keywords Internal -build_media_id <- function(df){ - # create a column that includes media identifiers, regardless of which column they are in - ## NOTE: I haven't found good tidyverse syntax for this yet - x <- rep(NA, nrow(df)) - if(any(colnames(df) == "videos")){ - videos <- !is.na(df$videos) - if(any(videos)){x[videos] <- df$videos[videos]} - } - if(any(colnames(df) == "sounds")){ - sounds <- !is.na(df$sounds) - if(any(sounds)){x[sounds] <- df$sounds[sounds]} - } - if(any(colnames(df) == "images")){ - images <- !is.na(df$images) - if(any(images)){x[images] <- df$images[images]} - } - x -} - -#' build file paths that include 1. path, 2. file name, 3. correct extension -#' @importFrom glue glue -#' @noRd -#' @keywords Internal -build_file_path <- function(ids, types){ - path <- pour("package", "directory", .pkg = "galah") - ext <- build_file_extension(types) - glue("{path}/{ids}.{ext}") |> as.character() -} - -#' get extensions for media files -#' @importFrom dplyr case_match -#' @noRd -#' @keywords Internal -build_file_extension <- function(x){ - case_match(x, - "image/jpg" ~ "jpg", - "image/jpeg" ~ "jpg", - "image/png" ~ "png", - "audio/mpeg" ~ "mpg", - "audio/x-wav" ~ "wav", - "audio/mp4" ~ "mp4", - "image/gif" ~ "gif", - "video/3gpp" ~ "3gp", - "video/quicktime" ~ "mov", - "audio/vnd.wave" ~ "wav") -} diff --git a/R/collapse_metadata.R b/R/collapse_metadata.R index adca405a..47655f93 100644 --- a/R/collapse_metadata.R +++ b/R/collapse_metadata.R @@ -1,249 +1,138 @@ -#' Internal function to `collapse()` apis -#' @noRd -#' @keywords Internal -collapse_apis <- function(){ - result <- list(type = "metadata/apis", - data = "galah:::node_config") - class(result) <- "query" - return(result) -} - -#' Internal function to `collapse()` assertions -#' NOTE: API doesn't accept any arguments - could post-filter for search +#' Internal function to `collapse()` lists +#' Required for pagination +#' Should run a query with `max = 0` to get total n +#' Then use `max` and `offset` to paginate up to `n` #' @noRd #' @keywords Internal -collapse_assertions <- function(){ - if(is_gbif()){ - result <- list(type = "metadata/assertions", - data = "galah:::gbif_internal_archived$assertions") +collapse_lists <- function(.query){ + if(is.null(.query$url)){ + .query + }else if(inherits(.query$url, "tbl_df")){ + .query + }else if(stringr::str_detect(.query$url, "[:digit:]+$")){ + .query }else{ - update_needed <- internal_cache_update_needed("assertions") - if(update_needed){ - result <- list(type = "metadata/assertions", - url = url_lookup("metadata/assertions"), - headers = build_headers()) - }else{ - result <- list(type = "metadata/assertions", - data = "galah:::check_internal_cache()$assertions") - } - } - class(result) <- "query" - return(result) -} - -#' Internal function to `collapse()` atlases -#' @noRd -#' @keywords Internal -collapse_atlases <- function(){ - result <- list(type = "metadata/atlases", - data = "galah:::node_metadata") - class(result) <- "query" - return(result) -} - -#' Internal function to `collapse()` collections -#' @importFrom httr2 url_parse -#' @noRd -#' @keywords Internal -collapse_collections <- function(.query){ - url <- url_lookup("metadata/collections") - if(is_gbif() & !missing(.query)){ - if(!is.null(.query$filter)){ - url <- url_parse(url) - url$query <- list(q = .query$filter$value[1]) - url <- url_build(url) + url <- httr2::url_parse(.query$url) + n_requested <- as.integer(url$query$max) + # make decisions about how much pagination is needed + if(n_requested <= 500){ # we haven't hit pagination limit + .query + }else{ # more lists are requested + n <- get_max_n(.query) + n_pages <- ceiling(n$max_requested / n$paginate) + offsets <- (seq_len(n_pages) - 1) * n$paginate + result <- tibble::tibble( + offset = offsets, + max = c( + rep(n$paginate, n_pages - 1), + n$max_requested - offsets[n_pages])) + result$url <- purrr::map( + split(result, seq_len(nrow(result))), + function(a){ + url$query <- list(offset = a$offset, max = a$max) + httr2::url_build(url) + }) |> + unlist() + .query$url <- dplyr::select(result, "url") } + .query } - result <- list(type = "metadata/collections", - url = url, - headers = build_headers()) - class(result) <- "query" - return(result) } -# NOTE: LA collectory functions do not accept `max` or `offset` -# Therefore they cannot be paginated. GBIF collectory funs can. -#' Internal function to `collapse()` datasets +#' Internal function to retrieve max number of entries for an API #' @noRd #' @keywords Internal -collapse_datasets <- function(.query){ - url <- url_lookup("metadata/datasets") - if(is_gbif() & !missing(.query)){ - if(!is.null(.query$filter)){ - url <- url_parse(url) - url$query <- list(q = .query$filter$value[1]) - url <- url_build(url) - } - } - result <- list(type = "metadata/datasets", - url = url, - headers = build_headers()) - class(result) <- "query" - return(result) -} - -#' Internal function to `collapse()` distributions -#' @noRd -#' @keywords Internal -collapse_distributions_metadata <- function(.query){ - url <- url_lookup("metadata/distributions") - result <- list(type = "metadata/distributions", - url = url, - headers = build_headers()) - class(result) <- "query" - return(result) -} - -#' Internal function to `collapse()` fields -#' Note that this is inconsistent with `show_all_fields()` which returns data -#' from multiple APIs -#' @noRd -#' @keywords Internal -collapse_fields <- function(){ +get_max_n <- function(.query){ + url <- httr2::url_parse(.query$url) if(is_gbif()){ - result <- list(type = "metadata/fields", - data = "galah:::gbif_internal_archived$fields") + count_field <- "count" }else{ - update_needed <- internal_cache_update_needed("fields") - if(update_needed){ - result <- list(type = "metadata/fields", - url = url_lookup("metadata/fields"), - headers = build_headers()) - }else{ - result <- list(type = "metadata/fields", - data = "galah:::check_internal_cache()$fields") - } + count_field <- "listCount" } - class(result) <- "query" - return(result) + n <- list(requested = as.integer(url$query$max), + paginate = 500, + max_available = { + url$query <- list(max = 0) + list(type = "metadata/list-count", + url = httr2::url_build(url), + headers = .query$headers) |> + query_API() |> + purrr::pluck(count_field) # NOTE: only tested for ALA + }) + n$max_requested <- min(c(n$requested, n$max_available)) + n } -#' Internal function to `collapse()` identifiers -#' @noRd -#' @keywords Internal -collapse_identifiers <- function(.query){ - if(is.null(.query$filter)){ - url_list <- url_lookup("metadata/identifiers") - names(url_list) <- "no-name-supplied" - }else{ - base_url <- url_lookup("metadata/identifiers") |> - url_parse() - search_terms <- .query$filter$value - query <- as.list(search_terms) - # create query urls - urls <- lapply(query, - function(a, base_url){ - names(a) <- "taxonID" - base_url$query <- as.list(a) - url_build(base_url) - }, - base_url = base_url) |> - unlist() - } - # build object and return - result <- list(type = "metadata/identifiers", - url = tibble(url = urls, - search_term = search_terms), - headers = build_headers()) - class(result) <- "query" - return(result) -} -#' Internal function to `collapse()` licences +#' Internal function to call `collapse` for `request_metadata(type = "profiles-unnest")` #' @noRd #' @keywords Internal -collapse_licences <- function(){ - result <- list(type = "metadata/licences", - url = url_lookup("metadata/licences"), - headers = build_headers()) - class(result) <- "query" - return(result) -} - -#' Internal function to `collapse()` lists -#' @noRd -#' @keywords Internal -collapse_lists <- function(.query){ - url <- url_lookup("metadata/lists") |> - url_parse() - url$query <- list(max = 10000) - if(!missing(.query)){ - if(!is.null(.query$slice)){ - url$query <- list(max = .query$slice$slice_n) - } +collapse_profile_values <- function(.query, + error_call){ + url <- .query |> + purrr::pluck("url") |> + httr2::url_parse() + profile_name <- extract_profile_name(url) + short_name <- profile_short_name(profile_name, + error_call = error_call) + if (!potions::pour("atlas", "region") == "Spain") { + path_name <- url |> + purrr::pluck("path") |> + dirname() + url$path <- glue::glue("{path_name}/{short_name}") } - result <- list(type = "metadata/lists", - url = url_build(url), - headers = build_headers(), - slot_name = "lists") - class(result) <- "query" - return(result) + list(type = .query$type, + url = httr2::url_build(url)) |> + as_query() } +# this doesn't print for some reason -#' Internal function to `collapse()` profiles +#' Internal function to convert between long and short names +#' for data profiles. Only used by `collapse_profile_values()` #' @noRd #' @keywords Internal -collapse_profiles <- function(){ - update_needed <- internal_cache_update_needed("profiles") - if(update_needed){ - result <- list(type = "metadata/profiles", - url = url_lookup("metadata/profiles"), - headers = build_headers()) - }else{ - result <- list(type = "metadata/profiles", - data = "galah:::check_internal_cache()$profiles") - } - class(result) <- "query" - return(result) -} - -#' Internal function to `collapse()` providers -#' @noRd -#' @keywords Internal -collapse_providers <- function(.query){ - url <- url_lookup("metadata/providers") - if(is_gbif() & !missing(.query)){ - if(!is.null(.query$filter)){ - url <- url_parse(url) - url$query <- list(q = .query$filter$value[1]) - url <- url_build(url) +profile_short_name <- function(profile, + error_call) { + valid_profiles <- show_all_profiles() + short_name <- NA + if (suppressWarnings(!is.na(as.numeric(profile)))) { + # assume a profile id has been provided + short_name <- valid_profiles[match(as.numeric(profile), + valid_profiles$id),]$short_name + } else { + # try to match a short name or a long name + if (profile %in% valid_profiles$name) { + short_name <- valid_profiles[match(profile, + valid_profiles$name), ]$short_name + } else { + if (profile %in% valid_profiles$short_name) { + short_name <- profile + } } } - result <- list(type = "metadata/providers", - url = url, - headers = build_headers()) - class(result) <- "query" - return(result) -} - -#' Internal function to `collapse()` reasons -#' @noRd -#' @keywords Internal -collapse_reasons <- function(){ - update_needed <- internal_cache_update_needed("reasons") - if(update_needed){ - result <- list(type = "metadata/reasons", - url = url_lookup("metadata/reasons"), - headers = build_headers()) + if (is.na(short_name)) { + c( + "Unknown profile detected.", + i = "See a listing of valid data quality profiles with `show_all_profiles()`.") |> + cli::cli_abort(call = error_call) }else{ - result <- list(type = "metadata/reasons", - data = "galah:::check_internal_cache()$reasons") + short_name } - class(result) <- "query" - return(result) } -#' Internal function to `collapse()` ranks +#' Internal function to extract profile name from url +#' for data profiles. Only used by `compute_profile_values()` #' @noRd #' @keywords Internal -collapse_ranks <- function(){ - if(is_gbif()){ - result <- list(type = "metadata/ranks", - data = "galah:::gbif_internal_archived$ranks") - }else{ - result <- list(type = "metadata/ranks", - data = "galah:::galah_internal_archived$ranks") +extract_profile_name <- function(url) { + atlas <- potions::pour("atlas", "region") + if (atlas == "Spain") { + profile_name <- url |> + purrr::pluck("query", "profileName") + } else { + profile_name <- url |> + purrr::pluck("path") |> + basename() } - class(result) <- "query" - return(result) + return(profile_name) } diff --git a/R/collapse_occurrences.R b/R/collapse_occurrences.R index dfccb91c..5a6b6b72 100644 --- a/R/collapse_occurrences.R +++ b/R/collapse_occurrences.R @@ -1,129 +1,17 @@ -#' Internal function to `collapse()` for `type = "occurrences"` -#' @importFrom rlang abort +#' Internal function to collapse occurrences; called by `collapse_query` #' @noRd #' @keywords Internal -collapse_occurrences <- function(.query){ - if(is.null(.query$filter) & - is.null(.query$identify) & - is.null(.query$geolocate)){ - abort("No filters supplied to `collapse()` with `type = \"occurrences\"`") +collapse_occurrences <- function(x){ + if(any(names(x) == "body")){ + result <- list( + creator = potions::pour("user", "username", .pkg = "galah"), + notificationAddresses = list(potions::pour("user", "email", .pkg = "galah")), + sendNotification = potions::pour("package", "send_email", .pkg = "galah"), + format = x$body$format, + predicate = build_predicates(x$body)) |> + jsonlite::toJSON(auto_unbox = TRUE, pretty = TRUE) + x$body <- result + x } - switch(pour("atlas", "region"), - "United Kingdom" = collapse_occurrences_uk(.query), - "Global" = collapse_occurrences_gbif(.query), - collapse_occurrences_la(.query)) -} - -#' calculate the query to be returned for the UK atlas -#' @param .query An object of class `data_request()` -#' @noRd -#' @keywords Internal -collapse_occurrences_uk <- function(.query){ - # set default columns - if(is.null(.query$select)){ - .query$select <- galah_select(group = "basic") - } - # build a url - # NOTE: providing an email blocks this from executing (2023-08-30) - url <- url_lookup("data/occurrences") |> - url_parse() - url$query <- c(build_query(identify = .query$identify, - filter = .query$filter, - location = .query$geolocate, - data_profile = .query$data_profile), - fields = "`SELECT_PLACEHOLDER`", - qa = "`ASSERTIONS_PLACEHOLDER`", - sourceTypeId = source_type_id_lookup("United Kingdom"), - fileType = "csv", - reasonTypeId = pour("user", "download_reason_id"), - dwcHeaders = "true") - # build output - result <- list( - type = "data/occurrences", - url = url_build(url), - headers = build_headers(), - filter = .query$filter, - select = .query$select) - class(result) <- "query" - return(result) -} - -#' calculate the query to be returned for GBIF -#' @importFrom glue glue -#' @noRd -#' @keywords Internal -collapse_occurrences_gbif <- function(.query, format = "SIMPLE_CSV"){ - # deal with user-specified taxonomic names - if(!is.null(identify)){ - .query$filter <- rbind( - .query$filter, - data.frame(variable = "taxonKey", - logical = "==", - value = "`TAXON_PLACEHOLDER`", - query = "")) - } - # get user string - username <- pour("user", "username", .pkg = "galah") - password <- pour("user", "password", .pkg = "galah") - user_string <- glue("{username}:{password}") - # build object - result <- list( - type = "data/occurrences", - url = url_lookup("data/occurrences"), - headers = list( - `User-Agent` = galah_version_string(), - `X-USER-AGENT` = galah_version_string(), - `Content-Type` = "application/json", - Accept = "application/json"), - options = list( - httpauth = 1, - userpwd = user_string), - body = build_predicates(.query$filter, - .query$geolocate, - format = format)) - class(result) <- "query" - return(result) -} - -#' calculate the query to be returned for a given living atlas -#' @param .query An object of class `data_request()` -#' @noRd -#' @keywords Internal -collapse_occurrences_la <- function(.query){ - # set default columns - if(is.null(.query$select)){ - .query$select <- galah_select(group = "basic") - } - # build a query - query <- c(build_query(identify = .query$identify, - filter = .query$filter, - location = .query$geolocate, - data_profile = .query$data_profile), - fields = "`SELECT_PLACEHOLDER`", - qa = "`ASSERTIONS_PLACEHOLDER`", - facet = "false", # not tested - emailNotify = email_notify(), - sourceTypeId = {pour("atlas", "region") |> - source_type_id_lookup()}, - reasonTypeId = pour("user", "download_reason_id"), - email = pour("user", "email"), - dwcHeaders = "true") - # DOI conditional on this service being offered - if (!is.null(.query$mint_doi) & - pour("atlas", "region") == "Australia") { - query$mintDoi <- .query$mint_doi - } - # build url - url <- url_lookup("data/occurrences") |> - url_parse() - url$query <- query - # build output - result <- list( - type = "data/occurrences", - url = url_build(url), - headers = build_headers(), - filter = .query$filter, - select = .query$select) - class(result) <- "query" - return(result) -} + x +} \ No newline at end of file diff --git a/R/collapse_occurrences_count.R b/R/collapse_occurrences_count.R deleted file mode 100644 index ee91eab7..00000000 --- a/R/collapse_occurrences_count.R +++ /dev/null @@ -1,137 +0,0 @@ -#' collapse for type = "occurrences-count" -#' @keywords Internal -#' @param .query an object of class `data_request` -#' @noRd -collapse_occurrences_count <- function(.query){ - if(is_gbif()){ - function_name <- "collapse_occurrences_count_gbif" - arg_names <- names(formals(collapse_occurrences_count_gbif)) - }else{ - function_name <- "collapse_occurrences_count_atlas" - arg_names <- names(formals(collapse_occurrences_count_atlas)) - } - custom_call <- .query[names(.query) %in% arg_names] - class(custom_call) <- "data_request" - do.call(function_name, custom_call) -} - -#' collapse for counts on LAs -#' @importFrom httr2 url_build -#' @importFrom httr2 url_parse -#' @keywords Internal -#' @noRd -collapse_occurrences_count_atlas <- function(identify = NULL, - filter = NULL, - geolocate = NULL, - data_profile = NULL, - group_by = NULL, - slice = NULL, - arrange = NULL -){ - query <- build_query(identify, - filter, - geolocate, - data_profile = data_profile) - # set behaviour depending on `group_by()` - if(is.null(group_by)){ - url <- url_lookup("data/occurrences-count") |> - url_parse() - url$query <- c(query, pageSize = 0) - result <- list(type = "data/occurrences-count", - url = url_build(url), - headers = build_headers(), - filter = filter, - slot_name = "totalRecords", - expand = FALSE) - }else{ - url <- url_lookup("data/occurrences-count-groupby") |> - url_parse() - facets <- as.list(group_by$name) - names(facets) <- rep("facets", length(facets)) - if(is.null(slice)){ - # limits to 10,000 rows - # TODO: This should ultimately be set by `slice` or `atlas_counts(limit = )`, not internally. - # Will need updating to avoid hidden limit setting here & in `compute_occurrences_count()` - slice <- tibble(slice_n = 1e4, slice_called = FALSE) - } - if(is.null(arrange)){ - arrange <- tibble(variable = "count", direction = "descending") - } - slice_arrange <- bind_cols(slice, arrange) - arrange_list <- check_slice_arrange(slice_arrange) - url$query <- c(query, facets, arrange_list) - result <- list(type = "data/occurrences-count-groupby", - url = url_build(url), - headers = build_headers(), - filter = filter, - expand = ifelse(length(facets) > 1, TRUE, FALSE), - arrange = slice_arrange) - } - class(result) <- "query" - return(result) -} - -#' collapse for counts on GBIF -#' @importFrom httr2 url_build -#' @importFrom httr2 url_parse -#' @keywords Internal -#' @noRd -collapse_occurrences_count_gbif <- function(identify = NULL, - filter = NULL, - geolocate = NULL, - group_by = NULL, - slice = NULL - ){ - # get relevant information - if(is.null(group_by)){ - url <- url_lookup("data/occurrences-count") |> - url_parse() - url$query <- c( - build_query_gbif(identify, filter, geolocate), - limit = 0) - result <- list( - type = "data/occurrences-count", - url = url_build(url), - slot_name = "count", - expand = FALSE) - # add facets - }else{ - result <- list(type = "data/occurrences-count-groupby") - url <- url_lookup("data/occurrences-count") |> - url_parse() - facets <- as.list(group_by$name) - names(facets) <- rep("facet", length(facets)) - if(is.null(slice)){ - slice <- tibble(slice_n = 30, slice_called = FALSE) - } - url$query <- c(build_query_gbif(identify, filter, geolocate), - limit = 0, - facets, - facetLimit = slice$slice_n) - result$url <- url_build(url) - result$expand <- ifelse(length(facets) > 1, TRUE, FALSE) - } - # aggregate and return - result$headers <- build_headers() - class(result) <- "query" - result -} - -#' Internal function to check `slice` and `arrange` for counts -#' @keywords Internal -#' @noRd -check_slice_arrange <- function(df){ - if(df$variable == "count"){ # arranged in descending order by default - if(df$direction == "ascending"){ - list(fsort = "count", flimit = 0) - }else{ - list(fsort = "count", flimit = df$slice_n) - } - }else{ # non-count fields are arranged in ascending order by default - if(df$direction == "ascending"){ - list(fsort = "index", flimit = df$slice_n) - }else{ - list(fsort = "index", flimit = 0) - } - } -} diff --git a/R/parse_occurrences_count.R b/R/collapse_occurrences_count_atlas.R similarity index 50% rename from R/parse_occurrences_count.R rename to R/collapse_occurrences_count_atlas.R index c69fb3ff..0364580b 100644 --- a/R/parse_occurrences_count.R +++ b/R/collapse_occurrences_count_atlas.R @@ -1,38 +1,8 @@ -#' Compute counts -#' -#' This is a little different from other `compute` functions; it converts a -#' `data_query` object (from `collapse(type = "occurrences-count")`) into one or more urls -#' that can be passed verbatim to `query_API()`. This is important when `group_by` -#' has `expand = TRUE`, because it requires an initial call to the atlas to -#' calculate the requisite URLs. It makes very little difference under other -#' circumstances -#' @param .query An object of class `data_query` -#' @keywords Internal -#' @noRd -parse_occurrences_count <- function(.query){ - if(is_gbif()){ - if(.query$expand){ - abort("Grouped counts haven't been (re)implemented for GBIF yet") - # compute_grouped_counts_GBIF(.query) - }else{ - .query - } - }else{ - if(.query$expand){ - parse_occurrences_count_groupby(.query) - }else{ - parse_occurrences_count_nogroupby(.query) - } - } -} -# Note: the above handles types `data/occurrences-count-groupby` -# and `data/occurrences-count`. This is probably inefficient. - #' Internal function to handle facet counting, adjustment etc. #' @noRd #' @keywords Internal -parse_occurrences_count_nogroupby <- function(.query){ - url <- url_parse(.query$url) +collapse_occurrences_count_atlas_basic <- function(.query){ + url <- httr2::url_parse(.query$url) # check if a limit has been set if(!is.null(url$query$flimit)){ @@ -42,24 +12,27 @@ parse_occurrences_count_nogroupby <- function(.query){ # handle slice_head if(as.integer(url$query$flimit) < 1){ - url$query$flimit <- .query$arrange$slice_n # Q: is this correct? - if(.query$arrange$slice_n < n_facets){ - url$query$foffset <- n_facets - .query$arrange$slice_n + url$query$flimit <- .query$request$slice_arrange$slice_n # Q: is this correct? + if(.query$request$slice_arrange$slice_n < n_facets){ + url$query$foffset <- n_facets - .query$request$slice_arrange$slice_n } - .query$url <- url_build(url) + .query$url <- httr2::url_build(url) .query # message when limit is hit }else{ if(as.integer(url$query$flimit) < n_facets){ - limit <- url$query$flimit |> prettyNum(big.mark=",", preserve.width="none") - n_total_facets <- n_facets |> prettyNum(big.mark=",", preserve.width="none") + limit <- url$query$flimit |> + prettyNum(big.mark = ",", + preserve.width = "none") + n_total_facets <- n_facets |> + prettyNum(big.mark = ",", + preserve.width = "none") - bullets <- c( - cli::cli_text(cli::col_yellow(glue("Limiting to first {limit} of {n_total_facets} rows."))), + cli::cli({ + cli::cli_text(cli::col_yellow("Limiting to first {limit} of {n_total_facets} rows.")) cli::cli_text(cli::col_magenta("Use `atlas_counts(limit = )` to return more rows.")) - ) - inform(bullets) + }) } # .query$url <- url_build(url) .query @@ -69,145 +42,136 @@ parse_occurrences_count_nogroupby <- function(.query){ } } -#' Determine set of queries when expand = TRUE -#' @importFrom dplyr bind_rows -#' @importFrom dplyr c_across -#' @importFrom dplyr full_join -#' @importFrom dplyr rowwise -#' @importFrom dplyr starts_with -#' @importFrom dplyr ungroup -#' @importFrom glue glue_collapse -#' @importFrom httr2 url_build -#' @importFrom httr2 url_parse +#' Determine set of queries when group_by() is set #' @noRd #' @keywords Internal -parse_occurrences_count_groupby <- function(.query, error_call = caller_env()){ +collapse_occurrences_count_atlas_groupby_crossed <- function(.query, + error_call = rlang::caller_env()){ data_cached <- .query # get url - url <- url_parse(.query$url) + url <- httr2::url_parse(.query$url) # remove last-provided facet facet_list <- url$query[names(url$query) == "facets"] facet_names <- unlist(facet_list) names(facet_names) <- NULL - - # Error when Atlas facet max is reached - if (pour("atlas", "region") == "Estonia" & - length(facet_list) > 1) { - atlas <- pour("atlas", "region") - n_fields <- length(facet_list) - bullets <- c( - "Too many fields passed to `group_by()`.", - x = glue("Selected atlas ({atlas}) accepts a maximum of 1 field, not {n_fields}.") - ) - abort(bullets, call = error_call) - } # save out facet limits to add back later saved_facet_queries <- list( flimit = url$query$flimit, foffset = url$query$foffset) saved_facet_queries <- saved_facet_queries[ - unlist(lapply(saved_facet_queries, function(a){!is.null(a)}))] + purrr::map(saved_facet_queries, + \(a){!is.null(a)}) |> + unlist()] # rebuild url with only first facet argument url$query <- c( url$query[names(url$query) != "facets"], facet_list[-length(facet_list)]) - .query$url <- url_build(url) + .query$url <- httr2::url_build(url) # check number of facets n_facets <- check_facet_count(.query, warn = FALSE) # incorporate this into the query - url <- url_parse(.query$url) + url <- httr2::url_parse(.query$url) url$query$flimit <- max(n_facets) - .query$url <- url_build(url) + .query$url <- httr2::url_build(url) # run query to get list of count tibbles result <- query_API(.query) - if(is.null(result)){system_down_message("count")} - result <- lapply(result, - function(a){a$fieldResult |> bind_rows()}) + if(is.null(result)){ + system_down_message("count", + error_call = error_call) + } + result <- purrr::map(result, + \(a){a$fieldResult |> + dplyr::bind_rows()}) names(result) <- facet_names[-length(facet_names)] # expand to a tibble that gives all combinations kept_facets <- facet_names[-length(facet_names)] - result_list <- lapply(names(result), - function(a){ + result_list <- purrr::map(names(result), + \(a){ x <- result[[a]][c(1, 4)] names(x)[1] <- a - x}) - + x}) + # convert to all combinations of levels if(length(result_list) > 1){ - levels_list <- lapply(result_list, function(a){a[[1]]}) + levels_list <- purrr::map(result_list, \(a){a[[1]]}) names(levels_list) <- names(result) levels_list <- c(levels_list, list(stringsAsFactors = FALSE)) result_df <- do.call(expand.grid, levels_list) |> - tibble() + tibble::tibble() for(i in seq_along(result_list)){ - result_df <- full_join(result_df, result_list[[i]], by = kept_facets[i]) + result_df <- dplyr::full_join(result_df, + result_list[[i]], + by = kept_facets[i]) } }else{ + # FIXME: This fails if `result_list` is empty result_df <- result_list[[1]] } # # extract existing fq statements - query <- url_parse(.query$url)$query + query <- httr2::url_parse(.query$url)$query if(is.null(query$fq)){ fqs <- NULL }else{ fqs <- strsplit(query$fq, "AND")[[1]] - fqs <- fqs[!grepl(paste(kept_facets, collapse = "|"), fqs)] # remove fqs that relate to parsed facets + fqs <- fqs[!grepl(glue::glue_collapse(kept_facets, sep = "|"), fqs)] # remove fqs that relate to parsed facets if(length(fqs) < 1){ fqs <- NULL }else{ - fqs <- paste(fqs, collapse = " AND ") + fqs <- glue::glue_collapse(fqs, sep = " AND ") } } # glue `fq` statements together result_df <- result_df |> - rowwise() |> - mutate(query = glue_collapse(c_across(starts_with("fq")), sep = " AND ")) |> - select(-starts_with("fq")) |> - ungroup() + dplyr::rowwise() |> + dplyr::mutate(query = dplyr::starts_with("fq") |> + dplyr::c_across() |> + glue::glue_collapse( sep = " AND ")) |> + dplyr::select(-dplyr::starts_with("fq")) |> + dplyr::ungroup() if(!is.null(fqs)){ - result_df$query <- glue("{fqs} AND {result_df$query}") + result_df$query <- glue::glue("{fqs} AND {result_df$query}") } # recombine into urls - url_final <- url_parse(.query$url) + url_final <- httr2::url_parse(.query$url) query_without_fq <- c( url_final$query[!(names(url_final$query) %in% c("fq", "facets", "flimit", "foffset"))], list(facets = facet_names[length(facet_names)]), saved_facet_queries) - url_list <- lapply(result_df$query, function(a, url){ + url_list <- purrr::map(result_df$query, function(a, url){ url$query <- c(list(fq = a), query_without_fq) - url_build(url) + httr2::url_build(url) }, url = url_final) result_df$url <- unlist(url_list) - result_df <- select(result_df, -query) + result_df <- dplyr::select(result_df, -query) # join and export - result <- c(list( - type = data_cached$type, - url = result_df), - data_cached[!(names(data_cached) %in% c("url", "type"))]) - class(result) <- "query" - result + c(list(type = data_cached$type, + url = result_df), + data_cached[!(names(data_cached) %in% c("url", "type"))]) |> + as_query() } #' Internal function to check number of facets to be returned by a `group_by` query #' It is called exclusively by `compute_counts()` #' @noRd #' @keywords Internal -check_facet_count <- function(.query, warn = TRUE, error_call = caller_env()){ - url <- url_parse(.query$url) +check_facet_count <- function(.query, + warn = TRUE, + error_call = rlang::caller_env()){ + url <- httr2::url_parse(.query$url) current_limit <- url$query$flimit if(is.null(current_limit)){ @@ -222,13 +186,12 @@ check_facet_count <- function(.query, warn = TRUE, error_call = caller_env()){ } url$query$flimit <- 0 temp_data <- .query - temp_data$url <- url_build(url) - temp_data$slot_name <- NULL + temp_data$url <- httr2::url_build(url) result <- query_API(temp_data) if(length(result) < 1){ 0 }else{ - lapply(result, function(a){a$count}) |> unlist() + purrr::map(result, function(a){a$count}) |> unlist() } # if(inherits(result, "data.frame")){ # group_by arg present # n_available <- result$count diff --git a/R/collapse_occurrences_count_gbif.R b/R/collapse_occurrences_count_gbif.R new file mode 100644 index 00000000..e66d9a7f --- /dev/null +++ b/R/collapse_occurrences_count_gbif.R @@ -0,0 +1,113 @@ +#' Function to construct `body` arg for GBIF +#' predicates are JSON scripts for passing to GBIF offline downloads API. +#' https://www.gbif.org/developer/occurrence +#' @param x A list with slots relevant to building predicates +#' @noRd +#' @keywords Internal +collapse_occurrences_count_gbif <- function(x, limit = 0){ + x$body <- list(predicate = build_predicates(x$body), + limit = limit) |> + remove_nulls_from_list() |> + jsonlite::toJSON(auto_unbox = TRUE, + pretty = TRUE) + x +} + +#' Internal function to handle count queries with 'basic' group_by queries +#' In practice, this means just passing arguments to the `facets` arg +#' @noRd +#' @keywords Internal +collapse_occurrences_count_gbif_groupby_basic <- function(x){ + x$body <- list(predicate = build_predicates(x$body), + limit = 0, + facets = parse_predicates_groupby(x$body$group_by)) |> + remove_nulls_from_list() |> + jsonlite::toJSON(auto_unbox = TRUE, + pretty = TRUE) + x +} + +#' Internal function to handle 'crossed' count queries +#' @noRd +#' @keywords Internal +collapse_occurrences_count_gbif_groupby_crossed <- function(x){ + + # get a 'basic' query, showing facets for each variable separately + facets <- collapse_occurrences_count_gbif_groupby_basic(x) |> + collect() |> + dplyr::relocate(x$request$group_by$name) # place in supplied order + + # build filters for our next round of queries + # for 3 facets, we need to expand our crossed variables + if(ncol(facets) > 3){ + + filters <- facets |> + select(!!!names(facets[1:2])) |> + purrr::map(.f = \(a){a[!is.na(a)]}) |> + expand.grid(stringsAsFactors = FALSE) + facet <- colnames(facets)[3] + + z <- x$request + z$slice_arrange <- NULL # this is a hack to avoid messy object update code + filter_1 <- colnames(filters)[1] + filter_2 <- colnames(filters)[2] + + body_list <- purrr::map( + split(filters, seq_len(nrow(filters))), + \(a){ + value_1 <- a[[1]][[1]] + value_2 <- a[[2]][[1]] + result <- z |> + filter({{filter_1}} == {{value_1}}, + {{filter_2}} == {{value_2}}) |> + group_by(facet) |> + collapse() + result$body + }) + + + # for 2 facets, we just select the levels we need + }else{ + filters <- facets |> + select(!!!(colnames(facets)[1])) |> + tidyr::drop_na() + facet <- colnames(facets)[2] + # extract a query that we can update with new parameters + z <- x$request + z$slice_arrange <- NULL # this is a hack to avoid messy object update code + filter_name <- colnames(filters)[1] + # create multiple new queries from the old one + # this works because new calls to `filter()` *adds* to a query + # while new calls to `group_by()` *replaces* old entries + body_list <- purrr::map(filters[[1]], \(a){ + result <- z |> + filter({{filter_name}} == {{a}}) |> + group_by(facet) |> + collapse() + result$body + }) + } + + # add predicates to tibble; tibble to `body`; return + filters$predicate <- body_list + x$body <- filters + x +} + +#' Internal function to convert a facet df into a predicate +#' @noRd +#' @keywords Internal +tibble_to_predicate <- function(df){ + # iterate over rows + purrr::map( + split(df, seq_len(nrow(df))), + .f = \(a){ + # for each row, convert each column (cell) into a list + cols_vector <- seq_len(ncol(a)) + purrr::map(cols_vector, \(b){ + list(type = "equals", + key = gbif_upper_case(names(a)[b]), + value = a[[b]][[1]]) + }) + }) +} \ No newline at end of file diff --git a/R/collapse_occurrences_doi.R b/R/collapse_occurrences_doi.R deleted file mode 100644 index 33601dbe..00000000 --- a/R/collapse_occurrences_doi.R +++ /dev/null @@ -1,50 +0,0 @@ -#' Internal function to `collapse()` for `type = "doi"` -#' @importFrom rlang abort -#' @importFrom stringr str_split -#' @noRd -#' @keywords Internal -collapse_occurrences_doi <- function(.query, error_call = caller_env()){ - if(is.null(.query$filter)){ - abort("A DOI must be specified using `filter(doi == \"my-doi-here\")`.", - call = error_call) - } - - if(is.null(.query$filter$variable) && .query$filter$variable != "doi"){ - abort("No DOI has been supplied.", - call = error_call) - } - - if(pour("atlas", "acronym") != "ALA"){ - bullets <- c( - "DOI downloads not supported by selected atlas.", - i = "`request_data(type = \"occurrences-doi\")` has only been implemented for ALA." - ) - abort(bullets, - call = error_call) - } - - doi <- .query$filter$value[[1]] - - # remove "https://" if present - if (grepl("^http://doi.org/", doi)) { - doi <- sub("^https://doi.org/", "", doi) - } - - # extract useful part of DOI - doi_str <- stringr::str_split(doi, "ala.")[[1]][2] - if (is.na(doi_str)) { - bullets <- c( - "DOI has not been generated by the ALA.", - i = "DOIs created by the ALA have a prefix of 10.26197/ala." - ) - abort(bullets, call = error_call) - } - - result <- list( - type = "data/occurrences-doi", - url = url_lookup("data/occurrences-doi", doi_string = doi_str), - headers = build_headers(), - download = TRUE) - class(result) <- "data_query" - return(result) -} diff --git a/R/collapse_query_set.R b/R/collapse_query_set.R new file mode 100644 index 00000000..22d3dc1d --- /dev/null +++ b/R/collapse_query_set.R @@ -0,0 +1,50 @@ +#' Internal function to parse a `query_set` into a single `query` +#' @param x a `query_set` +#' @noRd +#' @keywords Internal +collapse_query_set <- function(x, + error_call = rlang::caller_env()){ + switch(x$type, + "data/occurrences" = collapse_occurrences(x), + "data/occurrences-count" = { + if(is_gbif()){ + collapse_occurrences_count_gbif(x) + }else{ + collapse_occurrences_count_atlas_basic(x) + } + }, + "data/occurrences-count-groupby" = { + if(is_gbif()){ + if(nrow(x$body$group_by) > 1){ + collapse_occurrences_count_gbif_groupby_crossed(x) + }else{ + collapse_occurrences_count_gbif_groupby_basic(x) + } + }else{ + query_names <- httr2::url_parse(x$url) |> + purrr::pluck("query") |> + names() + if(length(which(query_names == "facets")) > 1){ + collapse_occurrences_count_atlas_groupby_crossed(x) + }else{ + collapse_occurrences_count_atlas_basic(x) + } + } + }, + "data/occurrences-glimpse" = { + if(is_gbif()){ + collapse_occurrences_count_gbif(x, limit = 3) + }else{ + x + }}, + "data/species" = collapse_occurrences(x), # optimised for GBIF + "data/species-count" = collapse_species_count(x), + # "-unnest" functions require some checks + "metadata/profiles-unnest" = collapse_profile_values(x, + error_call = error_call) |> + add_request(x$request), + # some "metadata/" functions require pagination under some circumstances + "metadata/lists" = collapse_lists(x), # always paginates + x # remaining "metadata/" functions and "data/occurrences-doi" are passed as-is + ) +} \ No newline at end of file diff --git a/R/collapse_species.R b/R/collapse_species.R deleted file mode 100644 index a0bf0307..00000000 --- a/R/collapse_species.R +++ /dev/null @@ -1,100 +0,0 @@ -#' Internal function to `collapse()` for `type = "species"` -#' @noRd -#' @keywords Internal -collapse_species <- function(.query){ - if(is_gbif()){ - result <- collapse_occurrences_gbif(.query, - format = "SPECIES_LIST") - result$type <- "data/species" - result - }else{ - collapse_species_atlas(.query) - } -} - -#' calculate the query to be returned for a given living atlas -#' @noRd -#' @keywords Internal -collapse_species_atlas <- function(.query){ - # set default columns - if(is.null(.query$select)){ - .query$select <- galah_select(group = "taxonomy") - } - - # determine whether to use `group_by` or `species_facets()` - if(is.null(.query$group_by)){ - .query$group_by <- tibble(name = species_facets(), - type = "field") - } - - # build a query - query <- c( - build_query(.query$identify, - .query$filter, - .query$geolocate, - .query$data_profile), - emailNotify = email_notify(), - sourceTypeId = 2004, - reasonTypeId = pour("user", "download_reason_id"), - email = pour("user", "email"), - facets = .query$group_by$name, - parse_select_species(.query$select) - ) - # build url - url <- url_lookup("data/species") |> - url_parse() - url$query <- query - # build output - result <- list( - type = "data/species", - url = url_build(url), - headers = build_headers(), - filter = .query$filter, - group_by = .query$group_by, - download = TRUE) - class(result) <- "query" - result -} - -#' parse `select()` for `atlas_species()` -#' @importFrom rlang warn -#' @importFrom glue glue -#' @importFrom glue glue_collapse -#' @noRd -#' @keywords Internal -parse_select_species <- function(.select){ - # parse labels for supplied field names - quosure_check <- lapply(.select, is_quosure) |> unlist() - if(any(quosure_check)){ - named_fields <- lapply(.select[quosure_check], as_label) |> unlist() - }else{ - named_fields <- NULL - } - # create output - result <- list( - lookup = "false", - count = "false", - synonym = "false", - lists = "false") - # fill list with correct results - if(!is.null(.select$group)){ - if(any(.select$group == "taxonomy")){ - result$lookup <- "true" - } - } - if(!is.null(named_fields)){ - # check for unexpected names - name_check <- !(named_fields %in% c("counts", "synonyms", "lists")) - if(any(name_check)){ - unexpected_names <- glue_collapse(named_fields[name_check], last = " and ") - bullets <- c("When type = 'species', `select()` only accepts 'counts', 'synonyms' or 'lists' as valid fields.", - i = glue("Unexpected fields: {unexpected_names}")) - warn(bullets) - } - # parse 'correct' names - if(any(named_fields == "counts")){result$count <- "true"} - if(any(named_fields == "synonyms")){result$synonym <- "true"} - if(any(named_fields == "lists")){result$lists <- "true"} - } - result -} diff --git a/R/collapse_species_count.R b/R/collapse_species_count.R index a5a8e345..21938cf8 100644 --- a/R/collapse_species_count.R +++ b/R/collapse_species_count.R @@ -1,68 +1,32 @@ -#' collapse for type = "species-count" -#' @keywords Internal -#' @param .query an object of class `data_request` +#' Internal function to compute for species counts #' @noRd +#' @keywords Internal collapse_species_count <- function(.query){ - if(is_gbif()){ - abort("`count()` is not supported for GBIF with type = 'species'") - ## TRUE? + if(!is.null(.query$request$group_by)){ + collapse_species_query_list(.query) }else{ - function_name <- "collapse_species_count_atlas" - arg_names <- names(formals(collapse_species_count_atlas)) + .query$url <- tibble::tibble(url = .query$url) + .query } - custom_call <- .query[names(.query) %in% arg_names] - class(custom_call) <- "data_request" - do.call(function_name, custom_call) } -#' collapse for counts on LAs -#' @importFrom httr2 url_build -#' @importFrom httr2 url_parse -#' @keywords Internal +#' Internal function to generate correct set of species-count queries when +#' `group_by()` is set #' @noRd -collapse_species_count_atlas <- function(identify = NULL, - filter = NULL, - geolocate = NULL, - data_profile = NULL, - group_by = NULL, - slice = NULL, - arrange = NULL -){ - url <- url_lookup("data/species-count") |> - url_parse() - query <- build_query(identify, - filter, - geolocate, - data_profile = data_profile) - # set behaviour depending on `group_by()` - if(is.null(group_by)){ - url$query <- c(query, - list(flimit = 1, - facets = species_facets())) - result <- list(type = "data/species-count", - url = url_build(url), - headers = build_headers(), - filter = filter, - expand = FALSE) - }else{ - facets <- c(as.list(group_by$name), species_facets()) - names(facets) <- rep("facets", length(facets)) - if(is.null(slice)){ - slice <- tibble(slice_n = 30, slice_called = FALSE) - } - if(is.null(arrange)){ - arrange <- tibble(variable = "count", direction = "descending") - } - slice_arrange <- bind_cols(slice, arrange) - arrange_list <- check_slice_arrange(slice_arrange) - url$query <- c(query, facets, arrange_list) - result <- list(type = "data/species-count", - url = url_build(url), - headers = build_headers(), - filter = filter, - expand = TRUE, - arrange = slice_arrange) - } - class(result) <- "query" - return(result) -} +#' @keywords Internal +collapse_species_query_list <- function(.query){ + # use existing `group_by()` code to handle the facet construction + new_query <- collapse_occurrences_count_atlas_groupby_crossed(.query) + distinct_facet <- .query$request$distinct$name # this is not retained for some reason + new_urls <- new_query |> + purrr::pluck("url", "url") |> + purrr::map(.f = \(a){ + url_now <- httr2::url_parse(a) + url_now$query$flimit <- 0 # set no facets to be returned; we only want the number of facets + url_now$query$facets <- distinct_facet # set facet correctly + httr2::url_build(url_now) + }) |> + unlist() + new_query$url$url <- new_urls + new_query +} \ No newline at end of file diff --git a/R/collapse_taxa.R b/R/collapse_taxa.R deleted file mode 100644 index 0388ff55..00000000 --- a/R/collapse_taxa.R +++ /dev/null @@ -1,60 +0,0 @@ -#' Internal function to `collapse()` for `type = "taxa"`, `method = "metadata` -#' @noRd -#' @keywords Internal -collapse_taxa <- function(.query){ - if(is.null(.query$identify)){ - result <- list(type = "metadata/taxa") - class(result) <- "query" - result - }else{ - if(ncol(.query$identify) > 1 | colnames(.query$identify)[1] != "search_term"){ - collapse_taxa_multiple(.query) - }else{ - collapse_taxa_single(.query) - } - } -} - -#' Internal function to `collapse()` for a single taxonomic name -#' @noRd -#' @keywords Internal -collapse_taxa_single <- function(.query){ - urls <- lapply(.query$identify$search_term, - function(a){url_lookup("metadata/taxa-single", - name = a)}) |> - unlist() - search_terms <- .query$identify$search_term - # build object and return - result <- list(type = "metadata/taxa-single", - url = tibble(url = urls, - search_term = search_terms), - headers = build_headers()) - class(result) <- "query" - return(result) -} - -#' Internal function to `collapse()` where multiple taxonomic levels are given -#' @noRd -#' @keywords Internal -collapse_taxa_multiple <- function(.query){ - split_list <- split(.query$identify, seq_len(nrow(.query$identify))) - base_url <- url_lookup("metadata/taxa-multiple") |> - url_parse() - urls <- lapply(split_list, - function(a, base_url){ - base_url$query <- as.list(a) - url_build(base_url) - }, - base_url = base_url) |> - unlist() - search_terms <- lapply(split_list, - function(a){paste(a, collapse = "_")}) |> - unlist() - # build object and return - result <- list(type = "metadata/taxa-multiple", - url = tibble(url = urls, - search_term = search_terms), - headers = build_headers()) - class(result) <- "query" - return(result) -} diff --git a/R/collapse_unnest.R b/R/collapse_unnest.R deleted file mode 100644 index aa4082ec..00000000 --- a/R/collapse_unnest.R +++ /dev/null @@ -1,85 +0,0 @@ -#' Internal function to run `collapse()` for -#' `request_metadata(type = "fields") |> unnest()` -#' @importFrom httr2 url_build -#' @importFrom httr2 url_parse -#' @noRd -#' @keywords Internal -collapse_fields_unnest <- function(.query){ - url <- url_lookup("metadata/fields-unnest") |> - url_parse() - if(is_gbif()){ - url$query <- list( - limit = 0, - facet = .query$filter$value[1], # note: facet (singular), not facets (plural) - facetLimit = 10^4) - }else{ - url$query <- list( - facets = .query$filter$value[1], - flimit = 10^4) - } - result <- list( - type = "metadata/fields-unnest", - url = url_build(url)) - class(result) <- "query" - return(result) -} - -#' Internal function to run `collapse()` for -#' `request_metadata(type = "lists") |> unnest()` -#' @noRd -#' @keywords Internal -collapse_lists_unnest <- function(.query){ - - url <- url_lookup("metadata/lists-unnest", - list_id = .query$filter$value[1]) |> - url_parse() - - # Request additional raw fields if `show_fields(all_fields = TRUE)` - if(isTRUE(attributes(.query)$all_fields)) { - url$query <- list( - max = -1, # remove max limit - includeKVP = TRUE # add name & status columns - ) - } else { - url$query <- list( - max = -1 # remove max limit - ) - } - - result <- list( - type = "metadata/lists-unnest", - url = url_build(url)) - class(result) <- "query" - return(result) -} - -#' Internal function to run `collapse()` for -#' `request_metadata(type = "profiles") |> unnest()` -#' @noRd -#' @keywords Internal -collapse_profiles_unnest <- function(.query){ - result <- list( - type = "metadata/profiles-unnest", - url = url_lookup("metadata/profiles-unnest", - profile = .query$filter$value[1])) - class(result) <- "query" - return(result) -} - -#' Internal function to `collapse()` for -#' `request_metadata(type = "taxa") |> unnest()` -#' @importFrom rlang abort -#' @noRd -#' @keywords Internal -collapse_taxa_unnest <- function(.query){ - if(!is.null(.query$filter)){ - id <- .query$filter$value[1] - }else if(!is.null(.query$identify)){ - id <- "`TAXON_PLACEHOLDER`" - } - result <- list(type = "metadata/taxa-unnest", - url = url_lookup("metadata/taxa-unnest", id = id), - headers = build_headers()) - class(result) <- "query" - return(result) -} diff --git a/R/collect_distributions.R b/R/collect_distributions.R index 49e2d4a9..c23f4a65 100644 --- a/R/collect_distributions.R +++ b/R/collect_distributions.R @@ -1,14 +1,12 @@ #' Internal function to `collect` for type `data/distributions` -#' @importFrom sf st_as_sf -#' @importFrom sf st_as_sfc #' @noRd #' @keywords Internal collect_distributions <- function(.query){ result <- query_API(.query) # NOTE: below is consistent with `collect_distributions_metadata()` (+ geometry) result <- result |> - bind_rows() |> - select("gid", + dplyr::bind_rows() |> + dplyr::select("gid", "family", "genus_name", "scientific", @@ -18,14 +16,14 @@ collect_distributions <- function(.query){ "area_km", "data_resource_uid", "geometry") |> - rename( + dplyr::rename( "id" = "gid", # this is chosen as ID because it is called by later APIs "genus" = "genus_name", "species" = "scientific", "taxon_concept_id" = "lsid", "label" = "area_name", "common_name" = "common_nam") |> - mutate("common_name" = trimws(.data$common_name)) - result$geometry <- st_as_sfc(result$geometry, crs=4326) - return(st_as_sf(result)) + dplyr::mutate("common_name" = trimws(.data$common_name)) + result$geometry <- sf::st_as_sfc(result$geometry, crs=4326) + return(sf::st_as_sf(result)) } \ No newline at end of file diff --git a/R/collect_files.R b/R/collect_files.R new file mode 100644 index 00000000..ecf7aac7 --- /dev/null +++ b/R/collect_files.R @@ -0,0 +1,39 @@ +#' Internal version of `collect()` for `request_files(type = "media")` +#' @param object of class `files_response`, from `compute()` +#' @noRd +#' @keywords Internal +collect_media_files <- function(.query){ + result <- query_API(.query) + status_values <- purrr::map(result, + \(a){a$status_code}) |> + unlist() + result_summary <- tibble::tibble(status_code = status_values) |> + dplyr::group_by(.data$status_code) |> + dplyr::count() + + # successful downloads + success <- result_summary |> + dplyr::filter(.data$status_code == 200) + n_downloaded <- success[["n"]] + + # failed downloads + fail <- NULL + if(nrow(result_summary) > 1) { + if(any(result_summary$status_code %in% "403")) { + fail <- result_summary |> + dplyr::filter(.data$status_code == 403) + n_failed <- fail[["n"]] + } + } + user_directory <- potions::pour("package", "directory") + bullets <- c( + "v" = "Downloaded {n_downloaded} files successfully (status 200).", + ">" = "Files saved in local directory: \"{user_directory}\"." + ) + if(!is.null(fail)) { + bullets <- c(bullets, + "x" = "Failed {n_failed} downloads due to missing images (status 403)") + } + cli::cli_bullets(bullets) + invisible(result_summary) +} \ No newline at end of file diff --git a/R/collect_media.R b/R/collect_media.R index 699f78f2..ca410986 100644 --- a/R/collect_media.R +++ b/R/collect_media.R @@ -1,76 +1,3 @@ -#' Internal version of `collect()` for `request_data(type = "media")` -#' @param object of class `data_response`, from `compute()` -#' @importFrom dplyr any_of -#' @importFrom dplyr filter -#' @importFrom dplyr mutate -#' @importFrom dplyr select -#' @importFrom purrr pluck -#' @importFrom rlang abort -#' @noRd -#' @keywords Internal -collect_media_metadata <- function(.query){ - result <- query_API(.query) |> - pluck("results") |> - bind_rows() - if(nrow(result) < 1){ # case where no data returned - if(pour("package", "verbose")){ - warn("No data returned from `metadata/media` API") - } - ids <- .query$body |> - fromJSON() |> - unlist() - result <- tibble(image_id = ids) - }else{ - colnames(result) <- rename_columns(names(result), type = "media") - } - # Select only the rows and columns we want - result |> - filter(!is.na(result$image_id)) |> - select(any_of(wanted_columns("media"))) -} - -#' Internal version of `collect()` for `request_files(type = "media")` -#' @param object of class `files_response`, from `compute()` -#' @importFrom dplyr group_by -#' @importFrom dplyr filter -#' @importFrom dplyr count -#' @importFrom rlang .data -#' @noRd -#' @keywords Internal -collect_media_files <- function(.query){ - result <- query_API(.query) - result_summary <- tibble( - status_code = unlist(lapply(result, function(a){a$status_code}))) |> - group_by(.data$status_code) |> - count() - - # successful downloads - success <- result_summary |> - dplyr::filter(.data$status_code == 200) - n_downloaded <- success[["n"]] - - # failed downloads - fail <- NULL - if(nrow(result_summary) > 1) { - if(any(result_summary$status_code %in% "403")) { - fail <- result_summary |> - dplyr::filter(.data$status_code == 403) - n_failed <- fail[["n"]] - } - } - user_directory <- pour("package", "directory") - bullets <- c( - "v" = glue("Downloaded {n_downloaded} files successfully (status 200)."), - ">" = glue("Files saved in local directory: \"{user_directory}\".") - ) - if(!is.null(fail)) { - bullets <- c(bullets, - "x" = glue("Failed {n_failed} downloads due to missing images (status 403)")) - } - inform(bullets) - invisible(result_summary) -} - #' Collect media files #' #' @description @@ -80,12 +7,7 @@ collect_media_files <- function(.query){ #' @param df A `tibble` returned by `atlas_media()` or a pipe starting with #' `request_data(type = "media")`. #' @param thumbnail Default is `FALSE`. If `TRUE` will download small -#' thumbnail-sized images, rather than full size images (default). -#' @param path -#' `r lifecycle::badge("deprecated")` -#' Use `galah_config(directory = "path-to-directory)"` instead. Supply a path -#' to a local folder/directory where downloaded media will be saved to. -#' +#' thumbnail-sized images, rather than full size images (default). #' @return Invisibly returns a `tibble` listing the number of files downloaded, #' grouped by their HTML status codes. Primarily called for the side effect of #' downloading available image & media files to a user local directory. @@ -120,30 +42,10 @@ collect_media_files <- function(.query){ #' collect(thumbnail = TRUE) #' # step three is synonymous with `collect_media()` #' } -#' @importFrom cli col_magenta -#' @importFrom cli cli_text -#' @importFrom rlang .data #' @export collect_media <- function(df, - thumbnail = FALSE, - path - ){ - if (!missing(path)) { - lifecycle::deprecate_stop( - when = "2.0.0", - what = "collect_media(path = )", - details = "Use `galah_config(directory = )` to supply a folder path instead." - ) - } - - # suggest option to set directory in galah_config() - user_directory <- pour("package", "directory") - if (stringr::str_detect(user_directory, "Temp")) { - inform( - cli::cli_text("{cli::col_magenta('To change which file directory media files are saved to, use `galah_config(directory = )`.')}") - ) - } - + thumbnail = FALSE + ){ request_files() |> filter("media" == df) |> collapse(thumbnail = thumbnail) |> diff --git a/R/collect_metadata.R b/R/collect_metadata.R index c873fb81..583ca0bb 100644 --- a/R/collect_metadata.R +++ b/R/collect_metadata.R @@ -1,347 +1,497 @@ -#' Internal function to `collect()` APIs +# Utilities + +#' Internal function to update attributes on a metadata tibble +#' as per `galah` requirements #' @noRd #' @keywords Internal -collect_apis <- function(.query){ - result <- .query$data |> +update_attributes <- function(df, type){ + attr(df, "call") <- type # needed for `show_values()` to work + attr(df, "region") <- potions::pour("atlas", "region") # needed for caching to work + df +} + +#' Often a `.query` will have a `data` slot in place of a `url` +#' This may call e.g. `retrieve_cache()` OR an internal object +#' Either way, the string will be a valid function call set in `capture()` +#' Our job at this point is to parse that function, NOT just `retrieve_cache()` +#' @noRd +#' @keywords Internal +retrieve_internal_data <- function(.query){ + if(is.null(.query$data)){ + cli::cli_abort("Query is missing a `data` slot") + } + .query$data |> parse(text = _) |> eval() - attr(result, "call") <- "apis" - attr(result, "region") <- pour("atlas", "region") - result +} + +#' Function to convert list entries in tibbles, supporting list-columns +#' for nested data +#' @param x a list-entry - i.e. we need to call +#' purrr::map(list, tidy_list_columns) for this to work +#' @noRd +#' @keywords Internal +tidy_list_columns <- function(x){ + + # tibble-ify list columns + list_check <- purrr::map(x, is.list) |> + unlist() + if(any(list_check)){ + list_names <- names(x)[list_check] + list_tibbles <- purrr::map(list_names, + \(a){ + tibble::tibble({{a}} == list(x[[a]])) + }) + }else{ + list_tibbles <- NULL + } + + # bind with non-list columns + x[!list_check] |> + make_nulls_safe() |> + tibble::as_tibble() |> + dplyr::bind_cols(list_tibbles) |> + dplyr::select(tidyselect::any_of(names(x))) # reorder columns to same as `x` +} + +#' Internal function to ensure rows can be converted to tibble +#' This is important because some lists contain `NULL` +#' The function fixes it by converting to `NA` +#' @param x a single list, to be converted into a tibble row. use map() for multiple rows +#' @noRd +#' @keywords Internal +make_nulls_safe <- function(x){ + x_null <- purrr::map(x, is.null) |> + unlist() + if(any(x_null)){ + x[x_null] <- purrr::map(x[x_null], \(a){c(NA)}) + } + x +} + +# collect functions + +#' Internal function to `collect()` APIs +#' @noRd +#' @keywords Internal +collect_apis <- function(.query){ + retrieve_internal_data(.query) |> + update_attributes(type = "apis") |> + parse_select(.query) } #' Internal function to `collect()` assertions -#' @importFrom dplyr bind_rows #' @noRd #' @keywords Internal collect_assertions <- function(.query){ if(!is.null(.query$data)){ - result <- .query$data |> - parse(text = _) |> - eval() - attr(result, "call") <- "assertions" # needed for `show_values()` to work - attr(result, "region") <- pour("atlas", "region") # needed for caching to work + result_df <- retrieve_internal_data(.query) }else{ - result <- lapply(query_API(.query), - function(a){a[names(a) != "termsRequiredToTest"]}) |> - bind_rows() - names(result) <- rename_columns(names(result), type = "assertions") - result <- result[wanted_columns("assertions")] - result$type <- "assertions" - attr(result, "call") <- "assertions" # needed for `show_values()` to work - attr(result, "region") <- pour("atlas", "region") # needed for caching to work - check_internal_cache(assertions = result) + # get data from API + result_api <- purrr::map(query_API(.query), + \(a){a[names(a) != "termsRequiredToTest"]}) + # set up a pipe to transform results from the API + result_df <- result_api |> + dplyr::bind_rows() |> + dplyr::rename_with(camel_to_snake_case) |> + parse_rename(.query) |> + dplyr::mutate(type = "assertions") |> # for consistency with `collect_fields()` + update_attributes(type = "assertions") + update_cache(assertions = result_df) } - result + parse_select(result_df, .query) # always evaluate `select()` last } #' Internal function to `collect()` atlases +#' NOTE: This function does not cache anything because it *always* calls internal data #' @noRd #' @keywords Internal collect_atlases <- function(.query){ - result <- .query$data |> - parse(text = _) |> - eval() - attr(result, "call") <- "atlases" - attr(result, "region") <- pour("atlas", "region") - result + retrieve_internal_data(.query) |> + update_attributes(type = "atlases") |> + parse_select(.query) } #' Internal function to `collect()` collections -#' @importFrom dplyr bind_rows -#' @importFrom dplyr relocate -#' @importFrom dplyr rename -#' @importFrom purrr pluck #' @noRd #' @keywords Internal collect_collections <- function(.query){ - if(is_gbif()){ - result <- query_API(.query) - if(any(names(result) == "results")){ # happens when `filter()` not specified - # Note: This assumes only one API call; will need more potentially - result <- pluck(result, "results") - } - result <- flat_lists_only(result) |> - bind_rows() - }else if(pour("atlas", "region", .pkg = "galah") == "France"){ - result <- query_API(.query) |> - pluck("_embedded", "producers") |> - unlist() - result <- tibble(name = result) + if(!is.null(.query$data)){ + result_df <- retrieve_internal_data(.query) }else{ - result <- query_API(.query) |> - bind_rows() - result_reordered <- relocate(result, "uid") - result <- result_reordered |> rename("id" = "uid") + # Handle GBIF first + if(is_gbif()){ + result <- query_API(.query) + if(any(names(result) == "results")){ # happens when `filter()` not specified + # Note: This assumes only one API call; will need more potentially + result <- purrr::pluck(result, "results") + } + result_df <- result |> + purrr::map(tidy_list_columns) |> + dplyr::bind_rows() + # Then France + }else if(potions::pour("atlas", "region", .pkg = "galah") == "France"){ + result <- .query |> + query_API() |> + purrr::pluck("_embedded", "producers") |> + unlist() + result_df <- tibble::tibble(name = result) + # Finally, all other Living Atlases + }else{ + result <- .query |> + query_API() + result_df <- result |> + dplyr::bind_rows() + if(any(colnames(result_df) == "uid")){ + result_df <- result_df |> + dplyr::relocate("uid") |> + dplyr::rename("id" = "uid") + } + } + + if(nrow(result_df) > 0){ + result_df <- result_df |> + dplyr::rename_with(camel_to_snake_case) |> + parse_arrange() |> + update_attributes(type = "collections") + update_cache(collections = result_df) + } + } - attr(result, "call") <- "collections" - attr(result, "region") <- pour("atlas", "region") - result + parse_select(result_df, .query) } -#' Internal function to remove `list()` entries inside lists -#' This supports passing to `bind_rows()`, but loses data +#' Internal function to `collect()` config +#' @returns a tibble containing 4 columns (strings) and one row: +#' - `client_id` +#' - `client_secret` (tbd) +#' - `authorize_url` +#' - `token_url` +#' - `scopes` +#' @details +#' This is the *ONLY* function in galah that doesn't call `query_API()`, +#' for the simple reason that it is sometimes called _inside_ that function, +#' and we dont' want recursive queries here. #' @noRd #' @keywords Internal -flat_lists_only <- function(x){ - lapply(x, - function(a){ - lapply(a, function(b){ - if(is.list(b)){ - NULL - }else{ - b - } - }) - }) +collect_config <- function(.query){ + if(!is.null(.query$data)){ + result <- retrieve_internal_data(.query) + }else{ + result <- query_API(.query) |> + tibble::as_tibble() |> + update_attributes(type = "config") + update_cache(config = result) + } + result } #' Internal function to `collect()` datasets -#' @importFrom dplyr bind_rows -#' @importFrom dplyr relocate -#' @importFrom dplyr rename #' @noRd #' @keywords Internal collect_datasets <- function(.query){ - result <- query_API(.query) - if(is_gbif()){ - if(any(names(result) == "results")){ # happens when `filter()` not specified - # Note: This assumes only one API call; will need more potentially - result <- pluck(result, "results") - } - result <- result |> - flat_lists_only() |> - bind_rows() - }else if(pour("atlas", "region", .pkg = "galah") == "France"){ - result <- result |> - pluck("_embedded", "datasets") |> - bind_rows() + if(!is.null(.query$data)){ + result_df <- retrieve_internal_data(.query) }else{ - result <- result |> - bind_rows() |> - relocate("uid") |> - rename("id" = "uid") + result <- query_API(.query) + if(is_gbif()){ + if(any(names(result) == "results")){ # happens when `filter()` not specified + # Note: This assumes only one API call; will need more potentially + result <- purrr::pluck(result, "results") + } + result_df <- result |> + purrr::map(tidy_list_columns) |> + dplyr::bind_rows() + }else if(potions::pour("atlas", "region", .pkg = "galah") == "France"){ + result_df <- result |> + purrr::pluck("_embedded", "datasets") |> + dplyr::bind_rows() + }else{ + result_df <- result |> + dplyr::bind_rows() |> + dplyr::relocate("uid") |> + dplyr::rename("id" = "uid") + } + result_df <- result_df |> + dplyr::rename_with(camel_to_snake_case) |> + parse_arrange() |> + update_attributes(type = "datasets") + update_cache(datasets = result_df) } - attr(result, "call") <- "datasets" - attr(result, "region") <- pour("atlas", "region") - result + parse_select(result_df, .query) } #' Internal function to `collect()` distributions -#' @importFrom dplyr any_of -#' @importFrom dplyr rename -#' @importFrom dplyr select #' @noRd #' @keywords Internal collect_distributions_metadata <- function(.query){ result <- query_API(.query) result <- result |> - bind_rows() |> - select("spcode", - "family", - "genus_name", - "scientific", - "common_nam", - "lsid", - "area_name", - "area_km", - "data_resource_uid") |> - rename( + dplyr::bind_rows() |> + # NOTE: This syntax should be integrated with `lookup_select_columns()` et al before shipping + dplyr::select( + "spcode", + "family", + "genus_name", + "scientific", + "common_nam", + "lsid", + "area_name", + "area_km", + "data_resource_uid") |> + dplyr::rename( "id" = "spcode", # this is chosen as ID because it is called by later APIs "genus" = "genus_name", "species" = "scientific", "taxon_concept_id" = "lsid", "label" = "area_name", "common_name" = "common_nam") |> - mutate("common_name" = trimws(.data$common_name)) # remove leading or trailing spaces - attr(result, "call") <- "distributions" - attr(result, "region") <- pour("atlas", "region") + dplyr::mutate("common_name" = trimws(.data$common_name)) # remove leading or trailing spaces + result <- update_attributes(result, type = "distributions") + update_cache(distributions = result) result } #' Internal function to `collect()` fields -#' @importFrom dplyr all_of -#' @importFrom dplyr bind_rows -#' @importFrom dplyr mutate -#' @importFrom dplyr select #' @noRd #' @keywords Internal collect_fields <- function(.query){ - if(is_gbif()){ - result <- .query$data |> - parse(text = _) |> - eval() - attr(result, "call") <- "fields" - attr(result, "region") <- pour("atlas", "region") - result + if(!is.null(.query$data)){ + result_df <- retrieve_internal_data(.query) }else{ - if(!is.null(.query$url)){ # i.e. there is no cached `tibble` - result <- query_API(.query) |> - bind_rows() + result <- query_API(.query) |> + dplyr::bind_rows() + + if(is_gbif()){ + # we need to join some local metadata to GBIF info + df <- gbif_internal_archived$search_fields |> + dplyr::mutate(search_field = TRUE) + + # organise information from the API + result_df <- result |> + dplyr::mutate(id = .data$simpleName, + description = .data$qualifiedName, + type = "fields", + download_field = TRUE) |> + dplyr::full_join(df, by = "id") + + # clean up NAs (without `tidyr`) + result_df$download_field[is.na(result_df$download_field)] <- FALSE + result_df$search_field[is.na(result_df$search_field)] <- FALSE + + }else{ # if there is a 'stored' field, use it to filter results if(any(colnames(result) == "stored")){ - result <- result |> dplyr::filter(.data$stored == TRUE) + result_df <- result |> + dplyr::filter(.data$stored == TRUE) } # now mutate to required format - result <- result |> - mutate(id = result$name) |> - select(all_of(wanted_columns("fields"))) |> - mutate(type = "fields") |> - bind_rows(galah_internal_archived$media, - galah_internal_archived$other) - attr(result, "call") <- "fields" - attr(result, "region") <- pour("atlas", "region") - check_internal_cache(fields = result) - result - }else{ # this should only happen when `data` slot is present in place of `url` - check_internal_cache()[["fields"]] + result_df <- result_df |> + dplyr::mutate(id = result_df$name, + type = "fields") |> + dplyr::rename_with(camel_to_snake_case) |> + dplyr::bind_rows(galah_internal_archived$media, + galah_internal_archived$other) |> + dplyr::distinct(.data$id, .keep_all = TRUE) # please keep this line! + # Sometimes living atlases update their field lists to add or remove + # media information which is *also* added here in the `bind_rows()` line. + # Using `distinct()` is a safe way to ensure they are always present + # but **not** duplicated. } + result_df <- update_attributes(result_df, type = "fields") + update_cache(fields = result_df) } + result_df |> + parse_select(.query) |> + parse_filter(.query) } #' Internal function to `collect()` licences -#' @importFrom dplyr all_of -#' @importFrom dplyr arrange -#' @importFrom dplyr bind_rows -#' @importFrom dplyr select #' @noRd #' @keywords Internal collect_licences <- function(.query){ - result <- query_API(.query) - if(length(result) > 0){ - if (any(duplicated(names(result[[1]])))) { # remove duplicate columns (i.e. Spain atlas) - result <- lapply(result, function(x) x[unique(names(x))]) - } - result <- result |> - bind_rows() - result <- result |> - select(all_of(c("id", "name", "acronym", "url"))) |> - arrange(result$id) + if(!is.null(.query$data)){ + result_df <- retrieve_internal_data(.query) }else{ - result <- tibble(id = character(), - name = character(), - acronym = character(), - url = character()) + result <- query_API(.query) + if(length(result) > 0){ + if (any(duplicated(names(result[[1]])))) { # remove duplicate columns (i.e. Spain atlas) + result <- purrr::map(result, \(x) x[unique(names(x))]) + } + result_df <- result |> + dplyr::bind_rows() |> + dplyr::rename_with(camel_to_snake_case) |> + parse_arrange() + }else{ + result_df <- tibble::tibble(id = character(), + name = character(), + acronym = character(), + url = character()) + } + result_df <- update_attributes(result_df, type = "licences") + update_cache(licences = result_df) } - attr(result, "call") <- "licences" - attr(result, "region") <- pour("atlas", "region") - result + parse_select(result_df, .query) } #' Internal function to `collect()` lists -#' @importFrom dplyr bind_rows -#' @importFrom purrr pluck #' @noRd #' @keywords Internal collect_lists <- function(.query){ - if(inherits(.query$url, "data.frame")){ - result <- lapply(query_API(.query), - function(a){a$lists}) |> - bind_rows() + # NOTE: this function has some quite versatile behaviour, so we need to + # explicitly control when caching does (and does not) happen. + should_update_cache <- FALSE + + # requests for cached data use the `data` slot; check this first + if(!is.null(.query$data)){ + result_df <- retrieve_internal_data(.query) }else{ - result <- query_API(.query) |> - pluck("lists") |> - bind_rows() + # here we run and parse an API call + result <- query_API(.query) # this when `url` is a single value or a tibble + # pagination returns long lists - handle using `map()` + # if(length(result) > 1 & is.null(names(result))){ # this old code is risky + # test for pagination requests in .query instead + if(inherits(.query$url, "data.frame")){ + result_df <- purrr::map(query_API(.query), + \(a){a$lists}) |> + dplyr::bind_rows() + should_update_cache <- TRUE + }else{ + lists_slot <- purrr::pluck(result, "lists") + # single-list queries that use `filter()` don't have a `lists` slot + if(is.null(lists_slot)){ + result_df <- result |> + make_nulls_safe() |> + tibble::as_tibble() + # but some queries do + }else{ + result_df <- lists_slot |> + dplyr::bind_rows() + should_update_cache <- TRUE + } + } + + # cleaning + result_df <- result_df |> + dplyr::rename_with(camel_to_snake_case) |> + parse_rename(.query) |> + parse_arrange() |> + update_attributes(type = "lists") + + if(should_update_cache){ + update_cache(lists = result_df) + } } - result <- result |> - rename("species_list_uid" = "dataResourceUid") - attr(result, "call") <- "lists" - attr(result, "region") <- pour("atlas", "region") - result + # return + parse_select(result_df, .query) +} + +#' Internal version of `collect()` for `request_metadata(type = "media")` +#' @param object of class `data_response`, from `compute()` +#' @noRd +#' @keywords Internal +collect_media_metadata <- function(.query, + error_call = rlang::caller_env()){ + result <- query_API(.query) + + # ensure list-columns are imported correctly + result_df <- result |> + purrr::map(tidy_list_columns) |> + dplyr::bind_rows() + + # Select only the information we want + # NOTE: this has no caching *on purpose* + result_df |> + dplyr::rename_with(camel_to_snake_case) |> + parse_rename(.query) |> + dplyr::filter(!is.na(.data$media_id)) |> + parse_select(.query) } #' Internal function to `collect()` profiles -#' @importFrom dplyr all_of -#' @importFrom dplyr arrange -#' @importFrom dplyr bind_rows -#' @importFrom dplyr filter -#' @importFrom dplyr select #' @noRd #' @keywords Internal collect_profiles <- function(.query){ - if(!is.null(.query$url)){ - result <- query_API(.query) |> - bind_rows() - result <- result |> - filter(!duplicated(result$id)) |> - arrange("id") |> - select(all_of(wanted_columns(type = "profile"))) - attr(result, "call") <- "profiles" - attr(result, "region") <- pour("atlas", "region") - check_internal_cache(show_all_profiles = result) - result + if(!is.null(.query$data)){ + result_df <- retrieve_internal_data(.query) }else{ - check_internal_cache()[["profiles"]] + result <- query_API(.query) |> + dplyr::bind_rows() + result_df <- result |> + dplyr::filter(!duplicated(.data$id)) |> + dplyr::rename_with(camel_to_snake_case) |> + parse_arrange() |> + update_attributes(type = "profiles") + update_cache(profiles = result_df) } + result_df |> + parse_select(.query) |> + parse_filter(.query) } #' Internal function to `collect()` providers -#' @importFrom dplyr bind_rows -#' @importFrom dplyr rename #' @noRd #' @keywords Internal collect_providers <- function(.query){ - result <- query_API(.query) - if(is_gbif()){ - if(any(names(result) == "results")){ # happens when `filter()` not specified - # Note: This assumes only one API call; will need more potentially - result <- pluck(result, "results") - } - result <- result |> - flat_lists_only() |> - bind_rows() - }else if(pour("atlas", "region", .pkg = "galah") == "France"){ - result <- tibble(name = { - pluck(result, "_embedded", "providers") |> - unlist() - }) + if(!is.null(.query$data)){ + result_df <- retrieve_internal_data(.query) }else{ - result <- result |> - bind_rows() - if(nrow(result) > 0){ # exception added because this API isn't always populated (e.g. France) - result <- result |> - relocate("uid") |> - rename("id" = "uid") + result <- query_API(.query) + if(is_gbif()){ + if(any(names(result) == "results")){ # happens when `filter()` not specified + # Note: This assumes only one API call; will need more potentially + result <- purrr::pluck(result, "results") + } + result_df <- result |> + purrr::map(tidy_list_columns) |> + dplyr::bind_rows() + }else if(potions::pour("atlas", "region", .pkg = "galah") == "France"){ + result_df <- tibble::tibble(name = { + purrr::pluck(result, "_embedded", "providers") |> + unlist() + }) + }else{ + result_df <- result |> + dplyr::bind_rows() + if(nrow(result_df) > 0){ # exception added because this API isn't always populated (e.g. France) + result_df <- result_df |> + dplyr::relocate("uid") |> + dplyr::rename("id" = "uid") + } } + result_df <- result_df |> + dplyr::rename_with(camel_to_snake_case) |> + parse_arrange() |> + update_attributes(type = "providers") + update_cache(providers = result_df) } - attr(result, "call") <- "providers" - attr(result, "region") <- pour("atlas", "region") - result + parse_select(result_df, .query) } #' Internal function to `collect()` APIs #' @noRd #' @keywords Internal collect_ranks <- function(.query){ - result <- .query$data |> - parse(text = _) |> - eval() - attr(result, "call") <- "ranks" - attr(result, "region") <- pour("atlas", "region") - result + retrieve_internal_data(.query) |> + update_attributes(type = "ranks") |> + parse_select(.query) } #' Internal function to `collect()` reasons -#' @importFrom dplyr all_of -#' @importFrom dplyr arrange -#' @importFrom dplyr bind_rows -#' @importFrom dplyr filter -#' @importFrom dplyr select #' @noRd #' @keywords Internal collect_reasons <- function(.query){ - if(!is.null(.query$url)){ - result <- query_API(.query) |> - bind_rows() - result <- result |> - filter(!result$deprecated) |> - select(all_of(wanted_columns("reasons"))) |> - arrange("id") - attr(result, "call") <- "reasons" - attr(result, "region") <- pour("atlas", "region") - check_internal_cache(reasons = result) - result + if(!is.null(.query$data)){ + result_df <- retrieve_internal_data(.query) }else{ - check_internal_cache()[["reasons"]] + result <- query_API(.query) |> + dplyr::bind_rows() + result_df <- result |> + dplyr::filter(!.data$deprecated) |> + dplyr::relocate("id", "name") |> + parse_arrange() |> + update_attributes(type = "reasons") + update_cache(reasons = result_df) } -} + parse_select(result_df, .query) +} \ No newline at end of file diff --git a/R/collect_metadata_unnest.R b/R/collect_metadata_unnest.R new file mode 100644 index 00000000..b42ba151 --- /dev/null +++ b/R/collect_metadata_unnest.R @@ -0,0 +1,126 @@ +#' Internal function to run `compute()` for +#' `request_metadata(type = "fields") |> unnest()` +#' @noRd +#' @keywords Internal +collect_fields_unnest <- function(.query, + error_call = rlang::caller_env()){ + facet <- .query |> + purrr::pluck("url") |> + httr2::url_parse() + + if(is_gbif()){ + # get name of facet in question + facet <- purrr::pluck(facet, "query", "facet") # NOTE: "facet" (singular) + check_missing_fields(facet, call = error_call) + # get result from API + .query |> + query_API() |> + purrr::pluck(!!!list("facets", 1, "counts")) |> + dplyr::bind_rows() |> + dplyr::rename_with(camel_to_snake_case) |> + dplyr::rename({{facet}} := "name") |> + parse_select(.query) + + }else{ + facet <- purrr::pluck(facet, "query", "facets") # NOTE: "facets" (plural) + check_missing_fields(facet, call = error_call) + result <- .query |> + query_API() |> + purrr::pluck(!!!list(1, "fieldResult")) |> + dplyr::bind_rows() + + # extract unformatted facet values + if(nrow(result) > 0){ + result |> + dplyr::mutate( + field_name = stringr::str_extract(.data$i18nCode, "(?<=\\.).*"), + .before = 1) |> + dplyr::rename_with(camel_to_snake_case) |> + dplyr::rename({{facet}} := "field_name") |> + parse_select(.query) + }else{ # i.e. catch empty results + result + } + } +} + +#' Microfunction to prevent later failures due to missing field names +#' @noRd +#' @keywords Internal +check_missing_fields <- function(x, call){ + if (x == "NA") { + cli::cli_abort("No `field` passed to `show_values()`/`search_values()`.", + call = call) + } +} + +#' Internal function to run `compute()` for +#' `request_metadata(type = "lists") |> unnest()` +#' @noRd +#' @keywords Internal +collect_lists_unnest <- function(.query){ + + clean_common_names <- function(df){ + if(any(colnames(df) == "commonName")){ + df$commonName <- as.character(df$commonName) + if(any(df$commonName == "NULL")){ + df$commonName[df$commonName == "NULL"] <- NA + } + } + df + } + + # extract additional raw fields columns + clean_kvp_values <- function(df){ + if(any(colnames(df) == "kvpValues")){ + if(any(lengths(df$kvpValues) > 0)){ + df <- df |> + tidyr::unnest(cols = "kvpValues") |> + tidyr::unnest_wider("kvpValues") |> + tidyr::pivot_wider(names_from = "key", + values_from = "value") + } + } + df + } + + # get data + result <- query_API(.query) + + # process + result |> + purrr::list_transpose() |> + tibble::as_tibble() |> + clean_common_names() |> + clean_kvp_values() |> + dplyr::rename_with(camel_to_snake_case) |> + parse_rename(.query) |> + parse_select(.query) +} + +#' Internal function to run `compute()` for +#' `request_metadata(type = "profiles") |> unnest()` +#' @noRd +#' @keywords Internal +collect_profiles_unnest <- function(.query){ + result <- query_API(.query) + result |> + purrr::pluck("categories") |> + dplyr::bind_rows() |> + dplyr::pull("qualityFilters") |> + dplyr::bind_rows() |> + dplyr::rename_with(camel_to_snake_case) |> + parse_select(.query) +} + +#' Internal function to run `compute()` for +#' `request_metadata(type = "taxa") |> unnest()` +#' @noRd +#' @keywords Internal +collect_taxa_unnest <- function(.query){ + query_API(.query) |> + dplyr::bind_rows() |> + dplyr::rename_with(camel_to_snake_case) |> + parse_rename(.query) |> + parse_select(.query) +} diff --git a/R/collect_occurrences.R b/R/collect_occurrences.R index fd88e119..0d6fab68 100644 --- a/R/collect_occurrences.R +++ b/R/collect_occurrences.R @@ -6,30 +6,32 @@ #' @param file character; optional name for the downloaded file. Defaults to #' `data` followed by the system time in `%Y-%m-%d_%H-%M-%S` format, with a #' `.zip` suffix. -#' @importFrom potions pour -#' @importFrom rlang abort -#' @importFrom rlang inform -#' @importFrom tibble tibble #' @noRd #' @keywords Internal -collect_occurrences <- function(.query, wait, file = NULL){ - switch(pour("atlas", "region"), - "Austria" = collect_occurrences_direct(.query, file = file), - "United Kingdom" = collect_occurrences_direct(.query, file = file), - collect_occurrences_default(.query, wait = wait, file = file)) +collect_occurrences <- function(.query, + wait, + file = NULL, + error_call = rlang::caller_env()){ + switch(potions::pour("atlas", "region"), + "Austria" = collect_occurrences_direct(.query, + file = file, + call = error_call), + collect_occurrences_default(.query, + wait = wait, + file = file, + call = error_call)) } #' Internal function to `collect_occurrences()` for UK #' @noRd #' @keywords Internal -collect_occurrences_direct <- function(.query, file){ +collect_occurrences_direct <- function(.query, file, call){ .query$download <- TRUE .query$file <- check_download_filename(file) query_API(.query) result <- read_zip(.query$file) if(is.null(result)){ - inform("Download failed") - return(tibble()) + download_failed_message(call = call) }else{ result } @@ -38,41 +40,45 @@ collect_occurrences_direct <- function(.query, file){ #' Internal function to `collect_occurrences()` for living atlases #' @noRd #' @keywords Internal -collect_occurrences_default <- function(.query, wait, file){ +collect_occurrences_default <- function(.query, wait, file, call){ # check queue download_response <- check_queue(.query, wait = wait) if(is.null(download_response)){ - abort("No response from selected atlas") + cli::cli_abort("No response from selected atlas.", + call = call) } # get data - if(pour("package", "verbose", .pkg = "galah") & + if(potions::pour("package", "verbose", .pkg = "galah") & download_response$status == "complete") { - inform("Downloading") + scrolly_dots_message("Downloading") } # sometimes lookup info critical, but not others - unclear when/why! if(any(names(download_response) == "download_url")){ - new_object <- list(url = download_response$download_url, - download = TRUE) - new_object$file <- check_download_filename(file) + new_object <- list(type = "data/occurrences", + url = download_response$download_url, + download = TRUE, + file = check_download_filename(file)) |> + as_query() + # run downloads query_API(new_object) + # import result <- read_zip(new_object$file) }else{ return(download_response) } # handle result if(is.null(result)){ - inform("Download failed") - return(tibble()) + download_failed_message(call = call) }else{ result <- result |> - check_field_identities(.query) |> + check_field_identities(.query, error_call = call) |> check_media_cols() # check for, and then clean, media info # exception for GBIF to ensure DOIs are preserved if(!is.null(download_response$doi)){ # NOTE: GBIF documents DOIs in download response status url (it used to be automatically appended) # We extract and preserve this info for the user, as of 2025-06-10 doi <- download_response$doi - attr(result, "doi") <- paste0("https://doi.org/", doi) + attr(result, "doi") <- glue::glue("https://doi.org/{doi}") } if(!is.null(.query$search_url)){ attr(result, "search_url") <- .query$search_url @@ -85,20 +91,120 @@ collect_occurrences_default <- function(.query, wait, file){ #' @param .query An object of class `data_request` #' @noRd #' @keywords Internal -#' @importFrom potions pour -#' @importFrom rlang abort -#' @importFrom rlang inform -#' @importFrom tibble tibble collect_occurrences_doi <- function(.query, file = NULL, - error_call = caller_env()) { + call) { .query$file <- check_download_filename(file) query_API(.query) result <- read_zip(.query$file) if(is.null(result)){ - inform("Download failed.") - tibble() + download_failed_message(call = call) }else{ + # first see if DOI is returned in the API call + if(!is.null(.query$doi)){ + attr(result, "doi") <- glue::glue("https://doi.org/{.query$doi}") + } result } -} \ No newline at end of file +} + +#' collect type `data/occurrences-glimpse` +#' @noRd +#' @keywords Internal +collect_occurrences_glimpse <- function(.query){ + if(is_gbif()){ + collect_occurrences_glimpse_gbif(.query) + }else{ + collect_occurrences_glimpse_la(.query) + } +} + +#' collect type `data/occurrences-glimpse` for GBIF +#' @noRd +#' @keywords Internal +collect_occurrences_glimpse_gbif <- function(.query){ + result <- query_API(.query) + + # convert to tibble + df <- result |> + purrr::pluck("results") |> + purrr::map(tidy_list_columns) |> + dplyr::bind_rows() + attr(df, "total_n") <- result$count + + # assign new object for bespoke printing + if(tibble::is_tibble(df)){ + structure(df, + class = c("occurrences_glimpse", "tbl_df", "tbl", "data.frame")) + }else{ + df # not sure what use case this is, but probably NULL + } +} + +#' collect type `data/occurrences-glimpse` for living atlases +#' @noRd +#' @keywords Internal +collect_occurrences_glimpse_la <- function(.query){ + result <- query_API(.query) + + # pull required info from API into a tibble + df <- result |> + purrr::pluck("occurrences") |> + # non-standard fields are nested within `otherProperties` + # extract these + purrr::map(\(a){ + if(any(names(a) == "otherProperties")){ + c(a[names(a) != "otherProperties"], + a[["otherProperties"]]) + }else{ + a + } + }) |> + dplyr::bind_rows() + attr(df, "total_n") <- result$totalRecords + + # assign new object for bespoke printing + if(tibble::is_tibble(df)){ + structure(df, + class = c("occurrences_glimpse", "tbl_df", "tbl", "data.frame")) + }else{ + df # not sure what use case this is, but probably NULL + } +} + +#' Download failed message +#' @noRd +#' @keywords Internal +download_failed_message <- function(call){ + c("Download failed.", + i = "This usually suggests a problem with the download itself, rather than the API.", + i = "Consider checking that a file has been created in the expected location.") |> + cli::cli_abort(call = call) +} + +#' Theatrics +#' @noRd +#' @keywords Internal +scrolly_dots_message <- function(message) { + + spinny <- cli::make_spinner( + which = "simpleDotsScrolling", + template = paste0(message, " {spin}") + ) + + # update the spinner 100 times + lapply(1:100, function(x) { + spinny$spin() + wait(.001) + }) + + # clear the spinner from the status bar + # spinny$finish() +} + +#' Wait time +#' @noRd +#' @keywords Internal +wait <- function(seconds = 1) { + Sys.sleep(seconds) +} diff --git a/R/collect_occurrences_count.R b/R/collect_occurrences_count.R index edf9b404..db6320ab 100644 --- a/R/collect_occurrences_count.R +++ b/R/collect_occurrences_count.R @@ -2,116 +2,135 @@ #' @noRd #' @keywords Internal collect_occurrences_count <- function(.query){ - if(is_gbif()){ + {if(is_gbif()){ collect_occurrences_count_gbif(.query) }else{ collect_occurrences_count_la(.query) - } + }} |> + parse_select(.query) } #' `collect()` for `type = "data/occurrences-count"` for gbif -#' @importFrom dplyr bind_rows -#' @importFrom httr2 url_parse -#' @importFrom purrr pluck #' @noRd #' @keywords Internal -collect_occurrences_count_gbif <- function(.query){ +collect_occurrences_count_gbif <- function(.query, + error_call = rlang::caller_env()){ + # get response from GBIF result <- query_API(.query) - if(length(result$facets) < 1 & !is.null(result$count)){ # first handle single values - tibble(count = result$count) + + # first handle case when there are multiple queries in a tibble + if(inherits(result, "data.frame")){ + split(result, seq_len(nrow(result))) |> + purrr::map(.f = \(a){ + tibble::tibble( + dplyr::select(a, -"predicate", -"result"), + collect_occurrences_count_gbif_single(a$result[[1]], + error_on_null = FALSE)) + }) |> + dplyr::bind_rows() + # then handle 'simple' queries + }else{ + collect_occurrences_count_gbif_single(result, + error_on_null = TRUE) + } +} + +#' collect a single count query +#' @noRd +#' @keywords Internal +collect_occurrences_count_gbif_single <- function(result, + error_on_null = TRUE, + error_call = rlang::caller_env()){ + # handle obvious errors + if(is.null(result$count) & error_on_null){ + cli::cli_abort("API returned a NULL result", + call = error_call) + } + + # parse results + if(length(result$facets) < 1){ # first handle single values + tibble::tibble(count = result$count) }else{ - # note: this only works for length(facets) == 1 - result_df <- result |> - pluck(!!!list("facets", 1, "counts")) |> - bind_rows() - names(result_df)[1] <- .query$url |> - url_parse() |> - pluck("query", "facet") - # names(result_df)[1] <- result |> - # pluck(!!!list("facets", 1, "field")) |> - # tolower() - result_df + purrr::map( + purrr::pluck(result, "facets"), + \(a){ + df <- a |> + purrr::pluck("counts") |> + dplyr::bind_rows() + names(df)[1] <- purrr::pluck(a, "field") |> + snake_to_camel_case() + df + }) |> + dplyr::bind_rows() |> + dplyr::relocate("count", + .after = dplyr::last_col()) } } #' `collect()` for `type = "data/occurrences-count"` for living atlases -#' @importFrom dplyr bind_rows -#' @importFrom tibble tibble #' @noRd #' @keywords Internal collect_occurrences_count_la <- function(.query){ result <- query_API(.query) if(length(result$facetResults) < 1 & !is.null(result$totalRecords)){ # first handle single values - tibble(count = result$totalRecords) + tibble::tibble(count = result$totalRecords) }else{ # then when group_by() is specified clean_group_by(result, .query) |> - bind_rows() |> + dplyr::bind_rows() |> clean_labels() |> - arrange_counts(direction = .query$arrange$direction, - variable = .query$arrange$variable) + arrange_counts(direction = .query$request$slice_arrange$direction, + variable = .query$request$slice_arrange$variable) } } #' Internal function to clean objects returned by group_by() -#' @importFrom dplyr bind_cols -#' @importFrom dplyr bind_rows -#' @importFrom dplyr select -#' @importFrom dplyr slice -#' @importFrom purrr pluck #' @returns A list #' @noRd #' @keywords Internal clean_group_by <- function(result, .query){ access_list <- list(1, "fieldResult") if(inherits(.query$url, "data.frame")){ - added_cols <- select(.query$url, -url) - lapply(seq_along(result), function(a){ + added_cols <- dplyr::select(.query$url, -url) + purrr::map(seq_along(result), \(a){ # get list-cols and convert to df - result_df <- pluck(result[[a]], !!!access_list) |> - bind_rows() + result_df <- result[[a]] |> + purrr::pluck(!!!access_list) |> + dplyr::bind_rows() # add supplied cols added_cols |> - slice(a) |> - bind_cols(result_df) + dplyr::slice(a) |> + dplyr::bind_cols(result_df) }) }else{ - pluck(result, !!!access_list) + purrr::pluck(result, !!!access_list) } } #' Internal function to clean up columns when group_by() is specified -#' @importFrom dplyr all_of -#' @importFrom dplyr any_of -#' @importFrom dplyr last_col -#' @importFrom dplyr relocate -#' @importFrom dplyr rename -#' @importFrom dplyr select -#' @importFrom stringr str_extract -#' @importFrom stringr str_replace #' @noRd #' @keywords Internal clean_labels <- function(df){ if(any(colnames(df) == "i18nCode")){ values <- df$i18nCode |> - str_extract("\\.([:graph:]|\\s)+$") |> - str_replace("^\\.", "") + stringr::str_extract("\\.([:graph:]|\\s)+$") |> + stringr::str_replace("^\\.", "") variable <- df$i18nCode[1] |> - str_extract("^[:graph:]+\\.") |> - str_replace("\\.$", "") + stringr::str_extract("^[:alnum:]+\\.") |> + stringr::str_replace("\\.$", "") df[[variable]] <- values df |> - select(-any_of(c("label", "i18nCode", "fq"))) |> - relocate("count", .after = last_col()) + dplyr::relocate("count", + .after = dplyr::last_col()) }else{ # Some atlases (e.g. Estonia) only have "label" column if(any(colnames(df) == "label")){ - field_name <- str_extract(df$fq[1], "[^:]+") |> + field_name <- stringr::str_extract(df$fq[1], "[^:]+") |> as.character() col_lookup <- c("label") names(col_lookup) <- field_name df |> - rename(all_of(col_lookup)) |> - select(-"fq") + dplyr::rename(dplyr::all_of(col_lookup)) + # dplyr::select(-"fq") }else{ # some are completely empty df @@ -120,8 +139,6 @@ clean_labels <- function(df){ } #' Internal function to arrange count df -#' @importFrom dplyr arrange -#' @importFrom dplyr desc #' @noRd #' @keywords Internal arrange_counts <- function(df, @@ -129,9 +146,9 @@ arrange_counts <- function(df, variable = "count"){ var_symbol <- as.symbol(variable) if(direction == "ascending" & variable == "count"){ - arrange(df, !!var_symbol) + dplyr::arrange(df, !!var_symbol) } else if(direction == "descending" & variable != "count"){ - arrange(df, dplyr::desc(!!var_symbol)) + dplyr::arrange(df, dplyr::desc(!!var_symbol)) } else { df } diff --git a/R/collect_species.R b/R/collect_species.R index e2cbd533..045bd107 100644 --- a/R/collect_species.R +++ b/R/collect_species.R @@ -26,9 +26,6 @@ get_clean_colnames <- function(file, facet){ quiet = TRUE) if(length(column_names) > 0){ column_names <- camel_to_snake_case(column_names) - if(grepl("ID$", facet)){ - column_names[1] <- "taxon_concept_id" - } column_names[column_names %in% c("counts", "number_of_records")] <- "count" column_names }else{ diff --git a/R/collect_species_count.R b/R/collect_species_count.R index 4badc615..46a5d5d3 100644 --- a/R/collect_species_count.R +++ b/R/collect_species_count.R @@ -1,24 +1,23 @@ #' Internal function to collect counts for species -#' @importFrom dplyr bind_cols -#' @importFrom dplyr select -#' @importFrom tibble tibble #' @noRd #' @keywords Internal collect_species_count <- function(.query){ result <- query_API(.query) - counts <- lapply(result, extract_species_count) |> unlist() + counts <- purrr::map(result, extract_species_count) |> + unlist() if(nrow(.query$url) > 1){ - select(.query$url, -url) |> - bind_cols(tibble(count = counts)) + .query |> + purrr::pluck("url") |> + dplyr::select(-url) |> + dplyr::bind_cols(tibble::tibble(count = counts)) }else{ - tibble(count = counts) + tibble::tibble(count = counts) } } #' Internal function to extract counts for species -#' @importFrom purrr pluck #' @noRd #' @keywords Internal extract_species_count <- function(x){ - pluck(x, !!!list(1, "count")) + purrr::pluck(x, !!!list(1, "count")) } diff --git a/R/collect_taxa.R b/R/collect_taxa.R index ad9f75b4..2d4337d3 100644 --- a/R/collect_taxa.R +++ b/R/collect_taxa.R @@ -1,123 +1,134 @@ #' Internal function to `collect()` taxa -#' @importFrom dplyr any_of -#' @importFrom dplyr bind_rows -#' @importFrom dplyr select -#' @importFrom tibble as_tibble #' @noRd #' @keywords Internal collect_taxa <- function(.query){ - if(grepl("namematching|name-matching", .query$url$url[1])){ + if(stringr::str_detect(.query$url$url[1], "namematching|name-matching")){ collect_taxa_namematching(.query) # Australia, Spain, Sweden + }else if(stringr::str_detect(.query$url$url[1], "api.gbif.org")){ + collect_taxa_gbif(.query) }else{ - if(is_gbif()){ - collect_taxa_gbif(.query) - }else{ - collect_taxa_la(.query) # tested for Austria, UK - } + collect_taxa_la(.query) # tested for Austria, UK } } #' Internal function to `collect()` taxa for Atlas of Living Australia #' @noRd #' @keywords Internal -collect_taxa_namematching <- function(.query){ +collect_taxa_namematching <- function(.query, + error_call = rlang::caller_env()){ search_terms <- .query$url$search_term - result <- lapply(query_API(.query), - build_tibble_from_nested_list) |> - bind_rows() + result <- purrr::map(query_API(.query), + build_tibble_from_nested_list) |> + dplyr::bind_rows() # break pipe for use case where all search terms are dubious (i.e. no taxonConceptID) # if(any(colnames(result) == "taxonConceptID")){ # NOTE: This code was meant to remove duplicates, but also removes all rows with NAs (which we don't want) # Might be worth returning to if this functionality is needed # result <- filter(result, !duplicated(taxonConceptID)) # } - # handle one or more returned issues values - issues <- unlist(result$issues) - - if(length(issues) > 1) { - issues_c <- paste(issues, collapse = ", ") - } else { - issues_c <- issues - } - + issues_vec <- purrr::map(result$issues, + \(a){ + b <- a[[1]] + if(length(b) <= 1){ + b + }else{ + glue::glue_collapse(b, sep = ", ") + } + }) |> + unlist() # add issues to result - result <- result |> - mutate("search_term" = search_terms, .before = "success", - issues = issues_c) - + result <- result |> + dplyr::select(-"issues") |> + dplyr::mutate("search_term" = search_terms, + .before = "success", + issues = issues_vec) # Check for homonyms - if(any(colnames(result) == "issues")){ - check_homonyms(result) - } - + check_homonyms(result, error_call = error_call) # Check for invalid search terms if (galah_config()$package$verbose) { check_search_terms(result) } - - names(result) <- rename_columns(names(result), type = "taxa") # old code - result |> select(any_of(wanted_columns("taxa"))) + result |> + dplyr::rename_with(camel_to_snake_case) |> + parse_rename(.query) |> + parse_select(.query) } #' Internal function to `collect()` taxa for other living atlases -#' @importFrom dplyr any_of -#' @importFrom dplyr bind_rows -#' @importFrom dplyr filter -#' @importFrom dplyr mutate -#' @importFrom dplyr select #' @noRd #' @keywords Internal collect_taxa_la <- function(.query){ search_terms <- .query$url$search_term result <- query_API(.query) |> clean_la_taxa(search_terms = search_terms) |> - bind_rows() + dplyr::bind_rows() if(ncol(result) > 1){ - name <- switch(pour("atlas", "region"), + name <- switch(potions::pour("atlas", "region"), "France" = "referenceID", "Portugal" = "usageKey", "guid") result <- result |> - filter(!duplicated({{name}})) |> - mutate("search_term" = search_terms) + dplyr::filter(!duplicated({{name}})) |> + dplyr::mutate("search_term" = search_terms) } - names(result) <- rename_columns(names(result), type = "taxa") # old code - result |> select(any_of(wanted_columns("taxa"))) + result |> + dplyr::rename_with(camel_to_snake_case) |> + parse_rename(.query) |> + parse_select(.query) } #' Internal function to `collect()` taxa for GBIF -#' @importFrom dplyr any_of -#' @importFrom dplyr bind_rows -#' @importFrom dplyr mutate -#' @importFrom dplyr select #' @noRd #' @keywords Internal collect_taxa_gbif <- function(.query){ search_terms <- .query$url$search_term - result <- query_API(.query) |> - bind_rows() |> - mutate("search_term" = search_terms, .before = 1) - names(result) <- rename_columns(names(result), type = "taxa") # old code - result |> select(any_of(wanted_columns("taxa"))) + query_API(.query) |> + clean_gbif_taxa() |> + dplyr::bind_rows() |> + dplyr::mutate("search_term" = search_terms, + .before = 1) |> + dplyr::rename_with(camel_to_snake_case) |> + parse_rename(.query) |> + parse_select(.query) +} + +#' Internal function to do cleaning for GBIF +#' @param result a list from a taxonomic web service +#' @noRd +#' @keywords Internal +clean_gbif_taxa <- function(result){ + purrr::map(result, + \(a){ + c( + purrr::pluck(a$usage), + { + x <- purrr::map(a$classification, + .f = \(b){b$name}) + names(x) <- purrr::map(a$classification, + .f = \(b){tolower(b$rank)}) + x + }, + a$diagnostics[lengths(a$diagnostics) < 2] + ) + }) } #' Internal function to do cleaning #' @param result a list from a taxonomic web service -#' @importFrom purrr pluck #' @noRd #' @keywords Internal clean_la_taxa <- function(result, search_terms){ - lapply(result, function(a){ + purrr::map(result, function(a){ # capture results if("_embedded" %in% names(a)) { # e.g. France list_of_results <- a |> - pluck("_embedded", "taxa") + purrr::pluck("_embedded", "taxa") } else { if("searchResults" %in% names(a)) { list_of_results <- a |> - pluck("searchResults", "results") + purrr::pluck("searchResults", "results") } else { # e.g. Portugal (single result) list_of_results <- list(a) } @@ -126,9 +137,13 @@ clean_la_taxa <- function(result, search_terms){ # find best string match to search term if (length(list_of_results) > 1) { # i.e. more than one match if ("name" %in% list_of_results[[1]]) { - taxon_names <- unlist(lapply(list_of_results, function(b){b$name})) + taxon_names <- purrr::map(list_of_results, + function(b){b$name}) |> + unlist() } else { # e.g. France - taxon_names <- unlist(lapply(list_of_results, function(b){b$scientificName})) + taxon_names <- purrr::map(list_of_results, + function(b){b$scientificName}) |> + unlist() } string_distances <- utils::adist( tolower(search_terms), @@ -144,60 +159,60 @@ clean_la_taxa <- function(result, search_terms){ } else { list_of_results <- list_of_results[[min_distance]] } - } else { - list_of_results <- list_of_results } # unlist if necessary - atlas <- pour("atlas", "region") + atlas <- potions::pour("atlas", "region") if (any(atlas %in% c("France", "Portugal"))) { - list_of_results <- list_of_results |> unlist() + list_of_results <- list_of_results |> + unlist() } list_of_results }) } #' Internal function to `collect()` identifiers -#' @importFrom dplyr any_of -#' @importFrom dplyr bind_rows -#' @importFrom dplyr mutate -#' @importFrom dplyr select #' @noRd #' @keywords Internal collect_identifiers <- function(.query){ search_terms <- .query$url$search_term result <- query_API(.query) |> - flat_lists_only() |> - bind_rows() + purrr::map(tidy_list_columns) |> + dplyr::bind_rows() + if(any(colnames(result) == "taxonConceptID")){ result <- result |> - filter(!duplicated(result$taxonConceptID)) + dplyr::filter(!duplicated(result$taxonConceptID)) } + + if(!any(colnames(result) == "success")){ # GBIF doesn't indicate success + # we avoid `is_gbif()` here because other atlases use GBIF APIs + result$success <- TRUE + result <- result |> + dplyr::relocate("success", .before = 1) |> + parse_rename(.query) + } + result <- result |> - mutate("search_term" = search_terms, .before = "success") + dplyr::mutate("search_term" = search_terms, .before = "success") # Check for invalid search terms if (galah_config()$package$verbose) { check_search_terms(result) } - names(result) <- rename_columns(names(result), type = "taxa") # old code - result |> select(any_of(wanted_columns("taxa"))) - attr(result, "call") <- "identifiers" - attr(result, "region") <- pour("atlas", "region") - result + result |> + dplyr::rename_with(camel_to_snake_case) |> + parse_rename(.query) |> + parse_select(.query) } #' Internal function to check search terms provided to `search_taxa()` -#' @importFrom glue glue_collapse -#' @importFrom cli cli_div -#' @importFrom cli cli_text -#' @importFrom cli cli_end #' @noRd #' @keywords Internal check_search_terms <- function(result, atlas) { if (!all(result$success)) { - atlas <- pour("atlas", "region") + atlas <- potions::pour("atlas", "region") d <- cli::cli_div(theme = list(span.bold = list("font-weight" = "bold"), span.yellow = list(color = "yellow"))) @@ -212,44 +227,42 @@ check_search_terms <- function(result, atlas) { "!" = cli::cli_text("{.yellow {n_invalid} unmatched search term{?s}:}") ) if (n_invalid > 3) { - invalid_taxa_truncated <- c(invalid_taxa[1:3], glue("+ {n_invalid - 3} more")) + invalid_taxa_truncated <- c(invalid_taxa[1:3], glue::glue("+ {n_invalid - 3} more")) list_invalid_taxa <- glue::glue_collapse(invalid_taxa_truncated, sep = "\", \"", last = "\" ") - bullets <- c( - bullets, - cli::cli_text(format_error_bullets(c("{.yellow \"{list_invalid_taxa}}"))) - ) } else { list_invalid_taxa <- glue::glue_collapse(invalid_taxa, sep = "\", \"") - bullets <- c( - bullets, - cli::cli_text(format_error_bullets(c("{.yellow \"{list_invalid_taxa}\"}"))) - ) } + bullets <- c( + bullets, + c("{.yellow \"{list_invalid_taxa}\"}") |> + rlang::format_error_bullets() |> + cli::cli_text()) - inform(bullets) + cli::cli_text(bullets) cli::cli_end(d) } } #' Internal function to check for homonyms in search term provided to #' `search_taxa()` -#' @importFrom glue glue_collapse #' @noRd #' @keywords Internal -check_homonyms <- function(result) { - if ("homonym" %in% result$issues) { - homonym_taxa <- result[result$issues %in% "homonym",]$search_term - list_homonym_taxa <- glue::glue_collapse(homonym_taxa, - sep = ", ") - bullets <- c( - "Search returned multiple taxa due to a homonym issue.", - i = "Please provide another rank in your search to clarify taxa.", - i = "Use a `tibble` to clarify taxa, see `?search_taxa`.", - x = glue("Homonym issue with \"{list_homonym_taxa}\".") - ) - warn(bullets) +check_homonyms <- function(result, + error_call = rlang::caller_env()) { + homonym_check <- grepl("homonym", result$issues) + if(any(homonym_check)){ + homonym_taxa <- result |> + dplyr::filter(homonym_check == TRUE) |> + dplyr::pull("search_term") + list_homonym_taxa <- glue::glue_collapse(homonym_taxa, + sep = ", ") + c("Search returned multiple taxa due to a homonym issue.", + i = "Please provide another rank in your search to clarify taxa.", + i = "Use a `tibble` to clarify taxa, see `?search_taxa`.", + x = "Homonym issue with \"{list_homonym_taxa}\".") |> + cli::cli_warn(call = error_call) } } diff --git a/R/collect_unnest.R b/R/collect_unnest.R deleted file mode 100644 index a57cf288..00000000 --- a/R/collect_unnest.R +++ /dev/null @@ -1,99 +0,0 @@ -#' Internal function to run `compute()` for -#' `request_metadata(type = "fields") |> unnest()` -#' @importFrom httr2 url_parse -#' @importFrom dplyr bind_rows -#' @importFrom dplyr mutate -#' @importFrom dplyr select -#' @importFrom purrr pluck -#' @importFrom stringr str_extract -#' @noRd -#' @keywords Internal -collect_fields_unnest <- function(.query, error_call = caller_env()){ - if(is_gbif()){ - facet <- .query |> - pluck("url") |> - url_parse() |> - pluck("query", "facet") - - if (facet == "NA") { - abort("No `field` passed to `show_values()`/`search_values()`.") - } - - result <- .query |> - query_API() |> - pluck(!!!list("facets", 1, "counts")) |> - bind_rows() - colnames(result)[which(colnames(result) == "name")[1]] <- facet - select(result, {{facet}}) - - }else{ - facet <- .query |> - pluck("url") |> - url_parse() |> - pluck("query", "facets") - - if (facet == "NA") { - abort("No `field` passed to `show_values()`/`search_values()`.") - } - - result <- .query |> - query_API() |> - pluck(!!!list(1, "fieldResult")) |> - bind_rows() - - # extract unformatted facet values - result <- result |> - mutate( - field_value = stringr::str_extract( - result$i18nCode, - "(?<=\\.).*" # everything after . - ) - ) - - colnames(result)[which(colnames(result) == "field_value")[1]] <- facet - select(result, {{facet}}) - } -} - -#' Internal function to run `compute()` for -#' `request_metadata(type = "lists") |> unnest()` -#' @noRd -#' @keywords Internal -collect_lists_unnest <- function(.query){ - result <- query_API(.query) |> - bind_rows() - - # extract additional raw fields columns - if (any(colnames(result) %in% "kvpValues")) { - result <- result |> - tidyr::unnest_wider("kvpValues") |> - tidyr::pivot_wider(names_from = "key", - values_from = "value") - } - - return(result) - -} - -#' Internal function to run `compute()` for -#' `request_metadata(type = "profiles") |> unnest()` -#' @noRd -#' @keywords Internal -collect_profiles_unnest <- function(.query){ - result <- query_API(.query) |> - pluck("categories") |> - bind_rows() - result <- result |> - pull("qualityFilters") |> - bind_rows() - result -} - -#' Internal function to run `compute()` for -#' `request_metadata(type = "taxa") |> unnest()` -#' @noRd -#' @keywords Internal -collect_taxa_unnest <- function(.query){ - query_API(.query) |> - bind_rows() -} diff --git a/R/compound.R b/R/compound.R new file mode 100644 index 00000000..e89b6d69 --- /dev/null +++ b/R/compound.R @@ -0,0 +1,275 @@ +#' Force evaluation of a database query +#' +#' @description +#' [compound()] shows the full set of queries +#' required to properly evaluate the user's request, run prior to [collapse()]. +#' +#' The number of total queries to send for a single data request is often broader +#' than the single query returned by [collapse()]. If, for example, +#' the user's query includes a call to +#' \code{\link[=identify.data_request]{identify()}}, then a taxonomic query +#' is required to run _before_ the 'final' query is attempted. In relation to +#' other functions that manipulate `_request` objects, [compound()] is called +#' within \code{\link[=collapse.data_request]{collapse()}}, and itself +#' calls [capture()] internally where required. +#' @rdname compound +#' @param x An object to be compounded. Works for `data_request`, +#' `metadata_request`, `file_request`, `query` or `prequery`. +#' @param ... Other arguments passed to [capture()]. +#' @details +#' `galah` uses an object-based pipeline to convert piped requests into +#' valid queries, and to enact those queries with the specified organisation. +#' Typically, requests open with [galah_call()] - though [request_metadata()] +#' and [request_files()] are also valid - and end with +#' \code{\link[=collect.data_request]{collect()}}. Under the hood, +#' the sequence of functions is as follows: +#' +#' [capture()] → [compound()] → +#' \code{\link[=collapse.data_request]{collapse()}} → +#' \code{\link[=compute.data_request]{compute()}} → +#' \code{\link[=collect.data_request]{collect()}} +#' +#' [compound()] is the second of the [galah_call()] workflow, and it collates +#' the complete list of queries required to send in order to meet the user's +#' data request, returned by \code{\link[=collapse.data_request]{collapse()}}. +#' @order 1 +#' @return An object of class `query_set`, which is simply a list of all `query` +#' objects required to properly evaluate the specified request. Objects are +#' listed in the order in which they will be evaluated, meaning the query +#' that the user has actually requested will be placed last. +#' @seealso To open a piped query, see [galah_call()]. For alternative +#' operations on `_request` objects, see [capture()], +#' \code{\link[=collapse.data_request]{collapse()}}, +#' \code{\link[=compute.data_request]{compute()}} or +#' \code{\link[=collect.data_request]{collect()}}. +#' @export +compound <- function(x, ...){ + UseMethod("compound") +} + +#' @rdname compound +#' @order 2 +#' @export +compound.data_request <- function(x, mint_doi = FALSE, ...){ + x |> + capture(mint_doi = mint_doi, ...) |> + compound() +} + +#' @rdname compound +#' @order 3 +#' @export +compound.metadata_request <- function(x, ...){ + x |> + capture(...) |> + compound() +} + +#' @rdname compound +#' @order 4 +#' @export +compound.files_request <- function(x, + ...){ + x |> + capture(...) |> + compound() +} + +#' @rdname compound +#' @param mint_doi Logical: should a DOI be minted for this download? Only +#' applies to `type = "occurrences"`, and only for supported atlases. +#' @order 5 +#' @export +compound.prequery <- function(x, mint_doi = FALSE, ...){ + if(stringr::str_detect(x$type, "^metadata")){ + build_query_set_metadata(x) + }else if(stringr::str_detect(x$type, "^files")){ + list(capture_media_files(x, ...)) |> + as_query_set() + }else if(x$type == "data/distribtions"){ + build_query_set_distributions(x) + }else{ + build_query_set_data(x, mint_doi = mint_doi, ...) + } +} + +#' @rdname compound +#' @order 6 +#' @export +compound.query <- function(x, ...){ + list(x) |> + as_query_set() +} + +#' @rdname compound +#' @order 7 +#' @export +compound.query_set <- function(x, ...){ + x +} + +#' Internal function to routinely apply `query_set` naming +#' @noRd +#' @keywords Internal +as_query_set <- function(x){ + structure(x, class = c("query_set", "list")) +} + +#' Internal function to build a `query_set` object +#' for object of class `data_request` +#' @noRd +#' @keywords Internal +build_query_set_metadata <- function(x){ + # create an empty object to store results + result <- list() + + # handle authentication + if(!is.null(x$request$authenticate)){ + result <- append(result, + list(request_metadata("config") |> capture())) + } + + # add checks if required + if(potions::pour("package", "run_checks")){ + result <- append(result, + switch(x$request$type, + "fields-unnest" = list(request_metadata("fields") |> capture()), + "profiles-unnest" = list(request_metadata("profiles") |> capture()), + NULL)) + } + + # then handle `filter` and `identify` queries, where supported + if(grepl("-unnest$", x$request$type)){ + if(x$request$type == "taxa-unnest"){ + # identify() calls must be parsed, irrespective of `run_checks` (which is parsed above) + if(!is.null(x$request$identify)){ + result[[(length(result) + 1)]] <- list(type = "taxa", + identify = x$request$identify) |> + structure(class = "metadata_request") |> + capture() + } + if(is.null(x$request$identify) & is.null(x$request$filter)){ + cli::cli_abort("Requests of type `taxa-unnest` must also supply one of `filter()` or `identify()`.") + } + }else if(is.null(x$request$filter)){ + current_type <- x$request$type + cli::cli_abort("Requests of type `{current_type}` must supply `filter()`.") + } + } + + # add query in last place + result[[(length(result) + 1)]] <- x + + # return object of correct class + as_query_set(result) +} + +#' Internal function to build a `query_set` object +#' for object of class `data_request` +#' @noRd +#' @keywords Internal +build_query_set_data <- function(x, mint_doi, ...){ + + # handle DOIs + if(!missing(mint_doi)){ + x$request$mint_doi <- mint_doi + } + + # set up an object + result <- list() + + # handle authentication + if( + !is.null(x$request$authenticate) & + potions::pour("atlas", "region") == "Australia" + ){ + result <- append(result, + list(request_metadata("config") |> capture())) + } + + # handle `run_checks` + # find which functions are missing from the pipe + lookup_fields <- c("arrange", "filter", "select", "group_by", "distinct") + fields_absent <- !(lookup_fields %in% names(x$request)) + names(fields_absent) <- lookup_fields + x_type <- x$request$type + + if(potions::pour("package", "run_checks") & + x_type != "occurrences-doi"){ + # add check here to see whether any filters are specified + # it is possible to only call `identify()`, for example + if(any(!fields_absent) | + x_type %in% c("species-count", "species")) { + result <- c(result, + list(request_metadata("fields") |> + select(tidyselect::everything()) |> # needed to ensure GBIF works + capture(), + request_metadata("assertions") |> capture())) + }else{ + # for living atlases, we need `collapse_fields()` to check the `lsid` field + # this isn't required for GBIF which doesn't use `fq` for taxon queries + if(!is.null(x$request$identify) & + !is_gbif()){ + result <- c(result, + list(request_metadata("fields") |> capture())) + } + } + if(x_type %in% c("occurrences", "media", "species") & + reasons_supported()) { + result[[(length(result) + 1)]] <- request_metadata("reasons") |> + capture() + } + }else{ # if select is required, we need fields even if `run_checks == FALSE` + if(!fields_absent[["select"]] | + x_type %in% c("occurrences", "species")){ + result <- c(result, + list(request_metadata("fields") |> capture(), + request_metadata("assertions") |> capture())) + } + } + + # handle `identify()` + if(!is.null(x$request$identify) & + x_type != "occurrences-doi"){ + result[[(length(result) + 1)]] <- request_metadata() |> + identify(x$request$identify) |> + capture() + } + + # handle `apply_profile()` + if(!is.null(x$request$apply_profile)){ + result[[(length(result) + 1)]] <- request_metadata("profiles") |> + capture() + } + + # handle query + result[[(length(result) + 1)]] <- x + + # return + as_query_set(result) +} + +#' Internal function to build a `query_set` object +#' for object of class `data_request` when `type = distributions` +#' @noRd +#' @keywords Internal +build_query_set_distributions <- function(x, ...){ + if(is.null(x$identify) & is.null(x$filter)){ + # find all expert distributions + result <- list( + capture_distributions_metadata(), + capture_distributions_data(x) + ) + }else{ + if(!is.null(x$identify)){ + result <- list( + capture_taxa(list(identify = x$identify)) # wrong syntax? + ) + result[[2]] <- capture_distributions_data(x) # NOTE: shouldn't call microfunctions directly + }else{ + # i.e. !is.null(x$filter) + result <- list(capture_distributions_data(x)) + } + } + as_query_set(result) +} \ No newline at end of file diff --git a/R/compute.R b/R/compute.R deleted file mode 100644 index 60b73e47..00000000 --- a/R/compute.R +++ /dev/null @@ -1,58 +0,0 @@ -#' @title Compute a query -#' @description `compute()` is useful for several purposes. It's original -#' purpose is to send a request for data, which can then be processed by the -#' server and retrieved at a later time (via `collect()`). -#' @name compute.data_request -#' @order 1 -#' @param x An object of class `data_request`, `metadata_request` or -#' `files_request` (i.e. constructed using a pipe) or `query` -#' (i.e. constructed by `collapse()`) -#' @param ... Arguments passed on to other methods -#' @return An object of class `computed_query`, which is identical to class -#' `query` except for occurrence data, where it also contains information on the -#' status of the request. -#' @export -compute.data_request <- function(x, ...){ - # x$type <- check_type(x$type) # possibly still needed; unclear - collapse(x, ...) |> # converts to an object of class `query` - compute() -} - -# if calling `compute()` after `request_metadata()` -#' @rdname compute.data_request -#' @order 2 -#' @export -compute.metadata_request <- compute.data_request - - -# if calling `compute()` after `request_files()` -#' @rdname compute.data_request -#' @order 3 -#' @export -compute.files_request <- compute.data_request - -# if calling `compute()` on an object extracted from `collapse()` -#' @rdname compute.data_request -#' @order 5 -#' @export -compute.query <- function(x, ...){ - switch(x$type, - "data/occurrences" = compute_occurrences(x), - "data/species" = { - if(is_gbif()){ - compute_occurrences(x) - }else{ - as_computed_query(x) - } - }, - as_computed_query(x) - ) -} - -#' Internal function to convert class `query` to `computed_query` -#' @noRd -#' @keywords Internal -as_computed_query <- function(x){ - class(x) <- "computed_query" - x -} diff --git a/R/compute_occurrences.R b/R/compute_occurrences.R index cccde270..a590409a 100644 --- a/R/compute_occurrences.R +++ b/R/compute_occurrences.R @@ -2,9 +2,8 @@ #' @noRd #' @keywords Internal compute_occurrences <- function(.query){ - switch(pour("atlas", "region"), + switch(potions::pour("atlas", "region"), "Austria" = compute_occurrences_la_direct(.query), - "United Kingdom" = compute_occurrences_la_direct(.query), "Global" = compute_occurrences_gbif(.query), compute_occurrences_la(.query)) } @@ -14,10 +13,9 @@ compute_occurrences <- function(.query){ #' @noRd #' @keywords Internal compute_occurrences_la_direct <- function(.query){ - result <- c(.query, - list(fields = extract_fields(.query))) - class(result) <- "computed_query" - result + c(.query, + list(fields = extract_fields(.query))) |> + structure(class = "computed_query") } #' Internal function to `compute()` for `type = "occurrences"` for GBIF @@ -28,15 +26,12 @@ compute_occurrences_gbif <- function(.query){ post_result <- query_API(.query) # returns an id status_code <- list( type = "data/occurrences", - url = paste0("https://api.gbif.org/v1/occurrence/download/", - post_result)) |> + url = glue::glue("https://api.gbif.org/v1/occurrence/download/{post_result}")) |> query_API() |> check_occurrence_response() - result <- c( - list(type = "data/occurrences"), - status_code) - class(result) <- "computed_query" - return(result) + c(list(type = "data/occurrences"), + status_code) |> + structure(class = "computed_query") } #' Internal function to `compute()` for `type = "occurrences"` for ALA @@ -47,29 +42,48 @@ compute_occurrences_la <- function(.query){ status_code <- query_API(.query) |> as.list() |> check_occurrence_response() - if(pour("package", "verbose")){ + if(potions::pour("package", "verbose")){ n_records <- status_code$total_records - inform(glue("Request for {n_records} occurrences placed in queue")) + if(!is.null(.query$request$authenticate)){ + cli::cli_text("Query sent including JWT token") + } + cli::cli_text("Request for {n_records} occurrences placed in queue.") } # return a useful object - result <- c( - list(type = "data/occurrences"), + c(list(type = "data/occurrences"), status_code, - list(fields = extract_fields(.query))) - class(result) <- "computed_query" - result + list(fields = extract_fields(.query))) |> + add_request(.query) |> + structure(class = "computed_query") } #' Internal function to get the `fields` vector from a url -#' @importFrom httr2 url_parse -#' @importFrom purrr pluck #' @noRd #' @keywords Internal extract_fields <- function(.query){ .query |> - pluck("url") |> - url_parse() |> - pluck("query", "fields") |> + purrr::pluck("url") |> + httr2::url_parse() |> + purrr::pluck("query", "fields") |> strsplit(split = ",") |> - pluck(!!!list(1)) + purrr::pluck(!!!list(1)) } + +#' Internal function to retrieve a GBIF DOI +#' @noRd +#' @keywords Internal +compute_occurrences_doi <- function(.query){ + if(stringr::str_detect(.query$url, "api.gbif.org")){ + .query$download <- NULL + result <- query_API(.query) + c(list(type = "data/occurrences-doi", + url = result$downloadLink, + download = TRUE), + result[!(names(result) %in% c("request", "downloadLink"))]) |> + add_request(.query) |> + structure(class = "computed_query") + }else{ + # living atlases just need passing onward + as_computed_query(.query) + } +} \ No newline at end of file diff --git a/R/arrange.R b/R/dplyr-arrange.R similarity index 65% rename from R/arrange.R rename to R/dplyr-arrange.R index cb4fc34e..48ee74de 100644 --- a/R/arrange.R +++ b/R/dplyr-arrange.R @@ -1,8 +1,6 @@ #' Order rows using column values #' #' @description -#' `r lifecycle::badge("experimental")` -#' #' `arrange.data_request()` arranges rows of a query on the server side, meaning #' that the query is constructed in such a way that information will be arranged #' when the query is processed. This only has an effect when used in combination @@ -44,22 +42,34 @@ #' count() |> #' collect() #' } -#' @importFrom dplyr bind_cols #' @name arrange.data_request #' @export arrange.data_request <- function(.data, ...){ - dots <- enquos(..., .ignore_empty = "all") - parsed_dots <- parse_quosures_basic(dots) - if(length(parsed_dots) == 2 & - all(names(parsed_dots) %in% c("variable", "direction"))){ - .data$arrange <- as.list(parsed_dots) |> - as.data.frame() |> - tibble() + dots <- rlang::enquos(..., .ignore_empty = "all") + if(length(dots) < 1){ + return(.data) }else{ - .data$arrange <- tibble(variable = parsed_dots, - direction = "ascending") + parsed_dots <- purrr::map(dots, \(a){ + switch(expr_type(a), + "symbol" = {rlang::as_label(a)}, + "call" = { + # NOTE: this is *deliberately* not purrr::map(), + # which raises a warning + lapply(rlang::quo_get_expr(a), rlang::as_string)}, + "literal" = {rlang::quo_get_expr(a)}, + cli::cli_abort("Quosure type not recognised.", + call = rlang::caller_env()))}) |> + unlist() + if(length(parsed_dots) > 1){ + result <- tibble::tibble(variable = parsed_dots[[2]], + direction = "descending") + }else{ + result <- tibble::tibble(variable = parsed_dots, + direction = "ascending") + } + update_request_object(.data, + arrange = result) } - return(.data) } #' @rdname arrange.data_request diff --git a/R/dplyr-collapse.R b/R/dplyr-collapse.R new file mode 100644 index 00000000..6dc2e8ba --- /dev/null +++ b/R/dplyr-collapse.R @@ -0,0 +1,96 @@ +#' Generate a query +#' +#' Constructs a query so it can be inspected before being sent. `collapse()` can +#' be called at the end of a pipe that begins with [galah_call()] to return the +#' constructed user query generated by the user's data request +#' (a `query` object). Objects +#' of class `data_request` (created using [request_data()]), `metadata_request` +#' (from [request_metadata()]) or `files_request` (from [request_files()]) are +#' all supported. +#' @name collapse.data_request +#' @order 1 +#' @param x An object to run `collapse()` on. Classes supported by `galah` +#' include `data_request`, `metadata_request` and `files_request` for building +#' queries; and `prequery`, `query` or `query_set` once constructed (via +#' [capture()] or [compound()]). +#' @param ... Arguments passed on to [capture()]. +#' @details +#' `galah` uses an object-based pipeline to convert piped requests into +#' valid queries, and to enact those queries with the specified organisation. +#' Typically, requests open with [galah_call()] - though [request_metadata()] +#' and [request_files()] are also valid - and end with +#' \code{\link[=collect.data_request]{collect()}}. Under the hood, +#' the sequence of functions is as follows: +#' +#' [capture()] → [compound()] → +#' \code{\link[=collapse.data_request]{collapse()}} → +#' \code{\link[=compute.data_request]{compute()}} → +#' \code{\link[=collect.data_request]{collect()}} +#' +#' \code{\link[=collapse.data_request]{collapse()}} constructs a complete +#' user query, ready to be sent by +#' \code{\link[=compute.data_request]{compute()}}. +#' Information required to construct a complete user query are +#' provided by [capture()] and [compound()], preceding functions to +#' parse and combine all required API calls necessary to build a user's query. +#' @return An object of class `query`, which is a list-like object containing +#' two or more of the following slots: +#' +#' - `type`: The type of query, serves as a lookup to the corresponding field in `show_all(apis)` +#' - `url`: Either: +#' - a length-1 character giving the API to be queried; or +#' - a `tibble` containing at least the field `url` and optionally others +#' - `headers`: headers to be sent with the API call +#' - `body`: body section of the API call +#' - `options`: options section of the API call +#' - `request`: captures the supplied `_request` object (see [galah_call()]) +#' +#' @seealso To open a piped query, see [galah_call()]. For alternative +#' operations on `_request` objects, see [capture()], [compound()], +#' \code{\link[=compute.data_request]{compute()}} or +#' \code{\link[=collect.data_request]{collect()}}. +#' @export +collapse.data_request <- function(x, ...){ + x |> + compound(...) |> + collapse() +} + +#' @rdname collapse.data_request +#' @order 2 +#' @export +collapse.metadata_request <- collapse.data_request + +#' @rdname collapse.data_request +#' @order 3 +#' @export +collapse.files_request <- collapse.data_request + +#' @rdname collapse.data_request +#' @order 4 +#' @export +collapse.prequery <- collapse.data_request + +#' @rdname collapse.data_request +#' @order 5 +#' @export +collapse.query <- function(x, ...){ + x +} + +# if calling `collapse()` after `compound()` +#' @rdname collapse.data_request +#' @order 6 +#' @export +collapse.query_set <- function(x, ...){ + # note: files requests do not need to call build_checks() + if(grepl("^files", x[[1]]$type)){ + x |> + purrr::pluck(!!!list(1)) + }else{ + x |> + collapse_build_checks() |> + collapse_run_checks() |> + collapse_query_set() + } +} \ No newline at end of file diff --git a/R/collect.R b/R/dplyr-collect.R similarity index 64% rename from R/collect.R rename to R/dplyr-collect.R index dc8d2b95..170bfc42 100644 --- a/R/collect.R +++ b/R/dplyr-collect.R @@ -1,22 +1,45 @@ -#' @title Retrieve a database query -#' -#' @description `collect()` attempts to retrieve the result of a query from the -#' selected API. +#' Retrieve a database query +#' +#' @description +#' Retrieve the result of a query from the server. It is the +#' default way to end a piped query that begins with [galah_call()]. #' @name collect.data_request #' @order 1 #' @param x An object of class `data_request`, `metadata_request` or -#' `files_request` (from `galah_call()`); or an object of class `query_set` or -#' `query` (from `collapse()` or `compute()`) +#' `files_request` (from `galah_call()`); or an object of class `prequery`, +#' `query_set` or `query` (from [capture()], +#' \code{\link[=collapse.data_request]{collapse()}} +#' or \code{\link[=compute.data_request]{compute()}}) #' @param ... Arguments passed on to other methods -#' @param wait logical; should `galah` wait for a response? Defaults to FALSE. +#' @param wait logical; should `galah` wait for a response? Defaults to `FALSE`. #' Only applies for `type = "occurrences"` or `"species"`. #' @param file (Optional) file name. If not given, will be set to `data` with #' date and time added. The file path (directory) is always given by #' `galah_config()$package$directory`. +#' @details +#' `galah` uses an object-based pipeline to convert piped requests into +#' valid queries, and to enact those queries with the specified organisation. +#' Typically, requests open with [galah_call()] - though [request_metadata()] +#' and [request_files()] are also valid - and end with +#' \code{\link[=collect.data_request]{collect()}}. Under the hood, +#' the sequence of functions is as follows: +#' +#' [capture()] → [compound()] → +#' \code{\link[=collapse.data_request]{collapse()}} → +#' \code{\link[=compute.data_request]{compute()}} → +#' \code{\link[=collect.data_request]{collect()}} +#' +#' \code{\link[=collect.data_request]{collect()}} is the final step of the +#' [galah_call()] workflow, and it retrieves the result of a +#' query once it is processed by the server. #' @return In most cases, `collect()` returns a `tibble` containing requested #' data. Where the requested data are not yet ready (i.e. for occurrences when #' `wait` is set to `FALSE`), this function returns an object of class `query` #' that can be used to recheck the download at a later time. +#' @seealso To open a piped query, see [galah_call()]. For alternative +#' operations on `_request` objects, see [capture()], [compound()], +#' \code{\link[=collapse.data_request]{collapse()}} or +#' \code{\link[=compute.data_request]{compute()}}. #' @export collect.data_request <- function(x, ..., wait = TRUE, file = NULL){ collapse(x, ...) |> @@ -45,18 +68,35 @@ collect.files_request <- function(x, ...){ #' @rdname collect.data_request #' @order 4 #' @export -collect.query <- function(x, ..., wait = TRUE, file = NULL){ +collect.prequery <- function(x, ...){ compute(x) |> - collect(wait = wait, file = file) + collect(...) } #' @rdname collect.data_request #' @order 5 -#' @importFrom glue glue -#' @importFrom potions pour -#' @importFrom rlang abort -#' @importFrom rlang inform -#' @importFrom tibble tibble +#' @export +collect.query <- function(x, ...){ + compute(x) |> + collect(...) +} + +#' @rdname collect.data_request +#' @order 6 +#' @export +collect.query_set <- function(x, + ..., + wait = TRUE, + file = NULL + ){ + x |> + collapse(...) |> + compute() |> + collect(wait = wait, file = file) +} + +#' @rdname collect.data_request +#' @order 7 #' @export collect.computed_query <- function(x, ..., @@ -68,7 +108,7 @@ collect.computed_query <- function(x, is.null(x$data) & # some cached metadata queries have `data` instead is.null(x$status) # finally, after `compute()`, occurrences have `status` ){ - tibble() + tibble::tibble() }else{ switch(x$type, "data/distributions" = collect_distributions(x), @@ -76,6 +116,7 @@ collect.computed_query <- function(x, "data/occurrences-count" = collect_occurrences_count(x), "data/occurrences-count-groupby" = collect_occurrences_count(x), "data/occurrences-doi" = collect_occurrences_doi(x, file = file), + "data/occurrences-glimpse" = collect_occurrences_glimpse(x), "data/species"= collect_species(x, file = file), "data/species-count" = collect_species_count(x), # "data/taxonomy" = collect_taxonomy(x), @@ -84,6 +125,7 @@ collect.computed_query <- function(x, "metadata/assertions" = collect_assertions(x), "metadata/atlases" = collect_atlases(x), "metadata/collections" = collect_collections(x), + "metadata/config" = collect_config(x), "metadata/datasets" = collect_datasets(x), "metadata/distributions" = collect_distributions_metadata(x), "metadata/fields" = collect_fields(x), @@ -101,6 +143,6 @@ collect.computed_query <- function(x, "metadata/taxa-multiple" = collect_taxa(x), "metadata/taxa-unnest" = collect_taxa_unnest(x), "metadata/identifiers" = collect_identifiers(x), - abort("unrecognised `type`")) + cli::cli_abort("Unrecognised `type`")) } } diff --git a/R/dplyr-compute.R b/R/dplyr-compute.R new file mode 100644 index 00000000..650b09e9 --- /dev/null +++ b/R/dplyr-compute.R @@ -0,0 +1,105 @@ +#' Compute a query +#' +#' @description +#' Sends a request for information to a server. This is useful +#' for requests that run a server-side process, as it separates the +#' submission of the request from its retrieval. +#' +#' Within galah, `compute()` is generally hidden as it is one part of the overall +#' process to complete a `data_request`, +#' `metadata_request` or `file_request`. However, calling +#' \code{\link[=compute.data_request]{compute()}} at the +#' end of a [galah_call()] sends a request to be completed server-side +#' (i.e., outside of R), and the result can be returned in R by +#' calling \code{\link[=collect.data_request]{collect()}} +#' at a later time. This can be preferable to calling [atlas_occurrences()], which +#' prevents execution of new code until the server-side process is complete. +#' @name compute.data_request +#' @order 1 +#' @param x An object of class `data_request`, `metadata_request` or +#' `files_request` (i.e. constructed using a pipe) or `query` +#' (i.e. constructed by \code{\link[=collapse.data_request]{collapse()}}) +#' @param ... Arguments passed on to other methods +#' @details +#' `galah` uses an object-based pipeline to convert piped requests into +#' valid queries, and to enact those queries with the specified organisation. +#' Typically, requests open with [galah_call()] - though [request_metadata()] +#' and [request_files()] are also valid - and end with +#' \code{\link[=collect.data_request]{collect()}}. Under the hood, +#' the sequence of functions is as follows: +#' +#' [capture()] → [compound()] → +#' \code{\link[=collapse.data_request]{collapse()}} → +#' \code{\link[=compute.data_request]{compute()}} → +#' \code{\link[=collect.data_request]{collect()}} +#' +#' \code{\link[=compute.data_request]{compute()}} sends a query to a server, +#' which, once completed, can be retrieved using +#' \code{\link[=collect.data_request]{collect()}}. +#' @return An object of class `computed_query`, which is identical to class +#' `query` except for occurrence data, where it also contains information on the +#' status of the request. +#' @seealso To open a piped query, see [galah_call()]. For alternative +#' operations on `_request` objects, see [capture()], [compound()], +#' \code{\link[=collapse.data_request]{collapse()}}, +#' \code{\link[=collect.data_request]{collect()}}. +#' @export +compute.data_request <- function(x, ...){ + # x$type <- check_type(x$type) # possibly still needed; unclear + collapse(x, ...) |> # converts to an object of class `query` + compute() +} + +# if calling `compute()` after `request_metadata()` +#' @rdname compute.data_request +#' @order 2 +#' @export +compute.metadata_request <- compute.data_request + + +# if calling `compute()` after `request_files()` +#' @rdname compute.data_request +#' @order 3 +#' @export +compute.files_request <- compute.data_request + +# if calling `compute()` after `capture()` +#' @rdname compute.data_request +#' @order 4 +#' @export +compute.prequery <- compute.data_request + +# if calling `compute()` on an object extracted from `collapse()` +#' @rdname compute.data_request +#' @order 5 +#' @export +compute.query <- function(x, ...){ + switch(x$type, + "data/occurrences" = compute_occurrences(x), + "data/occurrences-doi" = compute_occurrences_doi(x), + "data/species" = { + if(is_gbif()){ + compute_occurrences(x) + }else{ + as_computed_query(x) + } + }, + as_computed_query(x) + ) +} + +#' @rdname compute.data_request +#' @order 6 +#' @export +compute.query_set <- function(x, ...){ + x |> + collapse() |> + compute() +} + +#' Internal function to convert class `query` to `computed_query` +#' @noRd +#' @keywords Internal +as_computed_query <- function(x){ + structure(x, class = "computed_query") +} diff --git a/R/count-data_request.R b/R/dplyr-count.R similarity index 51% rename from R/count-data_request.R rename to R/dplyr-count.R index a1527330..c80cf94a 100644 --- a/R/count-data_request.R +++ b/R/dplyr-count.R @@ -1,24 +1,32 @@ #' Count the observations in each group #' #' `count()` lets you quickly count the unique values of one or more variables. -#' It is evaluated lazily. +#' It is evaluated lazily. `add_count()` is an equivalent that uses `mutate()` +#' to add a new column with group-wise counts. #' @name count.data_request #' @param x An object of class `data_request`, created using [galah_call()] #' @param wt currently ignored #' @param ... currently ignored #' @param sort currently ignored #' @param name currently ignored -#' @importFrom dplyr count #' @export count.data_request <- function(x, ..., wt, sort, name){ - x$type <- switch(x$type, - "occurrences" = "occurrences-count", - "species" = "species-count", - "media" = abort("type = 'media' is not supported by `count()`"), - abort("`count()` only supports `type = 'occurrences' or` `'species'`")) - x -} \ No newline at end of file + x |> + group_by(...) |> + update_request_object(count = TRUE) +} + +#' @rdname count.data_request +#' @export +add_count.data_request <- function(x, + ..., + wt = NULL, + sort = FALSE, + name = NULL){ + update_request_object(x, + add_count = TRUE) +} diff --git a/R/dplyr-distinct.R b/R/dplyr-distinct.R new file mode 100644 index 00000000..1dccf7f1 --- /dev/null +++ b/R/dplyr-distinct.R @@ -0,0 +1,161 @@ +#' Keep distinct/unique rows +#' +#' Keep only unique/distinct rows from a data frame. This is similar to +#' [unique.data.frame()] but considerably faster. It is evaluated lazily. +#' @param .data A data frame, data frame extension (e.g. a tibble), or a +#' lazy data frame (e.g. from dbplyr or dtplyr). See Methods, below, +#' for more details. +#' @param ... Variables to use when determining uniqueness. Unlike the `dplyr` +#' implementation this must be set for the function to do anything, and only +#' a single variable is used. +#' @param .keep_all If `TRUE`, keep all variables in .data. Defaults to +#' `FALSE` +#' @details +#' This function has several potential uses. In it's default mode, it simply +#' shows the unique values for a supplied field: +#' +#' \preformatted{galah_call() |> +#' distinct(basisOfRecord) |> +#' collect() +#' +#' # A tibble: 9 × 1 +#' basisOfRecord +#' +#' 1 HUMAN_OBSERVATION +#' 2 PRESERVED_SPECIMEN +#' 3 OCCURRENCE +#' 4 MACHINE_OBSERVATION +#' 5 OBSERVATION +#' 6 MATERIAL_SAMPLE +#' 7 LIVING_SPECIMEN +#' 8 FOSSIL_SPECIMEN +#' 9 MATERIAL_CITATION +#' } +#' +#' This is the same result as you would get using [show_values()]: +#' +#' \preformatted{search_all(fields, "basisOfRecord") |> +#' show_values()} +#' +#' Using [distinct()] is somewhat more reliable, however, as it doesn't rely +#' on searching the tibble returned by `show_all(fields)`. It is also more +#' efficient, particularly when caching is turned off. If the goal is to +#' retrieve the _number_ of levels of a factor, use: +#' +#' \preformatted{galah_call() |> +#' distinct(basisOfRecord) |> +#' count() |> +#' collect() +#' +#' # A tibble: 1 × 1 +#' count +#' +#' 1 9 +#' } +#' +#' When the variable passed to [distinct()] in the above example is +#' `speciesID`, this is identical to calling: +#' +#' \preformatted{atlas_counts(type = "species")} +#' +#' You can also pass \code{\link[=group_by.data_request]{group_by()}} +#' to find the number of facets per level of a second variable: +#' +#' \preformatted{galah_call() |> +#' identify("Perameles") |> +#' distinct(speciesID) |> +#' group_by(basisOfRecord) |> +#' count() |> +#' collect() +#' +#' # A tibble: 8 × 2 +#' basisOfRecord count +#' +#' 1 Human observation 7 +#' 2 Preserved specimen 9 +#' 3 Machine observation 2 +#' 4 Observation 3 +#' 5 Occurrence 3 +#' 6 Material Sample 4 +#' 7 Fossil specimen 1 +#' 8 Living specimen 1 +#' } +#' +#' By setting `.keep_all = TRUE`, we get more information on each record. +#' Due to limits on the APIs this is not a perfect analogy for running +#' [dplyr::distinct()] on raw occurrences; but it does allow us to +#' generalise [atlas_species()] to use any taxonomic identifier. For example, +#' we might choose to show data by family instead of species: +#' +#' \preformatted{galah_call() |> +#' identify("Coleoptera") |> +#' distinct(familyID, .keep_all = TRUE) |> +#' collect()} +#' +#' Using [group_by()] is also valid: +#' +#' \preformatted{galah_call() |> +#' filter(year == 2024, +#' genus == "Crinia") |> +#' group_by(speciesID) |> +#' distinct(.keep_all = TRUE) |> +#' collapse()} +#' +#' In this case, \code{\link[=collect.data_request]{collect()}} and +#' [atlas_species()] are synonymous, with the exception that the latter +#' does not require you to set the `.keep_all` argument to `TRUE`. So you +#' could instead use: +#' +#' \preformatted{galah_call() |> +#' identify("Coleoptera") |> +#' distinct(familyID) |> +#' atlas_species()} +#' +#' @examples \dontrun{ +#' galah_call() |> +#' distinct(basisOfRecord) |> +#' count() |> +#' collect() +#' } +#' @export +distinct.data_request <- function(.data, + ..., + .keep_all = FALSE){ + # NOTE: internally this is based on `group_by.data_request` + # BUT there are cases where we need to distinguish between `group_by()` and `distinct()`, + # hence the separate slots + parsed_dots <- rlang::enquos(..., + .ignore_empty = "all") |> + parse_quosures_basic() |> + parse_distinct(keep_all = .keep_all) + + update_request_object(.data, + distinct = parsed_dots) +} + +#' Internal parsing of `distinct` args +#' @noRd +#' @keywords Internal +parse_distinct <- function(dot_names, + keep_all = FALSE, + error_call = rlang::caller_env()){ + if(length(dot_names) > 0){ + if(length(dot_names) > 1){ + c( + "Too many fields supplied.", + i = "`distinct.data_request` only accepts one field.") |> + cli::cli_abort(call = error_call) + } + if(length(dot_names) > 0){ + names(dot_names) <- NULL # needed to avoid empty strings added as names + tibble::tibble(name = dot_names, + keep_all = keep_all) + }else{ + tibble::tibble(name = NA, + keep_all = keep_all) + } + }else{ + tibble::tibble(name = NA, + keep_all = keep_all) + } +} \ No newline at end of file diff --git a/R/dplyr-filter.R b/R/dplyr-filter.R new file mode 100644 index 00000000..cf2a0443 --- /dev/null +++ b/R/dplyr-filter.R @@ -0,0 +1,182 @@ +#' Keep rows that match a condition +#' +#' The `filter()` function is used to subset a data, retaining all rows that +#' satisfy your conditions. To be retained, the row must produce a value of +#' `TRUE` for all conditions. Unlike 'local' filters that act on a `tibble`, +#' the galah implementations work by amending a query which is then enacted +#' by `collect()` or one of the `atlas_` family of functions (such as +#' `atlas_counts()` or `atlas_occurrences()`). +#' @name filter.data_request +#' @order 1 +#' @param .data An object of class `data_request`, `metadata_request` +#' or `files_request`, created using [galah_call()] or related functions. +#' @param ... Expressions that return a logical value, and are defined in terms +#' of the variables in the selected atlas (and checked using `show_all(fields)`. +#' If multiple expressions are included, they are combined with the & operator. +#' Only rows for which all conditions evaluate to `TRUE` are kept. +#' @return A tibble containing filter values. +#' @seealso \code{\link[=select.data_request]{select()}}, +#' \code{\link[=group_by.data_request]{group_by()}} and [geolocate()] for +#' other ways to amend the information returned by [atlas_()] functions. Use +#' `search_all(fields)` to find fields that you can filter by, and +#' [show_values()] to find what values of those filters are available. +#' @details +#' +#' *Syntax* +#' +#' `filter()` uses non-standard evaluation +#' (NSE), and is designed to be as compatible as possible with +#' `dplyr::filter()` syntax. Permissible examples include: +#' +#' * `==` (e.g. `year = 2020`) but not `=` (for consistency with `dplyr`) +#' * `!=`, e.g. `year != 2020`) +#' * `>` or `>=` (e.g. `year >= 2020`) +#' * `<` or `<=` (e.g. `year <= 2020`) +#' * `OR` statements (e.g. `year == 2018 | year == 2020`) +#' * `AND` statements (e.g. `year >= 2000 & year <= 2020`) +#' +#' Some general tips: +#' * Separating statements with a comma is equivalent to an `AND` statement; +#' Ergo `filter(year >= 2010 & year < 2020)` is the same as +#' `_filter(year >= 2010, year < 2020)`. +#' * All statements must include the field name; so +#' `filter(year == 2010 | year == 2021)` works, as does +#' `filter(year == c(2010, 2021))`, but `filter(year == 2010 | 2021)` +#' fails. +#' * It is possible to use an object to specify required values, e.g. +#' `year_value <- 2010; filter(year > year_value)`. +#' * `solr` supports range queries on text as well as numbers; so +#' `filter(cl22 >= "Tasmania")` is valid. +#' * It is possible to filter by 'assertions', which are statements about data +#' validity, such as `filter(assertions != c("INVALID_SCIENTIFIC_NAME", "COORDINATE_INVALID")`. +#' Valid assertions can be found using `show_all(assertions)`. +#' +#' *Exceptions* +#' +#' When querying occurrences, species, or their respective counts (i.e. all of +#' the above examples), field names are checked internally against +#' `show_all(fields)`. There are some cases where bespoke field names are +#' required, as follows. +#' +#' When requesting a data download from a DOI, the field `doi` is valid, i.e.: +#' \preformatted{galah_call() |> +#' filter(doi = "a-long-doi-string") |> +#' collect()} +#' +#' For taxonomic metadata, the `taxa` field is valid: +#' \preformatted{request_metadata() |> +#' filter(taxa == "Chordata") |> +#' unnest()} +#' +#' For building taxonomic trees, the `rank` field is valid: +#' \preformatted{request_data() |> +#' identify("Chordata") |> +#' filter(rank == "class") |> +#' atlas_taxonomy()} +#' +#' Media queries are more involved, but break two rules: they accept the `media` +#' field, and they accept a tibble on the rhs of the equation. For example, +#' users wishing to break down media queries into their respective API calls +#' should begin with an occurrence query: +#' +#' \preformatted{occurrences <- galah_call() |> +#' identify("Litoria peronii) |> +#' select(group = c("basic", "media") |> +#' collect()} +#' +#' They can then use the `media` field to request media metadata: +#' \preformatted{media_metadata <- request_metadata |> +#' filter(media == occurrences) |> +#' collect()} +#' +#' And finally, the metadata tibble can be used to request files: +#' \preformatted{request_files() |> +#' filter(media == media_metadata) |> +#' collect()} +#' +#' @examples \dontrun{ +#' # basic example +#' galah_call() |> +#' filter(year >= 2019, +#' basisOfRecord == "HumanObservation") |> +#' count() |> +#' collect() +#' +#' # Field names can be parsed from objects using `{{}}` syntax, e.g. +#' field <- "year" +#' value <- "2025" +#' galah_call() |> +#' filter({{field}} == value) |> +#' count() |> +#' collect() +#' } +#' @export +filter.data_request <- function(.data, ...){ + dots <- rlang::enquos(..., .ignore_empty = "all") + check_named_input(dots) + if(is_gbif()){ + filters <- parse_quosures_data_gbif(dots) # `handle_quosures_GBIF.R` + }else{ + filters <- parse_quosures_data(dots) # `handle_quosures.R` + } + update_request_object(.data, + filter = filters) +} +# usually filters as previously for ALA, but some exceptions: +# doi == "x" in `atlas_occurrences()` +# rank == "class" in `atlas_taxonomy()` replacement for `galah_down_to()` + +#' @rdname filter.data_request +#' @order 2 +#' @export +filter.metadata_request <- function(.data, ...){ + dots <- rlang::enquos(..., .ignore_empty = "all") + check_named_input(dots) + parse_quosures_metadata(.data, dots) +} +# Note: the intended purpose of this function is to pass `filter()` +# within the API call in the same was as `filter.data_request()`. +# In theory this would power `search_all()`; but in practice many +# APIs do not support a `q` argument that allows server-side filtering. +# The exception is GBIF. +# +# An unusual distinction is that when `unnest()` is also called, `filter()` is +# used to set the thing that is unnested; this is a different kind of search +# e.g. `request_metadata() |> filter(taxa == "Chordata") |> unnest()` + +#' simple parser for metadata +#' @noRd +#' @keywords Internal +parse_quosures_metadata <- function(request, dots){ + dots_parsed <- parse_quosures_files(dots) + names(dots_parsed)[2] <- "value" + request$filter <- as_metadata_filter(dots_parsed) + # The `filter` argument sets `type` when specified + initial_type <- request$type + supplied_type <- dots_parsed$variable[1] + if(!(supplied_type %in% c("taxa", "media")) & + !grepl("s$", supplied_type)){ + filter_type <- glue::glue("{supplied_type}s") + }else{ + filter_type <- supplied_type + } + if(grepl("-unnest$", initial_type)){ + request$type <- glue::glue("{filter_type}-unnest") + }else{ + request$type <- filter_type + } + request +} + +#' @rdname filter.data_request +#' @order 3 +#' @export +filter.files_request <- function(.data, ...){ + dots <- rlang::enquos(..., .ignore_empty = "all") + check_named_input(dots) + dots_parsed <- parse_quosures_files(dots) + check_files_filter(dots_parsed) + .data$type <- dots_parsed$variable[1] + .data$filter <- dots_parsed + .data +} \ No newline at end of file diff --git a/R/dplyr-glimpse.R b/R/dplyr-glimpse.R new file mode 100644 index 00000000..f71d987b --- /dev/null +++ b/R/dplyr-glimpse.R @@ -0,0 +1,36 @@ +#' Get a glimpse of your data +#' +#' [glimpse()] is like a transposed version of [print()]: columns run down the page, +#' and data runs across. This makes it possible to see every column in a data +#' frame. It's a little like [str()] applied to a data frame but it tries to +#' show you as much data as possible. This implementation is specific +#' to `galah` and is evaluated lazily. `r lifecycle::badge("experimental")` +#' @param x An object of class `data_request` +#' @param ... Other arguments, currently ignored +#' @details +#' This implementation of [glimpse()] actually involves changing the API call +#' sent to the server, then returning a novel object class with it's own +#' [print()] method. +#' @name glimpse.data_request +#' @examples \dontrun{ +#' galah_call() |> +#' filter(year >= 2019, +#' basisOfRecord == "HumanObservation") |> +#' select(year, basisOfRecord, species) |> +#' glimpse() |> +#' collect() +#' } +#' @export +glimpse.data_request <- function(x, ...){ + update_request_object(x, glimpse = TRUE) +} + +#' @rdname glimpse.data_request +#' @export +print.occurrences_glimpse <- function(x, ...){ + y <- utils::capture.output(dplyr::glimpse(x)) + n_text <- attr(x, 'total_n') |> + formatC(big.mark = ",") + y[[1]] <- glue::glue("Rows: {n_text}") + cli::cat_line(y) +} \ No newline at end of file diff --git a/R/dplyr-group_by.R b/R/dplyr-group_by.R new file mode 100644 index 00000000..f816e01d --- /dev/null +++ b/R/dplyr-group_by.R @@ -0,0 +1,73 @@ +#' Group by one or more variables +#' +#' Most data operations are done on groups defined by variables. `group_by()` +#' takes a field name (unquoted) and performs a grouping operation. The default +#' behaviour is to use it in combination with +#' \code{\link[=count.data_request]{count()}} to give information on number +#' of occurrences per level of that field. Alternatively, you can use it +#' without count to get a download of occurrences grouped by that variable. This +#' is particularly useful when used with a taxonomic `ID` field (`speciesID`, +#' `genusID` etc.) as it allows further information to be appended to the result. +#' This is how [atlas_species()] works, for example. See +#' \code{\link[=select.data_request]{select()}} for details. +#' @param .data An object of class `data_request` +#' @param ... Zero or more individual column names to include +#' @return If any arguments are provided, returns a `data.frame` with +#' columns `name` and `type`, as per [select.data_request()]. +#' @examples \dontrun{ +#' # default usage is for grouping counts +#' galah_call() |> +#' group_by(basisOfRecord) |> +#' counts() |> +#' collect() +#' +#' # Alternatively, we can use this with an occurrence search +#' galah_call() |> +#' filter(year == 2024, +#' genus = "Crinia") |> +#' group_by(speciesID) |> +#' collect() +#' # note that this example is equivalent to `atlas_species()`; +#' # but using `group_by()` is more flexible. +#' } +#' @export +group_by.data_request <- function(.data, ...){ + parsed_dots <- rlang::enquos(..., + .ignore_empty = "all") |> + parse_quosures_basic() |> + parse_group_by() + if(!is.null(parsed_dots)){ + update_request_object(.data, group_by = parsed_dots) + # TODO: add warning when using >1 dots with `type = 'occurrences'` + # as this is not supported by the API + }else{ + .data + } +} + +#' Internal parsing of `group_by` args +#' @noRd +#' @keywords Internal +parse_group_by <- function(dot_names, + error_call = rlang::caller_env()){ + if(length(dot_names) > 0){ + if(length(dot_names) > 3){ + c( + "Too many fields supplied.", + i = "`group_by.data_request` accepts a maximum of 3 fields.") |> + cli::cli_abort(call = error_call) + } + if(length(dot_names) > 0){ + names(dot_names) <- NULL # needed to avoid empty strings added as names + df <- tibble::tibble(name = dot_names) + df$type <- ifelse(stringr::str_detect(df$name, "[[:lower:]]"), + "field", + "assertions") + df + }else{ + NULL + } + }else{ + NULL + } +} \ No newline at end of file diff --git a/R/dplyr-select.R b/R/dplyr-select.R new file mode 100644 index 00000000..05c27c14 --- /dev/null +++ b/R/dplyr-select.R @@ -0,0 +1,193 @@ +#' @title Keep or drop columns using their names +#' +#' @description Select (and optionally rename) variables in a data frame, using +#' a concise mini-language that makes it easy to refer to variables based on +#' their name. Note that unlike calling `select()` on a local tibble, this +#' implementation is only evaluated at the +#' \code{\link[=collapse.data_request]{collapse()}} stage, meaning any errors +#' or messages will be triggered at the end of the pipe. +#' +#' `select()` supports `dplyr` **selection helpers**, including: +#' +#' * \code{\link[dplyr]{everything}}: Matches all variables. This is treated +#' unusually in `galah`; see `details`. +#' * \code{\link[dplyr]{last_col}}: Select last variable, possibly with an +#' offset. +#' +#' Other helpers select variables by matching patterns in their names: +#' +#' * \code{\link[dplyr]{starts_with}}: Starts with a prefix. +#' * \code{\link[dplyr]{ends_with}}: Ends with a suffix. +#' * \code{\link[dplyr]{contains}}: Contains a literal string. +#' * \code{\link[dplyr]{matches}}: Matches a regular expression. +#' * \code{\link[dplyr]{num_range}}: Matches a numerical range like x01, +#' x02, x03. +#' +#' Or from variables stored in a character vector: +#' +#' * \code{\link[dplyr]{all_of}}: Matches variable names in a character +#' vector. All names must be present, otherwise an out-of-bounds error is +#' thrown. +#' * \code{\link[dplyr]{any_of}}: Same as `all_of()`, except that no error +#' is thrown for names that don't exist. +#' +#' Or using a predicate function: +#' +#' * \code{\link[dplyr]{where}}: Applies a function to all variables and selects those for which the function returns `TRUE`. +#' @name select.data_request +#' @param .data An object of class `data_request`, created using [galah_call()]. +#' @param ... Zero or more individual column names to include. +#' @param group `string`: (optional) name of one or more column groups to +#' include. Valid options are `"basic"`, `"event"` `"taxonomy"`, `"media"` and +#' `"assertions"`. +#' @return A tibble +#' specifying the name and type of each column to include in the +#' call to `atlas_counts()` or `atlas_occurrences()`. +#' @details +#' GBIF nodes store content in hundreds of different fields, and users often +#' require thousands or millions of records at a time. To reduce time taken to +#' download data, and limit complexity of the resulting `tibble`, it is sensible +#' to restrict the fields returned by occurrence queries. The full list of +#' available fields can be viewed with `show_all(fields)`. Note that `select()` +#' and `galah_select()` are supported for all atlases that allow downloads, with +#' the exception of GBIF, for which all columns are returned. +#' +#' Calling the argument `group = "basic"` returns the following columns: +#' +#' * `recordID` +#' * `scientificName` +#' * `taxonConceptID` +#' * `decimalLatitude` +#' * `decimalLongitude` +#' * `eventDate` +#' * `basisOfRecord` +#' * `occurrenceStatus` +#' * `dataResourceName` +#' +#' Using `group = "event"` returns the following columns: +#' +#' * `eventRemarks` +#' * `eventTime` +#' * `eventID` +#' * `eventDate` +#' * `samplingEffort` +#' * `samplingProtocol` +#' +#' Using `group = "media"` returns the following columns: +#' +#' * `multimedia` +#' * `multimediaLicence` +#' * `images` +#' * `videos` +#' * `sounds` +#' +#' Using `group = "taxonomy"` returns higher taxonomic information for a given +#' query. It is the only `group` that is accepted by `atlas_species()` as well +#' as `atlas_occurrences()`. +#' +#' Using `group = "assertions"` returns all quality assertion-related +#' columns. The list of assertions is shown by `show_all_assertions()`. +#' +#' For `atlas_occurrences()`, arguments passed to `...` should be valid field +#' names, which you can check using `show_all(fields)`. For `atlas_species()`, +#' it should be one or more of: +#' +#' * `counts` to include counts of occurrences per species. +#' * `synonyms` to include any synonymous names. +#' * `lists` to include authoritative lists that each species is included on. +#' +#' For metadata queries - as generated using [request_metadata()] or +#' [galah_call()] - `select()` can now be used to return only the requested +#' columns. Unlike data queries, this works by capturing the user's query +#' and applying it user-side, rather than amending the query. +#' +#' @seealso \code{\link[=filter.data_request]{filter()}}, +#' \code{\link[=st_crop.data_request]{st_crop()}} and +#' \code{\link[=identify.data_request]{identify()}} for other ways to restrict +#' the information returned; `show_all(fields)` to list available fields. +#' @examples \dontrun{ +#' # Download occurrence records of *Perameles*, +#' # Only return scientificName and eventDate columns +#' galah_config(email = "your-email@email.com") +#' galah_call() |> +#' identify("perameles")|> +#' select(scientificName, eventDate) |> +#' collect() +#' +#' # Only return the "basic" group of columns and the basisOfRecord column +#' galah_call() |> +#' identify("perameles") |> +#' select(basisOfRecord, group = "basic") |> +#' collect() +#' +#' # When used in a pipe, `galah_select()` and `select()` are synonymous. +#' # Hence the previous example can be rewritten as: +#' galah_call() |> +#' galah_identify("perameles") |> +#' galah_select(basisOfRecord, group = "basic") |> +#' collect() +#' } +#' @export +select.data_request <- function(.data, ..., group = NULL){ + # if(is_gbif()){ + # cli::cli_text("`select()` is not supported for GBIF occurrence downloads API v1: skipping") + # .data + # }else{ + dots <- rlang::enquos(..., .ignore_empty = "all") + list(quosure = dots, + summary = generate_summary(dots)) |> + add_group(group) |> + update_request_object(.data, select = _) + # } +} + +#' @rdname select.data_request +#' @export +select.metadata_request <- function(.data, ...){ + dots <- rlang::enquos(..., + .ignore_empty = "all") + list(quosure = dots, + summary = generate_summary(dots)) |> + update_request_object(.data, select = _) +} + + +#' internal function to summarise select function (to support `print()`) +#' @noRd +#' @keywords Internal +generate_summary <- function(dots){ + labels <- purrr::map(dots, rlang::expr_text) |> + unlist() |> + glue::glue_collapse(sep = " | ") + labels[labels != ""] +} + +#' internal function to add `group` arg to the end of a list +#' @noRd +#' @keywords Internal +add_group <- function(dots, group){ + group <- check_groups(group, n = length(dots$quosure)) + summary_length <- nchar(dots$summary) + if(is.null(group)){ + if(summary_length < 1){ + group <- "basic" + dots$group <- group + }else{ + dots$group <- vector(mode = "character", length = 0L) + } + }else{ + dots$group <- group + } + if(length(dots$group) > 0){ + if(summary_length < 1){ + separator <- "" + }else{ + separator <- " | " + } + dots$summary <- paste0(dots$summary, + separator, + "group = ", + paste(group, collapse = ", ")) + } + dots +} \ No newline at end of file diff --git a/R/slice_head.R b/R/dplyr-slice_head.R similarity index 91% rename from R/slice_head.R rename to R/dplyr-slice_head.R index f1187c35..07696530 100644 --- a/R/slice_head.R +++ b/R/dplyr-slice_head.R @@ -1,8 +1,6 @@ #' Subset rows using their positions #' #' @description -#' `r lifecycle::badge("experimental")` -#' #' `slice()` lets you index rows by their (integer) locations. For objects of #' classes `data_request` or `metadata_request`, only `slice_head()` is #' currently implemented, and selects the first `n` rows. @@ -31,16 +29,15 @@ #' slice_head(n = 3) |> #' collect() #' } -#' @importFrom tibble tibble #' @export slice_head.data_request <- function(.data, ..., n, prop, by = NULL){ # handle inputs if(!missing(n)){ - result <- tibble(slice_n = n) + result <- tibble::tibble(slice_n = n) }else if(!missing(prop)){ - result <- tibble(slice_prop = prop) + result <- tibble::tibble(slice_prop = prop) } else { - result <- tibble() + result <- tibble::tibble() } # if no data - or NULL - is provided, make no updates diff --git a/R/filter_object_classes.R b/R/filter_object_classes.R new file mode 100644 index 00000000..e7268762 --- /dev/null +++ b/R/filter_object_classes.R @@ -0,0 +1,97 @@ +#' Object classes for `filter()` queries +#' +#' In galah, there are several ways to provide filter information. To ensure +#' these are handled and printed correctly, they are assigned classes +#' @param x a list, or object of supported class +#' @name filter_object_classes +#' @order 1 +#' @export +as_data_filter <- function(x){ + structure(x, class = c("data_filter", + "tbl_df", + "tbl", + "data.frame")) +} + +#' @rdname filter_object_classes +#' @order 2 +#' @export +as_predicates_filter <- function(x){ + x |> + structure(class = c("predicates_filter", + "list")) +} + +#' @rdname filter_object_classes +#' @order 3 +#' @export +as_metadata_filter <- function(x){ + x |> + structure(class = c("metadata_filter", + "list")) +} + +#' @rdname filter_object_classes +#' @order 4 +#' @export +as_files_filter <- function(x){ + x |> + structure(class = c("files_filter", + "list")) +} + + +# Print functions for the above + +#' @rdname filter_object_classes +#' @param ... Additional arguments, currently ignored +#' @order 5 +#' @export +print.data_filter <- function(x, ...){ + filter_string <- basic_filter_print(x) + glue::glue("Object of class `data_filter`: {filter_string}") |> + cat() +} + +#' @rdname filter_object_classes +#' @order 6 +#' @export +print.predicates_filter <- function(x, ...){ + # object of class `predicates_filter` + predicates_string <- glue::glue_collapse(unlist(x), sep = " ") + glue::glue("Object of class `predicates_filter`: {predicates_string}") |> + cat() +} + +#' @rdname filter_object_classes +#' @order 7 +#' @export +print.metadata_filter <- function(x, ...){ + glue::glue("Object of class `metadata_filter` with type `{x$variable}` (n = {length(x$data)} entries)") |> + cat() +} + +#' @rdname filter_object_classes +#' @order 8 +#' @export +print.files_filter <- function(x, ...){ + glue::glue("Object of class `files_filter` with {nrow(x$data)} rows") |> + cat() +} + +#' Internal function to print filter statements +#' @noRd +#' @keywords Internal +basic_filter_print <- function(x){ + if(ncol(x) > 2){ + df <- x[, 1:3] + }else{ + df <- x + } + if(nrow(df) > 1){ + df <- df[1, ] + } + glue::glue_collapse( + apply(df, 1, function(b){paste(b, collapse = " ")}), + sep = " | ") +} \ No newline at end of file diff --git a/R/galah-package.R b/R/galah-package.R index 68e2a553..e8cc6004 100644 --- a/R/galah-package.R +++ b/R/galah-package.R @@ -3,9 +3,9 @@ #' @description #' The Global Biodiversity Information Facility (GBIF; ) #' provides tools to enable users to find, access, combine and visualise -#' biodiversity data. `galah` enables the R community to directly access data and -#' resources hosted by GBIF and several of it's subsidiary organisations, known -#' as 'nodes'. +#' biodiversity data. `galah` is a `dplyr` extension package that enables the R +#' community to directly access data and resources hosted by GBIF and several +#' of it's subsidiary organisations (known as 'nodes') using `dplyr` verbs. #' #' The basic unit of data stored by these infrastructures is #' an **occurrence** record, which is an observation of a biological entity at @@ -13,8 +13,8 @@ #' taxonomic information, or associated media such images or sounds, #' all while restricting their queries to particular taxa or locations. Users #' can specify which columns are returned by a query, or restrict their results -#' to observations that meet particular quality-control criteria. -#' +#' to observations that meet particular quality-control criteria. +#' #' For those outside Australia, 'galah' is the common name of #' *Eolophus roseicapilla*, a widely-distributed Australian bird species. #' @name galah @@ -23,31 +23,43 @@ #' #' **Getting Started** #' -#' * [galah_call()]/\code{\link[=request_data]{request_()}} Start to build a query #' * [galah_config()] Set package configuration options -#' * [show_all()] & [search_all()] Data for generating filter queries -#' * [show_values()] & [search_values()] Show or search for values _within_ -#' `fields`, `profiles`, `lists`, `collections`, `datasets` or `providers` +#' * [galah_call()]/\code{\link[=request_data]{request_()}} Start to build a request #' -#' **Amend a query** +#' **Update a request object** #' -#' * [apply_profile()]/[galah_apply_profile()] Restrict to data that pass predefined checks (ALA only) +#' * [apply_profile()] Restrict to data that pass predefined checks #' * \code{\link[=arrange.data_request]{arrange()}} Arrange rows of a query on the server side +#' * [authenticate()] Authenticate your request via OAUTH in the browser #' * \code{\link[=count.data_request]{count()}} Request counts of the specified data type -#' * [desc()] Arrange counts in descending order (when combined with \code{\link[=arrange.data_request]{arrange()}}) -#' * \code{\link[=filter.data_request]{filter()}}/[galah_filter()] Filter records -#' * [geolocate()]/[galah_geolocate()] Spatial filtering of a query -#' * \code{\link[=group_by.data_request]{group_by()}}/[galah_group_by()] Group counts by one or more fields -#' * \code{\link[=identify.data_request]{identify()}}/[galah_identify()] Search for taxonomic identifiers (see also \code{\link[=taxonomic_searches]{taxonomic_searches}}) -#' * \code{\link[=select.data_request]{select()}}/[galah_select()] Fields to report information for +#' * \code{\link[=distinct.data_request]{distinct()}} Keep distinct/unique rows +#' * \code{\link[=filter.data_request]{filter()}} Filter records (see also \code{\link[=filter_object_classes]{filter_object_classes}})) +#' * [geolocate()] Spatial filtering of a query +#' * \code{\link[=glimpse]{glimpse()}} Get a glimpse of your data +#' * \code{\link[=group_by.data_request]{group_by()}} Group counts by one or more fields +#' * \code{\link[=identify.data_request]{identify()}} Search for taxonomic identifiers (see also \code{\link[=taxonomic_searches]{taxonomic_searches}}) +#' * \code{\link[=select.data_request]{select()}} Fields to report information for #' * \code{\link[=slice_head.data_request]{slice_head()}} Choose the first n rows of a download #' * [unnest()] Expand metadata for `fields`, `lists`, `profiles` or `taxa` #' -#' **Execute a query via API** +#' **Create and execute a query** #' -#' * \code{\link[=collapse.data_request]{collapse()}} Convert a `data_request` into a `query` +#' * [capture()] Convert a request into a `prequery` or `query` +#' * [compound()] Convert an object into a `query_set` showing all calls needed for evaluation +#' * \code{\link[=collapse.data_request]{collapse()}} Convert an object to a valid `query` #' * \code{\link[=compute.data_request]{compute()}} Compute a query -#' * \code{\link[=collect.data_request]{collect()}}/\code{\link[=atlas_]{atlas_()}}/[collect_media()] Retrieve a database query +#' * \code{\link[=collect.data_request]{collect()}} Retrieve a database query +#' +#' **Wrappers for accessing data** +#' +#' * [show_all()] & [search_all()] Data for generating filter queries +#' * [show_values()] & [search_values()] Show or search for values _within_ `fields`, `profiles`, `lists`, `collections`, `datasets` or `providers` +#' * [atlas_occurrences()] Download occurrence data +#' * [atlas_counts()] Get a summary of the number of records or species +#' * [atlas_species()] Download occurrences grouped by `speciesID` +#' * [atlas_taxonomy()] Download taxonomic trees +#' * [atlas_media()] Download media metadata linked to occurrences +#' * [collect_media()] Download media (images and sounds) #' #' **Miscellaneous functions** #' @@ -67,18 +79,20 @@ #' **assertions** attached to the record. Each piece of information #' associated with a given occurrence record is stored in a **field**, #' which corresponds to a **column** when imported to an -#' `R data.frame`. See `show_all(fields)` to view valid fields, +#' `tibble`. See `show_all(fields)` to view valid fields, #' layers and assertions, or conduct a search using `search_all(fields)`. #' #' Data fields are important because they provide a means to **filter** #' occurrence records; i.e. to return only the information that you need, and #' no more. Consequently, much of the architecture of `galah` has been #' designed to make filtering as simple as possible. The easiest way to do this -#' is to start a pipe with `galah_call()` and follow it with the relevant -#' `dplyr` function; starting with `filter()`, but also including `select()`, -#' `group_by()` or others. Functions without a relevant `dplyr` synonym include -#' [galah_identify()]/`identify()` for choosing a taxon, or [galah_geolocate()]/ -#' `st_crop()` for choosing a specific location. By combining different filters, +#' is to start a pipe with [galah_call()] and follow it with the relevant +#' `dplyr` function; starting with \code{\link[=filter.data_request]{filter()}}, +#' but also including \code{\link[=select.data_request]{select()}}, +#' \code{\link[=group_by.data_request]{group_by()}} or others. Functions without +#' a relevant `dplyr` synonym include +#' \code{\link[=identify.data_request]{identify()}} for choosing a taxon, or +#' [geolocate()] for choosing a specific location. By combining different filters, #' it is possible to build complex queries to return only the most valuable #' information for a given problem. #' @@ -89,10 +103,12 @@ #' However, there are many possible data quality checks, and it is not always #' clear which are most appropriate in a given instance. Therefore, `galah` #' supports data quality **profiles**, which can be passed to -#' [galah_apply_profile()] to quickly remove undesirable records. A full list of -#' data quality profiles is returned by `show_all(profiles)`. Note this service -#' is currently only available for the Australian atlas (ALA). +#' [apply_profile()] to quickly remove undesirable records. A full list of +#' data quality profiles is returned by `show_all(profiles)`. #' +#' @importFrom rlang caller_env +#' @importFrom rlang .data +#' @importFrom rlang `:=` #' @keywords internal "_PACKAGE" diff --git a/R/galah_apply_profile.R b/R/galah_apply_profile.R index 0d1cac25..7d0a42f9 100644 --- a/R/galah_apply_profile.R +++ b/R/galah_apply_profile.R @@ -16,7 +16,7 @@ #' @param ... a profile name. Should be a `string` - the name or abbreviation #' of a data quality profile to apply to the query. Valid values can be seen #' using `show_all(profiles)` -#' @return An updated `data_request` with a completed `data_profile` slot. +#' @return An updated `data_request` with a completed `apply_profile` slot. #' @seealso [show_all()] and [search_all()] to look up available data profiles. #' [filter.data_request()] can be used for more bespoke editing of individual data #' profile filters. @@ -29,27 +29,27 @@ #' apply_profile(ALA) |> #' atlas_counts() #' } -#' @importFrom rlang enquos #' @export apply_profile <- function(.data, ...){ - dots <- enquos(..., .ignore_empty = "all") + dots <- rlang::enquos(..., .ignore_empty = "all") result <- parse_quosures_basic(dots) |> - pluck(!!!list(1)) |> + purrr::pluck(!!!list(1)) |> parse_profile() - update_data_request(.data, data_profile = result) + update_request_object(.data, + apply_profile = result) } #' @rdname apply_profile -#' @importFrom rlang enquos #' @export galah_apply_profile <- function(...){ - dots <- enquos(..., .ignore_empty = "all") |> + dots <- rlang::enquos(..., .ignore_empty = "all") |> detect_request_object() switch(class(dots[[1]])[1], "data_request" = { result <- parse_quosures_basic(dots[-1]) |> parse_profile() - update_data_request(dots[[1]], data_profile = result) + update_request_object(dots[[1]], + apply_profile = result) }, { parse_quosures_basic(dots) |> @@ -58,19 +58,16 @@ galah_apply_profile <- function(...){ } #' Internal parsing of `profile` args -#' @importFrom glue glue -#' @importFrom rlang abort #' @noRd #' @keywords Internal -parse_profile <- function(dot_names, error_call = caller_env()) { +parse_profile <- function(dot_names, + error_call = rlang::caller_env()) { n_args <- length(dot_names) if (n_args > 0) { if (n_args > 1) { - bullets <- c( - "Too many data profiles supplied.", - x = glue("`galah_apply_profile()` accepts one profile argument, not {n_args}.") - ) - abort(bullets, call = error_call) + c("Too many data profiles supplied.", + x = "`galah_apply_profile()` accepts one profile argument, not {n_args}.") |> + cli::cli_abort(call = error_call) }else{ as.character(dot_names) } diff --git a/R/galah_bbox.R b/R/galah_bbox.R index d14a57ab..af6f954a 100644 --- a/R/galah_bbox.R +++ b/R/galah_bbox.R @@ -1,13 +1,5 @@ #' @rdname geolocate #' @order 4 -#' @importFrom glue glue -#' @importFrom rlang abort -#' @importFrom rlang caller_env -#' @importFrom rlang try_fetch -#' @importFrom sf st_as_sfc -#' @importFrom sf st_bbox -#' @importFrom sf st_crs -#' @importFrom sf st_is_valid #' @export galah_bbox <- function(...) { @@ -39,43 +31,45 @@ galah_bbox <- function(...) { unrecognised_class <- class(query) bullets <- c( "`galah_bbox` input must be an sf object, data.frame or tibble.", - x = glue("Can't use object of class '{unrecognised_class}'.") - ) + x = "Can't use object of class '{unrecognised_class}'.") if (inherits(query, "character")) { suggest <- c( i = "Did you mean to use `galah_polygon`?" ) - abort(c(bullets, suggest), call = caller_env()) + cli::cli_abort(c(bullets, suggest), + call = rlang::caller_env()) } else { - abort(bullets, call = caller_env()) + cli::cli_abort(bullets, + call = rlang::caller_env()) } } # handle shapefiles - if (inherits(query, "XY")) query <- st_as_sfc(query) + if (inherits(query, "XY")) query <- sf::st_as_sfc(query) # validate spatial objects & coordinates if (!inherits(query, c("sf", "sfc"))) { if(inherits(query, c("tbl", "data.frame"))) { check_col_names(query) query <- check_n_rows(query) - query <- st_bbox(c(xmin = query$xmin, + query <- sf::st_bbox(c(xmin = query$xmin, xmax = query$xmax, ymin = query$ymin, ymax = query$ymax), - crs = st_crs("WGS84")) + crs = sf::st_crs("WGS84")) } log <- NULL # see `log` to read any warnings that may have been silenced - valid <- try_fetch( # prevent warnings + valid <- rlang::try_fetch( # prevent warnings query |> - st_as_sfc() |> - st_is_valid(), warning = function(cnd) { + sf::st_as_sfc() |> + sf::st_is_valid(), warning = function(cnd) { log <<- cnd "" }) } else { - valid <- query |> st_is_valid() + valid <- query |> + sf::st_is_valid() } if (valid != TRUE) { @@ -83,16 +77,20 @@ galah_bbox <- function(...) { "Invalid spatial object or WKT detected.", i = "Check that the spatial feature or bounding box in `galah_bbox` is correct." ) - abort(bullets, call = caller_env()) + cli::cli_abort(bullets, call = rlang::caller_env()) } else { - if (inherits(query, c("tbl", "data.frame", "bbox")) && !inherits(query, c("sf", "sfc"))) { + if (inherits(query, c("tbl", "data.frame", "bbox")) && + !inherits(query, c("sf", "sfc"))) { bbox_coords <- round(query, 5) - query <- query |> st_as_sfc(crs = st_crs("WGS84")) + query <- query |> + sf::st_as_sfc(crs = sf::st_crs("WGS84")) } else { if (inherits(query, c("sf", "sfc"))) { - query <- query |> st_bbox(crs = st_crs("WGS84")) + query <- query |> + sf::st_bbox(crs = sf::st_crs("WGS84")) bbox_coords <- round(query, 5) - query <- query |> st_as_sfc(crs = st_crs("WGS84")) # FIXME: should we define the projection? + query <- query |> + sf::st_as_sfc(crs = sf::st_crs("WGS84")) # FIXME: should we define the projection? } } } @@ -100,10 +98,12 @@ galah_bbox <- function(...) { # currently a bug where the ALA doesn't accept some polygons # to avoid any issues, any polygons are converted to multipolygons if (inherits(query, "sf") || inherits(query, "sfc")) { - inform(glue(" - Data returned for bounding box: - xmin = {bbox_coords$xmin} xmax = {bbox_coords$xmax} \\ - ymin = {bbox_coords$ymin} ymax = {bbox_coords$ymax}")) + cli::cli({ + cli::cli_text("Data returned for bounding box:") + c("xmin = {bbox_coords$xmin} xmax = {bbox_coords$xmax}", + "ymin = {bbox_coords$ymin} ymax = {bbox_coords$ymax}") |> + cli::cli_bullets() + }) out_query <- build_wkt(query) } @@ -113,14 +113,12 @@ galah_bbox <- function(...) { if(is.null(dr)){ out_query }else{ - update_data_request(dr, geolocate = out_query) + update_request_object(dr, + geolocate = out_query) } } #' Internal function to `galah_bbox` -#' @importFrom glue glue -#' @importFrom rlang warn -#' @importFrom tibble tibble #' @noRd #' @keywords Internal check_n_rows <- function(tibble) { @@ -131,25 +129,21 @@ check_n_rows <- function(tibble) { ignored_rows <- paste(2:(nrow(tibble))) bullets <- c( "More than 1 set of coordinates supplied to `galah_bbox`.", - "*" = glue("Using first row, ignoring row(s) {ignored_rows}.") - ) - warn(bullets) + "*" = "Using first row, ignoring row(s) {ignored_rows}.") + cli::cli_warn(bullets) tibble <- tibble[1, ] }else{ tibble <- tibble } } - return(tibble) } #' Internal function to `galah_bbox` -#' @importFrom glue glue -#' @importFrom rlang abort -#' @importFrom tibble tibble #' @noRd #' @keywords Internal -check_col_names <- function(tibble, error_call = caller_env()) { +check_col_names <- function(tibble, + error_call = rlang::caller_env()) { valid_col_names <- c("xmin", "xmax", "ymin", "ymax") if (!identical(sort(names(tibble)), sort(valid_col_names))) { col_names <- names(tibble[!names(tibble) %in% valid_col_names]) @@ -159,8 +153,7 @@ check_col_names <- function(tibble, error_call = caller_env()) { bullets <- c( "Incorrect column names supplied to `galah_bbox`.", i = "Column names must be: 'xmin', 'xmax', 'ymin', 'ymax'.", - x = glue("Unrecognised column name(s): '{col_names}'.") - ) - abort(bullets, call = error_call) + x = "Unrecognised column name(s): '{col_names}'.") + cli::cli_abort(bullets, call = error_call) } } diff --git a/R/galah_call.R b/R/galah_call.R index 1b4d1617..262afcdc 100644 --- a/R/galah_call.R +++ b/R/galah_call.R @@ -1,53 +1,50 @@ -#' Start building a query +#' Start building a request #' #' @description #' To download data from the selected atlas, one must construct a query. This #' query tells the atlas API what data to download and return, as well as how it -#' should be filtered. Using `galah_call()` allows you to build a piped query to +#' should be filtered. Using [galah_call()] allows you to build a piped query to #' download data, in the same way that you would wrangle data with `dplyr` and -#' the `tidyverse`. -#' @param method string: what `request` function should be called. Should be one -#' of `"data"` (default), `"metadata"` or `"files"` +#' the `tidyverse`. It is synonymous with [request_data()]; to query other +#' data types call [request_metadata()] or [request_files()]. #' @param type string: what form of data should be returned? Acceptable values #' are specified by the corresponding `request` function -#' @param ... Zero or more arguments passed to -#' \code{\link[=collapse.data_request]{collapse()}} to alter a query. Currently -#' only `mint.doi` (for occurrences) and `thumbnail` (for media downloads) are -#' supported. Both are logical. #' @details -#' In practice, `galah_call()` is a wrapper to a group of underlying -#' `request_` functions, selected using the `method` argument. -#' Each of these functions can begin a piped query and end with `collapse()`, -#' `compute()` or `collect()`, or optionally one of the `atlas_` family of -#' functions. For more details see the object-oriented programming vignette: -#' \code{vignette("object_oriented_programming", package = "galah")} +#' [galah_call()] and any of the `request_` functions are used to begin a +#' piped query, which is then actioned using +#' \code{\link[=collect.data_request]{collect()}}, or optionally one of the +#' \code{\link[=atlas_occurrences]{atlas_}} family of functions. #' -#' Accepted values of the `type` argument are set by the underlying `request_` -#' functions. While all accepted types can be set directly, some are affected -#' by later functions. The most common example is that adding -#' \code{\link[=count.data_request]{count()}} to a pipe updates `type`, -#' converting `type = "occurrences"` to `type = "occurrences-count"` (and ditto -#' for `type = "species"`). +#' Having distinct functions for different types of request is useful because +#' it allows `galah` to separate different types of requests to perform better. +#' For example, [filter.data_request()]translates filters +#' to `solr` syntax for the living atlases, or to predicates for GBIF, whereas +#' [filter.metadata_request()] adds a search term to your metadata query. +#' @return Each sub-function returns a different object class: #' -#' The underlying `request_` functions are useful because they allow `galah` -#' to separate different types of requests to perform better. For example, -#' `filter.data_request` translates filters in R to `solr`, whereas -#' `filter.metadata_request` searches using a search term. -#' @return Each sub-function returns a different object class: `request_data()` -#' returns `data_request`. `request_metadata` returns `metadata_request`, -#' `request_files()` returns `files_request`. These objects are list-like and -#' contain the following slots: +#' - [request_data()] and [galah_call()] return class `"data_request"` +#' - [request_metadata()] returns class `"metadata_request"` +#' - [request_files()] returns class `"files_request"` #' -#' - `filter`: edit by piping \code{\link[=filter.data_request]{filter()}} or [galah_filter()]. -#' - `select`: edit by piping \code{\link[=filter.data_request]{select}} or [galah_select()]. -#' - `group_by`: edit by piping \code{\link[=group_by.data_request]{group_by()}} or [galah_group_by()]. -#' - `identify`: edit by piping \code{\link[=identify.data_request]{identify()}} or [galah_identify()]. -#' - `geolocate`: edit by piping \code{\link[=st_crop.data_request]{st_crop()}}, -#' [galah_geolocate()], [galah_polygon()] or [galah_bbox()]. -#' - `limit`: edit by piping \code{\link[=slice_head.data_request]{slice_head()}}. -#' - `doi`: edit by piping \code{\link[=filter.data_request]{filter(doi == "my-doi-here")}}. +#' These objects are list-like and store later dplyr verbs in the order +#' they are provided. #' -#' @seealso [collapse.data_request()], [compute.data_request()], [collect.data_request()] +#' @seealso To amend a request object, use [apply_profile()], +#' \code{\link[=arrange.data_request]{arrange()}}, +#' \code{\link[=count.data_request]{count()}}, +#' \code{\link[=distinct.data_request]{distinct()}}, +#' \code{\link[=filter.data_request]{filter()}}, +#' \code{\link[=glimpse.data_request]{glimpse()}}, +#' \code{\link[=group_by.data_request]{group_by()}}, +#' \code{\link[=identify.data_request]{identify()}}, +#' \code{\link[=select.data_request]{select}}, +#' \code{\link[=slice_head.data_request]{slice_head()}} or [unnest()]. +#' For operations on `_request` objects, see +#' [capture()], +#' [compound()], +#' \code{\link[=collapse.data_request]{collapse()}}, +#' \code{\link[=compute.data_request]{compute()}} or +#' \code{\link[=collect.data_request]{collect()}}. #' @rdname galah_call #' @examples \dontrun{ #' # Begin your query with `galah_call()`, then pipe using `%>%` or `|>` @@ -57,12 +54,14 @@ #' identify("Aves") |> #' filter(year > 2000 & year < 2005) |> #' group_by(year) |> -#' atlas_counts() +#' count() |> +#' collect() #' #' # Get information for all species in *Cacatuidae* family #' galah_call() |> #' identify("Cacatuidae") |> -#' atlas_species() +#' distinct("speciesID", .keep_all = TRUE) |> +#' collect() #' #' # Download records of genus *Eolophus* from 2001 to 2004 #' galah_config(email = "your-email@email.com") @@ -70,98 +69,37 @@ #' galah_call() |> #' identify("Eolophus") |> #' filter(year > 2000 & year < 2005) |> -#' atlas_occurrences() # synonymous with `collect()` -#' -#' -#' # galah_call() is a wrapper to various `request_` functions. -#' # These can be called directly for greater specificity. -#' -#' # Get number of records of *Aves* from 2001 to 2004 by year -#' request_data() |> -#' identify("Aves") |> -#' filter(year > 2000 & year < 2005) |> -#' group_by(year) |> -#' count() |> -#' collect() -#' -#' # Get information for all species in *Cacatuidae* family -#' request_data(type = "species") |> -#' identify("Cacatuidae") |> -#' collect() -#' -#' # Get metadata information about supported atlases in galah -#' request_metadata(type = "atlases") |> #' collect() -#' #' } #' @export -galah_call <- function(method = c("data", - "metadata", - "files"), - type, - ...){ - method <- match.arg(method) - if(missing(type)){ - type <- switch(method, - "data" = "occurrences", - "metadata" = "fields", - "files" = "media") - } - switch(method, - "data" = request_data(type = type, ...), - "metadata" = request_metadata(type = type), - "files" = request_files(type = type)) -} - -#' @rdname galah_call -#' @export -request_data <- function(type = c("occurrences", +galah_call <- function(type = c("occurrences", "occurrences-count", "occurrences-doi", # "distributions", "species", "species-count" - ), - ...){ + )){ if(!missing(type)){ type <- match.arg(type) }else{ type <- "occurrences" } - # create an empty list - valid_names <- c("type", - "identify", - "filter", - "select", - "group_by", - "arrange", - "geolocate", - "data_profile" - # "order" # tentatively removed - ) - default_call <- vector(mode = "list", length = length(valid_names)) - names(default_call) <- valid_names - default_call$type <- type # check_type(type) - # set default for limit? - # default_call$limit <- 100 ? - class(default_call) <- "data_request" - # update - if(length(list(...)) > 0){ - update_data_request(default_call, ...) - }else{ - default_call - } + list(type = type) |> + structure(class = "data_request") } #' @rdname galah_call -#' @importFrom glue glue -#' @importFrom rlang abort +#' @export +request_data <- galah_call + +#' @rdname galah_call #' @export request_metadata <- function(type = c("fields", "apis", "assertions", "atlases", "collections", + "config", "datasets", # "distributions", "licences", @@ -176,16 +114,14 @@ request_metadata <- function(type = c("fields", type_checked <- try(match.arg(type), silent = TRUE) if(inherits(type_checked, "try-error")){ - bullets <- c( - glue("Unrecognised metadata requested."), + c( + "Unrecognised metadata requested.", i = "See `?show_all()` for a list of valid metadata types.", - x = glue("Can't find metadata type `{type}`.") - ) - abort(bullets) + x = "Can't find metadata type `{type}`.") |> + cli::cli_abort() } - x <- list(type = type_checked) - class(x) <- "metadata_request" - return(x) + list(type = type_checked) |> + structure(class = "metadata_request") } #' @rdname galah_call @@ -194,7 +130,6 @@ request_files <- function( type = "media" # note: option to add `...` here for consistency with `request_data()` ){ - x <- list(type = match.arg(type)) - class(x) <- "files_request" - return(x) + list(type = match.arg(type)) |> + structure(class = "files_request") } diff --git a/R/galah_config.R b/R/galah_config.R index d439b767..9f2ab221 100644 --- a/R/galah_config.R +++ b/R/galah_config.R @@ -1,30 +1,46 @@ -#' Get or set configuration options that control galah behaviour -#' -#' The `galah` package supports large data downloads, and also -#' interfaces with the ALA which requires that users of some services -#' provide a registered email address and reason for downloading data. The -#' `galah_config` function provides a way to manage these issues as simply -#' as possible. -#' -#' @param \dots Options can be defined using the form `name = "value"`. -#' Valid arguments are: +#' View or set package behaviour +#' +#' @description +#' The `galah` package supports queries to a number of different data providers, +#' and once selected, it is desirable that all later queries are sent to that +#' organisation. Rather than supply this information separately in each +#' query, it is more parsimonious to cache it centrally +#' and call it as needed, which is what this function supports. +#' +#' Beyond choosing +#' an organisation, there are several other use cases for caching. Many +#' GBIF nodes require the user to supply a registered email address, +#' password, and (in some cases) a reason for downloading data, all stored via +#' `galah_config()`. This function also provides a convenient place to control +#' optional package behaviours, such as checking queries to ensure they are +#' valid (`run_checks`), informing you via email when your downloads are ready +#' (`send_email`), or controlling whether galah will provide updates on your +#' query as they are processed (`verbose`). +#' @param \dots Options can be defined using the form `name = "value"`, or +#' as a (single) named list. See details for accepted fields. +#' @details +#' Valid arguments to this function are: #' -#' * `api-key` string: A registered API key (currently unused). #' * `atlas` string: Living Atlas to point to, Australia by default. Can be -#' an organisation name, acronym, or region (see [show_all_atlases()] for -#' admissible values) -#' * `directory` string: the directory to use for the cache. +#' an organisation name, acronym, or region (see [show_all_atlases()] for +#' admissible values) +#' * `authenticate` logical: Should `galah` use authenticate your queries using +#' JWT tokens? Defaults to `FALSE`. If `TRUE`, user credentials are +#' verified prior to sending a query. This can allow users with special +#' access to download additional information in `galah`. +#' * `caching` logical: should metadata query results be cached in `options()`? +#' Defaults to `TRUE` for improved stability and speed. +#' * `directory` string: The directory to use for the disk cache. #' By default this is a temporary directory, which means that results will -#' only be cached -#' within an R session and cleared automatically when the user exits R. -#' The user may wish to set this to a non-temporary directory for +#' only be cached within an R session and cleared automatically when the user +#' exits R. The user may wish to set this to a non-temporary directory for #' caching across sessions. The directory must exist on the file system. #' * `download_reason_id` numeric or string: the "download reason" required. -#' by some ALA services, either as a numeric ID (currently 0--13) -#' or a string (see `show_all(reasons)` for a list of valid ID codes and -#' names). By default this is NA. Some ALA services require a valid -#' download_reason_id code, either specified here or directly to the -#' associated R function. +#' by some ALA services, either as a numeric ID (currently 0--13) +#' or a string (see `show_all(reasons)` for a list of valid ID codes and +#' names). By default this is NA. Some ALA services require a valid +#' download_reason_id code, either specified here or directly to the +#' associated R function. #' * `email` string: An email address that has been registered with the chosen #' atlas. For the ALA, you can register at #' [this address](https://auth.ala.org.au/userdetails/registration/createAccount). @@ -39,12 +55,9 @@ #' specific downloads for later citation. #' * `username` string: A registered username (GBIF only) #' * `verbose` logical: should `galah` give verbose such as progress bars? -#' Defaults to FALSE. -#' -#' @return For `galah_config()`, a `list` of all options. -#' When `galah_config(...)` is called with arguments, nothing is returned -#' but the configuration is set. -#' +#' Defaults to `FALSE`. +#' @return Returns an object with classes `galah_config` and `list`, invisibly +#' if arguments are supplied. #' @examples \dontrun{ #' # To download occurrence records, enter your email in `galah_config()`. #' # This email should be registered with the atlas in question. @@ -62,115 +75,128 @@ #' #' # Make debugging in your session easier by setting `verbose = TRUE` #' galah_config(verbose = TRUE) +#' +#' # Optionally supply arguments via a named list +#' list(email = "your-email@email.com") |> +#' galah_config() #' } -#' @importFrom lifecycle deprecate_warn -#' @importFrom glue glue -#' @importFrom rlang abort -#' @importFrom potions brew -#' @importFrom potions pour -#' @export galah_config - +#' @export galah_config <- function(...) { # make sure dots are captured properly dots <- list(...) # set defaults, if this has not happened already - if(length(pour()) == 0) { - brew(default_config()) + if(length(potions::pour()) == 0) { + potions::brew(default_config()) } # add user-provided information if(length(dots) > 0){ - # check for deprecated `cache_directory` - if(any(names(dots) == "cache_directory")){ - dots_location <- which(names(dots) == "cache_directory") - value <- dots$cache_directory - deprecate_warn(when = "2.0.0", - what = "galah_config(cache_directory)", - details = glue("Use `galah_config(directory = \"{value}\")` instead.") - ) - names(dots)[dots_location] <- "directory" + # add exception so that people can supply a named list to `galah_config()` + # this avoids calling things like: + # `x <- list(email = "something); do.call(galah_config, x)` + if(length(dots) == 1){ + if(is.list(dots[[1]])){ + dots <- dots[[1]] + } } # check all values in dots to ensure they are named if(length(dots) != length(names(dots))){ - bullets <- c("All arguments to `galah_config() must be named.", - i = "Did you use `==` instead of `=`?") - abort(bullets) + c("All arguments to `galah_config() must be named.", + i = "Did you use `==` instead of `=`?") |> + cli::cli_abort() } # check all values in dots to ensure they are valid result <- restructure_config(dots) + + # look up what information has been given, write specific callouts for unusual cases + supplied_names <- names(result) # add to `potions` object - if(any(names(result) == "atlas")){ - brew(atlas = list(atlas = result$atlas)) + if(any(supplied_names == "atlas")){ + potions::brew(atlas = list(atlas = result$atlas)) result <- result[names(result) != "atlas"] - result$atlas_config_called_by_user <- TRUE } if(length(result) > 0){ - brew(result, method = "leaves") + potions::brew(result, method = "leaves") } + + # invisibly return + x <- potions::pour() + as_galah_config(x) |> + invisible() }else{ - x <- pour() - class(x) <- c("galah_config", "list") - return(x) + # visibly return + x <- potions::pour() + as_galah_config(x) } } +#' Internal function to convert lists to class `galah_config` +#' @noRd +#' @keywords Internal +as_galah_config <- function(x){ + structure(x, + class = c("galah_config", "list")) +} + #' Set a 'default' object for storing config in `galah` #' @noRd #' @keywords Internal default_config <- function(){ - x <- list( - package = list( - verbose = TRUE, - run_checks = TRUE, - send_email = FALSE, - directory = tempdir(), - atlas_config_called_by_user = FALSE), - user = list( - username = "", - email = "", - api_key = "", - password = "", - download_reason_id = 4), - atlas = list( - organisation = "Atlas of Living Australia", - acronym = "ALA", - region = "Australia")) - class(x) <- c("galah_config", "list") - x + list(package = list(verbose = TRUE, + run_checks = TRUE, + send_email = FALSE, + caching = TRUE, + directory = tempdir()), + user = list(authenticate = FALSE, + username = "", + email = "", + password = "", + download_reason_id = 4), + atlas = list(organisation = "Atlas of Living Australia", + acronym = "ALA", + region = "Australia")) |> + as_galah_config() } #' Place new options into correctly nested structure #' @noRd #' @keywords Internal -restructure_config <- function(dots){ +restructure_config <- function(dots, + error_call= rlang::caller_env()){ + # NOTE: we use `lapply()` here rather than `purrr::map()` ON PURPOSE + # It prevents error messages being prefaced with: + # Error in `purrr::map()` at galah-R/R/galah_config.R:171:3: + # ℹ In index: 1. + # ...which is undesirable result <- lapply(names(dots), - function(a){validate_config(a, dots[[a]])}) + \(a){validate_config(a, + dots[[a]], + error_call = error_call)}) names(result) <- names(dots) result } #' Catch errors in user-provided config -#' @importFrom rlang abort -#' @importFrom glue glue -#' @importFrom potions pour #' @noRd #' @keywords Internal -validate_config <- function(name, value, error_call = caller_env()) { - result <- switch(name, - "api_key" = enforce_character(value), +validate_config <- function(name, + value, + error_call = rlang::caller_env()) { + result <- switch(name, "atlas" = { value <- configure_atlas(value) # see whether atlases have changed, and if so, give a message - check_atlas(pour("atlas"), value) + check_atlas(potions::pour("atlas"), value) }, + "authenticate" = enforce_logical(value), "caching" = enforce_logical(value), "directory" = check_directory(value), "download_reason_id" = enforce_download_reason(value), @@ -180,86 +206,86 @@ validate_config <- function(name, value, error_call = caller_env()) { "send_email" = enforce_logical(value), "username" = enforce_character(value), "verbose" = enforce_logical(value), - enforce_invalid_name(name)) + enforce_invalid_name(name, + error_call = error_call)) result } #' Ensure some arguments are logical -#' @importFrom rlang abort #' @noRd #' @keywords Internal -enforce_logical <- function(value, error_call = caller_env()){ +enforce_logical <- function(value, + error_call = rlang::caller_env()){ if (!is.logical(value)) { - abort("Supplied value must be TRUE or FALSE.", call = error_call) + cli::cli_abort("Supplied value must be TRUE or FALSE.", + call = error_call) }else{ value } } #' Ensure a file exists -#' @importFrom rlang abort #' @noRd #' @keywords Internal -enforce_exists <- function(value, error_call = caller_env()){ +enforce_exists <- function(value, + error_call = rlang::caller_env()){ if (!dir.exists(value)) { - bullets <- c("Cache directory does not exist.", - i = "Does the directory entered exist?") - abort(bullets, call = error_call) + c("Cache directory does not exist.", + i = "Does the directory entered exist?") |> + cli::cli_abort(call = error_call) }else{ value } } #' Ensure provided value is a string -#' @importFrom rlang abort #' @noRd #' @keywords Internal -enforce_character <- function(value, error_call = caller_env()){ +enforce_character <- function(value, + error_call = rlang::caller_env()){ if (!is.character(value)) { - bullets <- c( - glue("Invalid type"), - i = "Value must be entered as a string." - ) - abort(bullets, call = error_call) + c("Invalid type", + i = "Value must be entered as a string.") |> + cli::cli_abort(call = error_call) }else{ value } } #' Ensure download reason is valid -#' @importFrom rlang abort #' @noRd #' @keywords Internal -enforce_download_reason <- function(value, error_call = caller_env()){ +enforce_download_reason <- function(value, + error_call = rlang::caller_env()){ # first ensure API is available. Currently missing for Brazil, for example. - reasons_api_available <- url_lookup("metadata/reasons") |> + reasons_df <- show_all_reasons() |> try(silent = TRUE) - if(inherits(reasons_api_available, "try-error")){ - return(1) + if(inherits(reasons_df, "try-error")){ + if(is.numeric(value)){ + as.integer(value) + }else{ + 1 + } }else{ - if (is.numeric(value) & !(value %in% show_all_reasons()$id)) { - bullets <- c( - "Invalid download reason ID.", + if (is.numeric(value) & !(value %in% reasons_df$id)) { + c("Invalid download reason ID.", i = "Use `show_all(reasons)` to see all valid reasons.", - x = glue("{value} does not match an existing reason ID.") - ) - abort(bullets, call = error_call) - } else if(is.character(value) & !(value %in% show_all_reasons()$name)) { + x = "{value} does not match an existing reason ID.") |> + cli::cli_abort(call = error_call) + } else if(is.character(value) & !(value %in% reasons_df$name)) { bullets <- c( "Invalid download reason name.", i = "Use `show_all(reasons)` to see all valid reasons.", - x = glue("\"{value}\" does not match an existing reason name.") - ) - abort(bullets, call = error_call) + x = "\"{value}\" does not match an existing reason name.") |> + cli::cli_abort(call = error_call) } - if (is.character(value) & (value %in% show_all_reasons()$name)) { - valid_reasons <- show_all_reasons() - value_id <- valid_reasons |> - filter(valid_reasons$name == value) |> - select("id") |> - pull("id") - inform(c("v" = glue("Matched \"{value}\" to valid download reason ID {value_id}."))) + if (is.character(value) & (value %in% reasons_df$name)) { + value_id <- reasons_df |> + dplyr::filter(reasons_df$name == value) |> + dplyr::select("id") |> + dplyr::pull("id") + cli::cli_bullets(c("v" = "Matched \"{value}\" to valid download reason ID {value_id}.")) value_id }else{ value @@ -268,36 +294,34 @@ enforce_download_reason <- function(value, error_call = caller_env()){ } #' catch all failure for unknown names -#' @importFrom rlang abort #' @noRd #' @keywords Internal -enforce_invalid_name <- function(name, error_call = caller_env()){ - bullets <- c( - "Invalid option name.", +enforce_invalid_name <- function(name, + error_call = rlang::caller_env()){ + c("Invalid option name.", i = "See `?galah_config()` for valid options.", - x = glue("\"{name}\" is not a valid option name.") - ) - abort(bullets, call = error_call) + x = "\"{name}\" is not a valid option name.") |> + cli::cli_abort(call = error_call) } #' Set behaviour for deriving correct atlas information -#' @importFrom rlang abort -#' @importFrom glue glue #' @noRd #' @keywords Internal -configure_atlas <- function(query){ +configure_atlas <- function(query, + error_call = rlang::caller_env()){ comparison <- do.call(c, node_metadata) - comparison <- comparison[!is.na(comparison)] |> as.character() - lookup <- utils::adist(query, comparison, ignore.case = TRUE)[1, ] + comparison <- comparison[!is.na(comparison)] |> + as.character() + lookup <- utils::adist(query, + comparison, + ignore.case = TRUE)[1, ] if(all(lookup > 2)){ - bullets <- c( - "Unsupported atlas provided.", - i = glue("Use `show_all(atlases)` to see supported atlases."), - x = glue("\"{query}\" is not a valid atlas.") - ) - abort(bullets, call = caller_env()) + c("Unsupported atlas provided.", + i = "Use `show_all(atlases)` to see supported atlases.", + x = "\"{query}\" is not a valid atlas.") |> + cli::cli_abort(call = error_call) }else{ selected_entry <- comparison[which(lookup == min(lookup))][[1]] @@ -315,14 +339,18 @@ configure_atlas <- function(query){ } #' Provide a message if atlas is changed -#' @importFrom glue glue -#' @importFrom rlang inform #' @noRd #' @keywords Internal check_atlas <- function(current_data, new_data){ if(new_data$region != current_data$region){ - inform(glue( - "Atlas selected: {new_data$organisation} ({new_data$acronym}) [{new_data$region}]")) + current_url <- show_all_atlases() |> + dplyr::filter(.data$region == new_data$region) |> + dplyr::pull("url") + cli::cli({ + cli::cli_text("New organisation selected: {new_data$organisation} ({new_data$acronym})") + cli::col_magenta(current_url) |> + cli::cli_text() + }) } new_data } \ No newline at end of file diff --git a/R/galah_filter.R b/R/galah_filter.R index 27a522ae..2c22e9e5 100644 --- a/R/galah_filter.R +++ b/R/galah_filter.R @@ -1,194 +1,19 @@ -#' Keep rows that match a condition -#' -#' The `filter()` function is used to subset a data, retaining all rows that -#' satisfy your conditions. To be retained, the row must produce a value of -#' `TRUE` for all conditions. Unlike 'local' filters that act on a `tibble`, -#' the galah implementations work by amending a query which is then enacted -#' by `collect()` or one of the `atlas_` family of functions (such as -#' `atlas_counts()` or `atlas_occurrences()`). -#' @name filter.data_request -#' @order 1 -#' @param .data An object of class `data_request`, `metadata_request` -#' or `files_request`, created using [galah_call()] or related functions. -#' @param ... Expressions that return a logical value, and are defined in terms -#' of the variables in the selected atlas (and checked using `show_all(fields)`. -#' If multiple expressions are included, they are combined with the & operator. -#' Only rows for which all conditions evaluate to `TRUE` are kept. -#' @param profile -#' `r lifecycle::badge("deprecated")` -#' Use `galah_apply_profile` instead. -#' @return A tibble containing filter values. -#' @seealso \code{\link[=select.data_request]{select()}}, -#' \code{\link[=group_by.data_request]{group_by()}} and [geolocate()] for -#' other ways to amend the information returned by [atlas_()] functions. Use -#' `search_all(fields)` to find fields that you can filter by, and -#' [show_values()] to find what values of those filters are available. -#' @details -#' -#' *Syntax* -#' -#' `filter.data_request()` and `galah_filter()` uses non-standard evaluation -#' (NSE), and are designed to be as compatible as possible with -#' `dplyr::filter()` syntax. Permissible examples include: -#' -#' * `==` (e.g. `year = 2020`) but not `=` (for consistency with `dplyr`) -#' * `!=`, e.g. `year != 2020`) -#' * `>` or `>=` (e.g. `year >= 2020`) -#' * `<` or `<=` (e.g. `year <= 2020`) -#' * `OR` statements (e.g. `year == 2018 | year == 2020`) -#' * `AND` statements (e.g. `year >= 2000 & year <= 2020`) -#' -#' Some general tips: -#' * Separating statements with a comma is equivalent to an `AND` statement; -#' Ergo `filter(year >= 2010 & year < 2020)` is the same as -#' `_filter(year >= 2010, year < 2020)`. -#' * All statements must include the field name; so -#' `filter(year == 2010 | year == 2021)` works, as does -#' `filter(year == c(2010, 2021))`, but `filter(year == 2010 | 2021)` -#' fails. -#' * It is possible to use an object to specify required values, e.g. -#' `year_value <- 2010; filter(year > year_value)`. -#' * `solr` supports range queries on text as well as numbers; so -#' `filter(cl22 >= "Tasmania")` is valid. -#' * It is possible to filter by 'assertions', which are statements about data -#' validity, such as `filter(assertions != c("INVALID_SCIENTIFIC_NAME", "COORDINATE_INVALID")`. -#' Valid assertions can be found using `show_all(assertions)`. -#' -#' *Exceptions* -#' -#' When querying occurrences, species, or their respective counts (i.e. all of -#' the above examples), field names are checked internally against -#' `show_all(fields)`. There are some cases where bespoke field names are -#' required, as follows. -#' -#' When requesting a data download from a DOI, the field `doi` is valid, i.e.: -#' \preformatted{galah_call() |> -#' filter(doi = "a-long-doi-string") |> -#' collect()} -#' -#' For taxonomic metadata, the `taxa` field is valid: -#' \preformatted{request_metadata() |> -#' filter(taxa == "Chordata") |> -#' unnest()} -#' -#' For building taxonomic trees, the `rank` field is valid: -#' \preformatted{request_data() |> -#' identify("Chordata") |> -#' filter(rank == "class") |> -#' atlas_taxonomy()} -#' -#' Media queries are more involved, but break two rules: they accept the `media` -#' field, and they accept a tibble on the rhs of the equation. For example, -#' users wishing to break down media queries into their respective API calls -#' should begin with an occurrence query: -#' -#' \preformatted{occurrences <- galah_call() |> -#' identify("Litoria peronii) |> -#' select(group = c("basic", "media") |> -#' collect()} -#' -#' They can then use the `media` field to request media metadata: -#' \preformatted{media_metadata <- galah_call("metadata") |> -#' filter(media == occurrences) |> -#' collect()} -#' -#' And finally, the metadata tibble can be used to request files: -#' \preformatted{galah_call("files") |> -#' filter(media == media_metadata) |> -#' collect()} -#' -#' @examples \dontrun{ -#' galah_call() |> -#' filter(year >= 2019, -#' basisOfRecord == "HumanObservation") |> -#' count() |> -#' collect() -#' } -#' @importFrom rlang caller_env -#' @importFrom rlang enquos -#' @importFrom rlang eval_tidy -#' @importFrom rlang get_env -#' @importFrom rlang new_quosure -#' @importFrom rlang parse_expr -#' @importFrom rlang quo_get_expr -#' @importFrom rlang quo_squash -#' @export -filter.data_request <- function(.data, ...){ - dots <- enquos(..., .ignore_empty = "all") - check_named_input(dots) - update_data_request(.data, - filter = parse_quosures_data(dots)) # see `quosure_handling.R` -} -# usually filters as previously for ALA, but some exceptions: -# doi == "x" in `atlas_occurrences()` -# rank == "class" in `atlas_taxonomy()` replacement for `galah_down_to()` - -#' @rdname filter.data_request -#' @order 2 -#' @export -filter.metadata_request <- function(.data, ...){ - dots <- enquos(..., .ignore_empty = "all") - check_named_input(dots) - parse_quosures_metadata(.data, dots) -} -# Note: the intended purpose of this function is to pass `filter()` -# within the API call in the same was as `filter.data_request()`. -# In theory this would power `search_all()`; but in practice many -# APIs do not support a `q` argument that allows server-side filtering. -# The exception is GBIF. -# -# An unusual distinction is that when `unnest()` is also called, `filter()` is -# used to set the thing that is unnested; this is a different kind of search -# e.g. `request_metadata() |> filter(taxa == "Chordata") |> unnest()` - -#' simple parser for metadata -#' @noRd -#' @keywords Internal -parse_quosures_metadata <- function(request, dots){ - dots_parsed <- parse_quosures_files(dots) - request$filter <- dots_parsed - # The `filter` argument sets `type` when specified - initial_type <- request$type - supplied_type <- dots_parsed$variable[1] - if(!(supplied_type %in% c("taxa", "media")) & - !grepl("s$", supplied_type)){ - filter_type <- paste0(supplied_type, "s") - }else{ - filter_type <- supplied_type - } - if(grepl("-unnest$", initial_type)){ - request$type <- paste0(filter_type, "-unnest") - }else{ - request$type <- filter_type - } - request -} - -#' @rdname filter.data_request -#' @order 3 -#' @importFrom rlang .data -#' @export -filter.files_request <- function(.data, ...){ - dots <- enquos(..., .ignore_empty = "all") - check_named_input(dots) - dots_parsed <- parse_quosures_files(dots) - check_files_filter(dots_parsed) - .data$type <- dots_parsed$variable - .data$filter <- dots_parsed$data - .data -} - #' @rdname filter.data_request #' @order 4 #' @export -galah_filter <- function(..., profile = NULL){ - dots <- enquos(..., .ignore_empty = "all") |> +galah_filter <- function(...){ + dots <- rlang::enquos(..., .ignore_empty = "all") |> detect_request_object() check_named_input(dots) switch(class(dots[[1]])[1], "data_request" = { - update_data_request(dots[[1]], - filter = parse_quosures_data(dots[-1])) + if(is_gbif()){ + filters <- parse_quosures_data_gbif(dots[-1]) # `handle_quosures_GBIF.R` + }else{ + filters <- parse_quosures_data(dots[-1]) # `handle_quosures.R` + } + update_request_object(dots[[1]], + filter = filters) }, "metadata_request" = { parse_quosures_metadata(dots[[1]], dots[-1]) @@ -200,6 +25,10 @@ galah_filter <- function(..., profile = NULL){ input$type <- parsed_dots$variable input }, - parse_quosures_data(dots) + if(is_gbif()){ + parse_quosures_data_gbif(dots) + }else{ + parse_quosures_data(dots) + } ) } \ No newline at end of file diff --git a/R/galah_geolocate.R b/R/galah_geolocate.R index bad9c5f2..7f81a5e6 100644 --- a/R/galah_geolocate.R +++ b/R/galah_geolocate.R @@ -21,7 +21,6 @@ #' a shapefile. A bounding box can also be supplied as a `bbox` object #' (via `sf::st_bbox()`) or a `tibble`/`data.frame`. #' -#' `r lifecycle::badge("experimental")` #' **Use a point radius** #' Alternatively, set `type = "radius"` to narrow queries to within a circular #' area around a specific point location. Point coordinates can be supplied as @@ -155,5 +154,6 @@ galah_geolocate <- geolocate #' @param y A valid Well-Known Text string (wkt), a `POLYGON` or a `MULTIPOLYGON` #' @export st_crop.data_request <- function(x, y, ...){ - update_data_request(x, geolocate = parse_polygon(y)) + update_request_object(x, + geolocate = parse_polygon(y)) } \ No newline at end of file diff --git a/R/galah_group_by.R b/R/galah_group_by.R index eed65e45..b2a5878a 100644 --- a/R/galah_group_by.R +++ b/R/galah_group_by.R @@ -1,100 +1,17 @@ -#' Group by one or more variables -#' -#' Most data operations are done on groups defined by variables. `group_by()` -#' takes a field name (unquoted) and performs a grouping operation. The default -#' behaviour is to use it in combination with -#' \code{\link[=count.data_request]{count()}} to give information on number -#' of occurrences per level of that field. Alternatively, you can use it -#' without count to get a download of occurrences grouped by that variable. This -#' is particularly useful when used with a taxonomic `ID` field (`speciesID`, -#' `genusID` etc.) as it allows further information to be appended to the result. -#' This is how [atlas_species()] works, for example. See -#' \code{\link[=select.data_request]{select()}} for details. -#' @param .data An object of class `data_request` -#' @param ... Zero or more individual column names to include -#' @return If any arguments are provided, returns a `data.frame` with -#' columns `name` and `type`, as per [select.data_request()]. -#' @examples \dontrun{ -#' # default usage is for grouping counts -#' galah_call() |> -#' group_by(basisOfRecord) |> -#' counts() |> -#' collect() -#' -#' # Alternatively, we can use this with an occurrence search -#' galah_call() |> -#' filter(year == 2024, -#' genus = "Crinia") |> -#' group_by(speciesID) |> -#' collect() -#' # note that this example is equivalent to `atlas_species()`; -#' # but using `group_by()` is more flexible. -#' } -#' @export -group_by.data_request <- function(.data, ...){ -parsed_dots <- enquos(..., .ignore_empty = "all") |> - parse_quosures_basic() -df <- parse_group_by(parsed_dots) -update_data_request(.data, group_by = df) -} - #' @rdname group_by.data_request -#' @importFrom stringr str_detect #' @export galah_group_by <- function(...){ - dots <- enquos(..., .ignore_empty = "all") |> + dots <- rlang::enquos(..., .ignore_empty = "all") |> detect_request_object() switch(class(dots[[1]])[1], "data_request" = { df <- parse_quosures_basic(dots[-1]) |> parse_group_by() - update_data_request(dots[[1]], group_by = df) + update_request_object(dots[[1]], + group_by = df) }, { parse_quosures_basic(dots) |> parse_group_by() }) -} - -#' Internal parsing of `group_by` args -#' @noRd -#' @keywords Internal -parse_group_by <- function(dot_names){ - if(length(dot_names) > 0){ - if(length(dot_names) > 3){ - bullets <- c( - "Too many fields supplied.", - i = "`group_by.data_request` accepts a maximum of 3 fields." - ) - abort(bullets, call = caller_env()) - } - if(length(dot_names) > 0){ - df <- tibble(name = dot_names) - df$type <- ifelse(str_detect(df$name, "[[:lower:]]"), "field", "assertions") - }else{ - df <- tibble(name = "name", type = "type", .rows = 0) - } - }else{ - df <- tibble(name = "name", type = "type", .rows = 0) - } - - return(df) -} - -# for passing to atlas_counts, see rgbif::count_facet -# in practice, the only fields allowable by `path <- /occurrence/counts` -# are `year` (with optional year range); -# https://api.gbif.org/v1/occurrence/counts/year?year=1981,2012 -# NOTE: range query is optional - -# galah_call() |> -# galah_group_by(year) |> -# galah_filter(year >= 1981 & year <= 2012) |> -# atlas_counts() - -# ...and `basisOfRecord` (no filters) -# https://api.gbif.org/v1/occurrence/counts/basisOfRecord - -# galah_call() |> -# galah_group_by(basisOfRecord) |> -# atlas_counts() +} \ No newline at end of file diff --git a/R/galah_identify.R b/R/galah_identify.R index fa43fcf4..2239b72a 100644 --- a/R/galah_identify.R +++ b/R/galah_identify.R @@ -12,19 +12,13 @@ #' correct results. #' @name identify.data_request #' @order 1 -#' @param x An object of class `data_request`, created using [request_data()] +#' @param x An object of class `data_request` or `metadata_request`. #' @param ... One or more scientific names. -#' @param search -#' `r lifecycle::badge("deprecated")` -#' `galah_identify()` now always does a search to verify search terms; ergo -#' this argument is ignored. -#' @return A tibble containing identified taxa. +#' @return A `tibble` containing identified taxa. #' @seealso \code{\link[=filter.data_request]{filter()}} or [geolocate()] for #' other ways to filter a query. You can also use [search_taxa()] to check that #' supplied names are being matched correctly on the server-side; see #' [taxonomic_searches] for a detailed overview. -#' @importFrom dplyr rename -#' @importFrom dplyr select #' @examples \dontrun{ #' # Use `galah_identify()` to narrow your queries #' galah_call() |> @@ -39,29 +33,25 @@ #' count() |> #' collect() #' } -#' @importFrom lifecycle deprecate_stop -#' @importFrom lifecycle deprecate_warn -#' @importFrom rlang warn -#' @importFrom tibble tibble #' @export identify.data_request <- function(x, ...){ dots_initial <- list(...) if (length(dots_initial) < 1) { - warn("No query passed to `identify()`.") + cli::cli_warn("No query passed to `identify()`.") result <- NULL }else{ if(inherits(dots_initial[[1]], "data.frame") & length(dots_initial) == 1){ result <- dots_initial[[1]] }else{ - result <- tibble("search_term" = unlist(dots_initial)) + result <- tibble::tibble("search_term" = unlist(dots_initial)) } } - update_data_request(x, identify = result) + update_request_object(x, + identify = result) } #' @rdname identify.data_request -#' @param x An object of class `metadata_request`, created using [request_metadata()] #' @order 2 #' @export identify.metadata_request <- function(x, ...){ @@ -78,13 +68,12 @@ identify.metadata_request <- function(x, ...){ #' @rdname identify.data_request #' @order 3 #' @export -galah_identify <- function(..., search = NULL) { +galah_identify <- function(...) { dots_initial <- list(...) if (length(dots_initial) < 1) { - warn("No query passed to `identify()`.") - tibble("search_term" = character()) + cli::cli_warn("No query passed to `identify()`.") + tibble::tibble("search_term" = character()) }else{ - dots_initial <- check_search_arg(dots_initial, search) if(inherits(dots_initial[[1]], "data_request")){ do.call(identify.data_request, dots_initial) }else{ @@ -92,41 +81,4 @@ galah_identify <- function(..., search = NULL) { return(search_terms) } } -} - -#' Remove `search` argument from `galah_identify()`, give deprecated warning -#' @importFrom lifecycle deprecate_warn -#' @noRd -#' @keywords Internal -check_search_arg <- function(dots_initial, search = NULL) { - if("search" %in% names(dots_initial)) { - search <- dots_initial$name - dots_initial <- dots_initial[names(dots_initial) != "search"] - } - if(!is.null(search)){ - if(!is.logical(search)){ - deprecate_stop( - when = "2.0.0", - what = "galah_identify(search = )", - details = glue("`galah_identify()` now always does a search to verify search terms. \\ - Passing anything other than TRUE or FALSE to `search` has never worked")) - }else{ - if(search){ - # if search = TRUE, this function still behaves correctly - deprecate_warn( - when = "2.0.0", - what = "galah_identify(search = )", - details = glue("`galah_identify()` now always does a search to verify search terms. \\ - Please remove `search` argument from `galah_identify()`.")) - # if search = FALSE, abort warning to use filter(lsid == x) instead - }else{ - deprecate_stop( - when = "2.0.0", - what = "galah_identify(search = )", - details = glue("`galah_identify()` now always does a search to verify search terms. \\ - To pass identifiers, please use `filter(lsid == 'identifier_here') instead.")) - } - } - } - dots_initial } \ No newline at end of file diff --git a/R/galah_polygon.R b/R/galah_polygon.R index e909f9ff..fb2d8f9d 100644 --- a/R/galah_polygon.R +++ b/R/galah_polygon.R @@ -16,77 +16,79 @@ galah_polygon <- function(...){ out_query <- parse_polygon(query) # if a data request was supplied, return one if(!is.null(dr)){ - update_data_request(dr, geolocate = out_query) + update_request_object(dr, + geolocate = out_query) }else{ out_query } } #' parser for polygons -#' @importFrom rlang try_fetch -#' @importFrom sf st_as_sfc -#' @importFrom sf st_is_valid -#' @importFrom stringr str_detect -#' @importFrom stringr str_replace #' @noRd #' @keywords Internal -parse_polygon <- function(query){ +parse_polygon <- function(query, + error_call = rlang::caller_env()){ # make sure shapefiles are processed correctly - if (!inherits(query, "sf")) {query <- query[[1]]} else {query <- query} + if (!inherits(query, "sf")) { + query <- query[[1]] + } else { + query <- query + } # check object is accepted class - if (!inherits(query, c("character", "list", "matrix", "data.frame", "tbl", "sf", "sfc", "XY"))) { + accepted_classes <- c("character", + "list", + "matrix", + "data.frame", + "tbl", + "sf", + "sfc", + "XY") + if (!inherits(query, accepted_classes)) { unrecognised_class <- class(query) - bullets <- c( - "Invalid object detected.", + c("Invalid object detected.", i = "Did you provide a polygon or WKT in the right format?", - x = glue("`galah_polygon` cannot use object of class '{unrecognised_class}'.") - ) - abort(bullets, call = caller_env()) + x = "`galah_polygon` cannot use object of class '{unrecognised_class}'.") |> + cli::cli_abort(call = error_call) } # handle shapefiles - if (inherits(query, "XY")) query <- st_as_sfc(query) + if (inherits(query, "XY")){ + query <- sf::st_as_sfc(query) + } # make sure spatial object or wkt is valid if (!inherits(query, c("sf", "sfc"))) { check_wkt_length(query) # handle errors from converting impossible WKTs - query <- try_fetch( - query |> st_as_sfc(), + query <- rlang::try_fetch( + query |> sf::st_as_sfc(), error = function(cnd) { - bullets <- c( - "Invalid WKT detected.", - i = "Check that the spatial feature or WKT in `galah_polygon` is correct." - ) - abort(bullets, call = caller_env()) + c("Invalid WKT detected.", + i = "Check that the spatial feature or WKT in `galah_polygon` is correct.") |> + cli::cli_abort(call = error_call) }) - - # validate that wkt/spatial object is real - valid <- query |> st_is_valid() } - else { - valid <- query |> st_is_valid() } + + # validate that wkt/spatial object is real + valid <- query |> sf::st_is_valid() + if(any(is.na(valid))) { - bullets <- c( - "Invalid spatial object or WKT detected.", - i = "Check that the spatial feature or WKT in `galah_polygon` is correct." - ) - abort(bullets, call = caller_env()) + c("Invalid spatial object or WKT detected.", + i = "Check that the spatial feature or WKT in `galah_polygon` is correct.") |> + cli::cli_abort(call = error_call) } # check number of vertices of WKT if(any(n_points(query) > 500)) { n_verts <- n_points(query) - bullets <- c( - glue("Polygon has too many vertices."), + c("Polygon has too many vertices.", i = "`galah_polygon` only accepts simple polygons.", i = "See `?sf::st_simplify` for how to simplify geospatial objects.", - x = "Polygon must have 500 or fewer vertices, not {n_verts}." - ) - abort(bullets, call = caller_env()) + x = "Polygon must have 500 or fewer vertices, not {n_verts}.") |> + cli::cli_abort(call = error_call) } # currently a bug where the ALA doesn't accept some polygons @@ -98,12 +100,10 @@ parse_polygon <- function(query){ } else { # multiple polygons n_polygons <- length(query$geometry) - bullets <- c( - "Too many polygons.", + c("Too many polygons.", i = "`galah_polygon` cannot accept more than 1 polygon at a time.", - x = glue("{n_polygons} polygons detected in spatial object.") - ) - abort(bullets, call = caller_env()) + x = "{n_polygons} polygons detected in spatial object.") |> + cli::cli_abort(call = error_call) ## NOTE: Code below parses multiple polygons. ## Please do not remove! @@ -120,14 +120,15 @@ parse_polygon <- function(query){ } else { # remove space after "POLYGON" if present - if(str_detect(query, "POLYGON \\(\\(")) - query <- str_replace(query, "POLYGON \\(\\(", "POLYGON\\(\\(") + if(stringr::str_detect(query, "POLYGON \\(\\(")) + query <- stringr::str_replace(query, "POLYGON \\(\\(", "POLYGON\\(\\(") - if (str_detect(query, "POLYGON") & ! str_detect(query, "MULTIPOLYGON")) { + if (stringr::str_detect(query, "POLYGON") & + !stringr::str_detect(query, "MULTIPOLYGON")) { # change start of string - query <- str_replace(query, "POLYGON\\(\\(", "MULTIPOLYGON\\(\\(\\(") + query <- stringr::str_replace(query, "POLYGON\\(\\(", "MULTIPOLYGON\\(\\(\\(") # add an extra bracket - query <- paste0(query, ")") + query <- glue::glue("{query})") } out_query <- query } @@ -135,26 +136,23 @@ parse_polygon <- function(query){ } #' Internal function to `galah_polygon` -#' @importFrom sf st_geometry #' @noRd #' @keywords Internal n_points <- function(x) { - count_vertices(st_geometry(x)) + count_vertices(sf::st_geometry(x)) } #' Internal function to `galah_polygon` -#' @importFrom rlang caller_env -#' @importFrom sf st_is_empty #' @noRd #' @keywords Internal -count_vertices <- function(wkt_string, error_call = caller_env()) { +count_vertices <- function(wkt_string) { out <- if (is.list(wkt_string)) sapply(sapply(wkt_string, count_vertices), sum) else { if (is.matrix(wkt_string)) nrow(wkt_string) else { - if (!st_is_empty(wkt_string)) 1 else + if (!sf::st_is_empty(wkt_string)) 1 else 0 } } @@ -162,30 +160,25 @@ count_vertices <- function(wkt_string, error_call = caller_env()) { } #' Internal function to `galah_polygon` -#' @importFrom glue glue -#' @importFrom rlang abort -#' @importFrom rlang is_list -#' @importFrom rlang is_string #' @noRd #' @keywords Internal -check_wkt_length <- function(wkt, error_call = caller_env()) { - if (is_string(wkt) == TRUE | - is.matrix(wkt) == TRUE | - is_list(wkt) == TRUE | - is.data.frame(wkt) == TRUE) { +check_wkt_length <- function(wkt, + error_call = rlang::caller_env()) { + if (rlang::is_string(wkt) == TRUE | + is.matrix(wkt) == TRUE | + rlang::is_list(wkt) == TRUE | + is.data.frame(wkt) == TRUE) { # make sure strings aren't too long for API call if(!inherits(wkt, "character")){ - abort("Argument `wkt` must be of class 'character'", - call = error_call) + cli::cli_abort("Argument `wkt` must be of class 'character'", + call = error_call) } n_char_wkt <- nchar(wkt) max_char <- 10000 if (n_char_wkt > max_char) { - bullets <- c( - "Invalid WKT detected.", - x = glue("WKT string can be maximum {max_char} characters. WKT supplied has {n_char_wkt}.") - ) - abort(bullets, call = error_call) + c("Invalid WKT detected.", + x = "WKT string can be maximum {max_char} characters. WKT supplied has {n_char_wkt}.") |> + cli::cli_abort(call = error_call) } } } diff --git a/R/galah_radius.R b/R/galah_radius.R index 7b414ada..50f315c8 100644 --- a/R/galah_radius.R +++ b/R/galah_radius.R @@ -16,33 +16,30 @@ galah_radius <- function(...){ out_query <- parse_point_radius(query) # if a data request was supplied, return one if(!is.null(dr)){ - update_data_request(dr, geolocate = out_query) + update_request_object(dr, + geolocate = out_query) }else{ out_query } } #' parser for radius -#' @importFrom rlang try_fetch -#' @importFrom sf st_as_sfc -#' @importFrom sf st_coordinates -#' @importFrom stringr str_detect #' @noRd #' @keywords Internal -parse_point_radius <- function(..., error_call = caller_env()){ +parse_point_radius <- function(..., + error_call = rlang::caller_env()){ - query <- try_fetch( + query <- rlang::try_fetch( list(...)[[1]], error = function(cnd) { - bullets <- c( - "No input detected.", - i = "Did you forget to supply coordinates to `galah_radius()`?" - ) - abort(bullets, call = error_call) + c("No input detected.", + i = "Did you forget to supply coordinates to `galah_radius()`?") |> + cli::cli_abort(call = error_call) }) # Coords are supplied as an `sfc` point or lat/lon arguments - if (inherits(query, c("list")) && inherits(query[[1]], c("sf", "sfc"))) { + if (inherits(query, c("list")) && + inherits(query[[1]], c("sf", "sfc"))) { # make sure shapefiles are handled correctly coords <- query[[1]] @@ -53,21 +50,17 @@ parse_point_radius <- function(..., error_call = caller_env()){ # TODO: Recognise when more than one point is passed, default to first point unrecognised_class <- glue::glue_collapse(class(coords), sep = ", ") - bullets <- c( - "Invalid spatial object supplied as point coordinates.", + c("Invalid spatial object supplied as point coordinates.", i = "`galah_radius()` accepts sfc_POINT objects.", - x = glue("Cannot use class: {unrecognised_class}.") - ) - abort(bullets, call = error_call) + x = "Cannot use class: {unrecognised_class}.") |> + cli::cli_abort(call = error_call) } # extract point coordinate values - lat = st_coordinates(coords)[1] - lon = st_coordinates(coords)[2] + lat <- sf::st_coordinates(coords)[1] + lon <- sf::st_coordinates(coords)[2] - } - # Coords are supplied as lon/lat arguments - else { # + } else { # Coords are supplied as lon/lat arguments # TODO: Assign numeric values to lon/lat automatically? # if(!is.null(query[[1]]) && inherits(query[[1]], c("numeric", "double", "integer")) | @@ -75,18 +68,17 @@ parse_point_radius <- function(..., error_call = caller_env()){ # lon = query[[1]] # lat = query[[2]] # } - if(inherits(query, "list") && is.null(query$lat) | is.null(query$lon)) { - bullets <- c( - "Missing `lat` or `lon` values.", - i = "Point coordinates should be specified using `lat` & `lon` arguments, or supplied as an `sfc_POINT`." - ) - abort(bullets, call = error_call) + if(inherits(query, "list") && + (is.null(query$lat) | is.null(query$lon))) { + c("Missing `lat` or `lon` values.", + i = "Point coordinates should be specified using `lat` & `lon` arguments, or supplied as an `sfc_POINT`.") |> + cli::cli_abort(call = error_call) } else { query <- query # extract point coordinate values - lat = query$lat - lon = query$lon + lat <- query$lat + lon <- query$lon } } @@ -100,59 +92,50 @@ parse_point_radius <- function(..., error_call = caller_env()){ # Check for radius value. If empty, set to 10 km if(is.null(query$radius)) { - bullets <- c( - "No radius value specified.", - "*" = "Setting radius to 10 km." - ) - warn(bullets) - radius = 10 + c("No radius value specified.", + "*" = "Setting radius to 10 km.") |> + cli::cli_warn() + radius <- 10 } else { # Only use one radius value if(length(query$radius) > 1) { n_radius <- length(query$radius) - warn(c("More than 1 radius provided.", - "*" = glue("Using first radius, ignoring additional {n_radius - 1} value(s).")) - ) + c("More than 1 radius provided.", + "*" = "Using first radius, ignoring additional {n_radius - 1} value(s).") |> + cli::cli_warn() radius <- query$radius[[1]] } else { - radius = query$radius + radius <- query$radius } } # Check object is accepted class when supplied to lat/lon/radius arguments if (!any(inherits(c(lat, lon, radius), c("numeric", "double", "integer")))) { - wrong_classes <- tibble(arg = names(query), - class = lapply(query, class) |> unlist() - ) |> + wrong_classes <- tibble::tibble(arg = names(query), + class = purrr::map(query, class) |> unlist()) |> filter(!class %in% c("numeric", "double", "integer")) - unrecognised_class <- glue_collapse(unique(wrong_classes$class), - sep = ", ") - bullets <- c( - "Invalid class detected.", + unrecognised_class <- glue::glue_collapse(unique(wrong_classes$class), + sep = ", ") + c("Invalid class detected.", i = "Point can be specified as numeric `lat` & `lon` coordinates, or supplied as an `sfc_POINT`.", - x = glue("`galah_radius()` does not accept type '{unrecognised_class}'.") - ) - abort(bullets, call = error_call) + x = "`galah_radius()` does not accept type '{unrecognised_class}'.") |> + cli::cli_abort(call = error_call) } # make sure lat/lon aren't impossible if(lon > 180 | lon < -180 | lat > 90 | lat < -90) { - bullets <- c( - "Point location outside of possible range.", - i = "Are the coordinates valid?" - ) - abort(bullets, call = error_call) + c("Point location outside of possible range.", + i = "Are the coordinates valid?") |> + cli::cli_abort(call = error_call) } # Should this be an error? A message? if(radius > 1565) { - bullets <- c( - "Radius is larger than the area of Australia.", - i = "Try reducing the radius to narrow your query." - ) - inform(bullets) + c("Supplied radius is larger than the area of Australia.", + i = "Try reducing the radius to narrow your query.") |> + cli::cli_inform() } out_query <- list(lat = lat, diff --git a/R/galah_select.R b/R/galah_select.R index 27290258..0c08e0ea 100644 --- a/R/galah_select.R +++ b/R/galah_select.R @@ -1,205 +1,31 @@ -#' @title Keep or drop columns using their names -#' -#' @description Select (and optionally rename) variables in a data frame, using -#' a concise mini-language that makes it easy to refer to variables based on -#' their name. Note that unlike calling `select()` on a local tibble, this -#' implementation is only evaluated at the -#' \code{\link[=collapse.data_request]{collapse()}} stage, meaning any errors -#' or messages will be triggered at the end of the pipe. -#' -#' `select()` supports `dplyr` **selection helpers**, including: -#' -#' * \code{\link[dplyr]{everything}}: Matches all variables. -#' * \code{\link[dplyr]{last_col}}: Select last variable, possibly with an -#' offset. -#' -#' Other helpers select variables by matching patterns in their names: -#' -#' * \code{\link[dplyr]{starts_with}}: Starts with a prefix. -#' * \code{\link[dplyr]{ends_with}}: Ends with a suffix. -#' * \code{\link[dplyr]{contains}}: Contains a literal string. -#' * \code{\link[dplyr]{matches}}: Matches a regular expression. -#' * \code{\link[dplyr]{num_range}}: Matches a numerical range like x01, -#' x02, x03. -#' -#' Or from variables stored in a character vector: -#' -#' * \code{\link[dplyr]{all_of}}: Matches variable names in a character -#' vector. All names must be present, otherwise an out-of-bounds error is -#' thrown. -#' * \code{\link[dplyr]{any_of}}: Same as `all_of()`, except that no error -#' is thrown for names that don't exist. -#' -#' Or using a predicate function: -#' -#' * \code{\link[dplyr]{where}}: Applies a function to all variables and selects those for which the function returns `TRUE`. -#' @name select.data_request -#' @param .data An object of class `data_request`, created using [galah_call()]. -#' @param ... Zero or more individual column names to include. -#' @param group `string`: (optional) name of one or more column groups to -#' include. Valid options are `"basic"`, `"event"` `"taxonomy"`, `"media"` and -#' `"assertions"`. -#' @return A tibble -#' specifying the name and type of each column to include in the -#' call to `atlas_counts()` or `atlas_occurrences()`. -#' @details -#' GBIF nodes store content in hundreds of different fields, and users often -#' require thousands or millions of records at a time. To reduce time taken to -#' download data, and limit complexity of the resulting `tibble`, it is sensible -#' to restrict the fields returned by occurrence queries. The full list of -#' available fields can be viewed with `show_all(fields)`. Note that `select()` -#' and `galah_select()` are supported for all atlases that allow downloads, with -#' the exception of GBIF, for which all columns are returned. -#' -#' Calling the argument `group = "basic"` returns the following columns: -#' -#' * `decimalLatitude` -#' * `decimalLongitude` -#' * `eventDate` -#' * `scientificName` -#' * `taxonConceptID` -#' * `recordID` -#' * `dataResourceName` -#' * `occurrenceStatus` -#' -#' Using `group = "event"` returns the following columns: -#' -#' * `eventRemarks` -#' * `eventTime` -#' * `eventID` -#' * `eventDate` -#' * `samplingEffort` -#' * `samplingProtocol` -#' -#' Using `group = "media"` returns the following columns: -#' -#' * `multimedia` -#' * `multimediaLicence` -#' * `images` -#' * `videos` -#' * `sounds` -#' -#' Using `group = "taxonomy"` returns higher taxonomic information for a given -#' query. It is the only `group` that is accepted by `atlas_species()` as well -#' as `atlas_occurrences()`. -#' -#' Using `group = "assertions"` returns all quality assertion-related -#' columns. The list of assertions is shown by `show_all_assertions()`. -#' -#' For `atlas_occurrences()`, arguments passed to `...` should be valid field -#' names, which you can check using `show_all(fields)`. For `atlas_species()`, -#' it should be one or more of: -#' -#' * `counts` to include counts of occurrences per species. -#' * `synonyms` to include any synonymous names. -#' * `lists` to include authoritative lists that each species is included on. -#' -#' @seealso \code{\link[=filter.data_request]{filter()}}, -#' \code{\link[=st_crop.data_request]{st_crop()}} and -#' \code{\link[=identify.data_request]{identify()}} for other ways to restrict -#' the information returned; `show_all(fields)` to list available fields. -#' @examples \dontrun{ -#' # Download occurrence records of *Perameles*, -#' # Only return scientificName and eventDate columns -#' galah_config(email = "your-email@email.com") -#' galah_call() |> -#' identify("perameles")|> -#' select(scientificName, eventDate) |> -#' collect() -#' -#' # Only return the "basic" group of columns and the basisOfRecord column -#' galah_call() |> -#' identify("perameles") |> -#' select(basisOfRecord, group = "basic") |> -#' collect() -#' -#' # When used in a pipe, `galah_select()` and `select()` are synonymous. -#' # Hence the previous example can be rewritten as: -#' galah_call() |> -#' galah_identify("perameles") |> -#' galah_select(basisOfRecord, group = "basic") |> -#' collect() -#' } -#' @importFrom rlang inform -#' @export -select.data_request <- function(.data, ..., group){ - if(is_gbif()){ - inform("`select()` is not supported for GBIF: skipping") - .data - }else{ - dots <- enquos(..., .ignore_empty = "all") |> - as.list() |> - add_summary() |> - add_group(group) - update_data_request(.data, select = dots) - } -} - #' @rdname select.data_request #' @export -galah_select <- function(..., group){ - dots <- enquos(..., .ignore_empty = "all") |> +galah_select <- function(..., group = NULL){ + dots <- rlang::enquos(..., .ignore_empty = "all") |> detect_request_object() |> as.list() if(is_gbif()){ - inform("`select()` is not supported for GBIF: skipping") + cli::cli_text("`select()` is not supported for GBIF occurrence downloads API v1: skipping") if(inherits(dots[[1]], "data_request")){ dots[[1]] }else{ NULL } }else{ - dots <- dots |> - add_summary() |> - add_group(group) - if(inherits(dots[[1]], "data_request")){ - update_data_request(dots[[1]], select = dots[-1]) - }else{ - dots - } - } -} - -#' internal function to summarise select function (to support `print()`) -#' @importFrom rlang as_label -#' @noRd -#' @keywords Internal -add_summary <- function(dots){ - labels <- lapply(dots, as_label) |> - unlist() - labels <- labels[labels != ""] - last_entry <- length(dots) + 1 - dots[[last_entry]] <- paste(labels, collapse = " | ") - names(dots)[last_entry] <- "summary" - dots -} - -#' internal function to add `group` arg to the end of a list -#' @noRd -#' @keywords Internal -add_group <- function(dots, group){ - group <- check_groups(group, n = length(dots)) - summary_length <- nchar(dots$summary) - if(is.null(group)){ - if(summary_length < 1){ - group <- "basic" - dots$group <- group - }else{ - dots$group <- vector(mode = "character", length = 0L) + if(length(dots) < 1){ + list(quosure = c(), summary = "") |> + add_group(group) } - }else{ - dots$group <- group - } - if(length(dots$group) > 0){ - if(summary_length < 1){ - separator <- "" + else if(inherits(dots[[1]], "data_request")){ + list(quosure = dots[-1], + summary = generate_summary(dots[-1])) |> + add_group(group) |> + update_request_object(dots[[1]], + select = _) }else{ - separator <- " | " - } - dots$summary <- paste0(dots$summary, - separator, - "group = ", - paste(group, collapse = ", ")) + list(quosure = dots, + summary = generate_summary(dots)) |> + add_group(group) + } } - dots } \ No newline at end of file diff --git a/R/quosure_handling.R b/R/handle_quosures.R similarity index 56% rename from R/quosure_handling.R rename to R/handle_quosures.R index 6e10178c..2d568051 100644 --- a/R/quosure_handling.R +++ b/R/handle_quosures.R @@ -2,49 +2,18 @@ # related functions. Note that the approach used below is taken from advanced R: # https://adv-r.hadley.nz/expressions.html -#' This should parse out a request object and return quosures thereafter -#' @importFrom rlang eval_tidy -#' @importFrom rlang get_expr -#' @importFrom rlang quo_get_expr -#' @importFrom stringr str_detect -#' @noRd -#' @keywords Internal -detect_request_object <- function(dots){ - if (length(dots) > 0) { - call_string <- get_expr(dots)[[1]] |> - quo_get_expr() |> - deparse() |> - paste(collapse = " ") # captures multi-lines - # note: no leading "^" below, - # because pipes can parse to e.g. `galah_identify(galah_call(...` - types <- c( - "galah_call\\(", - "request_data\\(", - "request_metadata\\(", - "request_files\\(", - "^~.$", - "^.$") |> - paste(collapse = "|") - if (str_detect(call_string, types)) { # note: "~." or "." indicate presence of the magrittr pipe (%>%) - eval_request <- eval_tidy(dots[[1]]) - c(list(eval_request), dots[-1]) - }else{ - dots - } - }else{ - NULL - } -} +## -- Top-level parsers -- ## +# These are called 'first' by `galah_` functions #' parse quosures for objects of class `data_request` -#' @importFrom dplyr bind_rows -#' @importFrom tibble tibble #' @noRd #' @keywords internal -parse_quosures_data <- function(dots){ +parse_quosures_data <- function(dots){ if(length(dots) > 0){ - result <- lapply(dots, switch_expr_type) |> - bind_rows() |> + result <- purrr::map(dots, \(a){ + switch_expr_type(a) + }) |> + dplyr::bind_rows() |> clean_assertions() |> clean_logical_statements() result$query <- as.character(result$query) @@ -52,15 +21,87 @@ parse_quosures_data <- function(dots){ result <- NULL } if(is.null(result)){ - result <- tibble( + result <- tibble::tibble( variable = character(), logical = character(), value = character(), query = character()) } - result + as_data_filter(result) +} +# FIXME: work out how to propagate `rlang::caller_env()` through the below functions + +#' parse quosures, but for `select` and related functions +#' +#' Major difference here is there is no need for parsing; simply return +#' stuff that is a named object +#' @noRd +#' @keywords internal +parse_quosures_basic <- function(dots, + error_call = rlang::caller_env()){ + if(length(dots) > 0){ + parsed_dots <- purrr::map(dots, \(a){ + switch(expr_type(a), + "symbol" = {parse_symbol(a)}, + "call" = {rlang::eval_tidy(a)}, + "literal" = {rlang::quo_get_expr(a)}, + cli::cli_abort("Quosure type not recognised.", + call = error_call)) + }) + unlist(parsed_dots) + }else{ + NULL + } +} + +#' parse quosures, but for `filter.files_request()` where we expect large amounts +#' of data to be supplied +#' @noRd +#' @keywords internal +parse_quosures_files <- function(dots, + error_call = rlang::caller_env()){ + if(length(dots) > 0){ + check_named_input(dots) + dot_expr <- rlang::quo_get_expr(dots[[1]]) # i.e. only first entry is available + # get formula lhs + lhs <- rlang::f_lhs(dot_expr) + if(rlang::is_quosure(lhs)){ + lhs <- rlang::quo_get_expr(lhs) + } + lhs <- rlang::as_string(lhs) |> + dequote() + # get rhs + x <- rlang::f_rhs(dot_expr) |> + rlang::new_quosure(env = rlang::quo_get_env(dots[[1]])) + rhs <- switch(expr_type(x), + "call" = {rlang::eval_tidy(x)}, + "symbol" = {if(exists(rlang::quo_get_expr(x), + where = rlang::quo_get_env(x))){ + rlang::eval_tidy(x) + }else{ + rlang::as_label(x) + }}, + "literal" = {rlang::quo_get_expr(x)}, + cli::cli_abort("Quosure type not recognised.", + call = error_call)) + # if(inherits(rhs, "data.frame")){ + list(variable = dequote(lhs), + data = rhs) |> + as_files_filter() + # }else{ + # tibble::tibble( + # variable = dequote(lhs), + # logical = "==", + # value = rhs) + # } + }else{ + NULL + } } +## -- `data.frame` cleaning -- ## +# This is for cleaning the 'default' output from parsers + #' Function to ensure assertions are placed first in a query #' This is important so that they are parsed correctly #' Note this only gets triggered for AND statements - OR is handled earlier @@ -72,12 +113,12 @@ clean_assertions <- function(df){ check_1 <- concatenate_assertions(df[assertions_check, ], logical = "!=") check_2 <- concatenate_assertions(df[assertions_check, ], logical = "==") if(all(is.null(c(check_1, check_2)))){ - bind_rows( + dplyr::bind_rows( df[assertions_check, ], df[!assertions_check, ] ) }else{ - bind_rows( + dplyr::bind_rows( check_1, check_2, df[!assertions_check, ] @@ -122,77 +163,6 @@ clean_logical_statements <- function(df){ df } -#' parse quosures, but for `select` and related functions -#' -#' Major difference here is there is no need for parsing; simply return -#' stuff that is a named object -#' @importFrom rlang abort -#' @importFrom rlang eval_tidy -#' @importFrom rlang quo_get_expr -#' @noRd -#' @keywords internal -parse_quosures_basic <- function(dots){ - if(length(dots) > 0){ - parsed_dots <- lapply(dots, function(a){ - switch(expr_type(a), - "symbol" = {parse_symbol(a)}, - "call" = {eval_tidy(a)}, - "literal" = {quo_get_expr(a)}, - abort("Quosure type not recognised.")) - }) - unlist(parsed_dots) - }else{ - NULL - } -} - -#' parse quosures, but for `filter.files_request()` where we expect large amounts -#' of data to be supplied -#' @importFrom rlang as_label -#' @importFrom rlang as_string -#' @importFrom rlang is_quosure -#' @importFrom rlang f_lhs -#' @importFrom rlang f_rhs -#' @importFrom rlang quo_get_env -#' @importFrom rlang quo_get_expr -#' @importFrom tibble tibble -#' @noRd -#' @keywords internal -parse_quosures_files <- function(dots){ - if(length(dots) > 0){ - check_named_input(dots) - dot_expr <- quo_get_expr(dots[[1]]) # i.e. only first entry is available - # get formula lhs - lhs <- f_lhs(dot_expr) - if(is_quosure(lhs)){ - lhs <- quo_get_expr(lhs) - } - lhs <- as_string(lhs) |> dequote() - # get rhs - x <- new_quosure(f_rhs(dot_expr), env = quo_get_env(dots[[1]])) - rhs <- switch(expr_type(x), - "call" = {eval_tidy(x)}, - "symbol" = {if(exists(quo_get_expr(x), - where = quo_get_env(x))){ - eval_tidy(x) - }else{ - as_label(x) - }}, - "literal" = {quo_get_expr(x)}, - abort("Quosure type not recognised.")) - if(inherits(rhs, "data.frame")){ - list(variable = dequote(lhs), data = rhs) - }else{ - tibble( - variable = dequote(lhs), - logical = "==", - value = rhs) - } - }else{ - NULL - } -} - #' Internal function to remove quoting of variable names #' Used as quotes are added when lhs is set using {{}} #' @noRd @@ -201,35 +171,32 @@ dequote <- function(x){ gsub("^\"|\"$", "", x) } + +## -- Quosure parsing -- ## + #' Switch functions for quosures #' @param x A (single) quosure -#' @importFrom rlang abort -#' @importFrom rlang quo_get_expr #' @noRd #' @keywords internal switch_expr_type <- function(x, ...){ switch(expr_type(x), "symbol" = {parse_symbol(x)}, "call" = {parse_call(x, ...)}, - "literal" = {quo_get_expr(x)}, - abort("Quosure type not recognised.") + "literal" = {rlang::quo_get_expr(x)}, + cli::cli_abort("Quosure type not recognised.") ) } #' Get type from quosures #' @param x A (single) quosure -#' @importFrom rlang quo_is_symbol -#' @importFrom rlang quo_is_call -#' @importFrom rlang quo_get_expr -#' @importFrom rlang is_syntactic_literal #' @noRd #' @keywords internal expr_type <- function(x){ - if(quo_is_symbol(x)){ + if(rlang::quo_is_symbol(x)){ "symbol" - }else if(quo_is_call(x)){ + }else if(rlang::quo_is_call(x)){ "call" - }else if(is_syntactic_literal(quo_get_expr(x))){ + }else if(rlang::quo_get_expr(x) |> rlang::is_syntactic_literal()){ "literal" }else{ typeof(x) @@ -238,22 +205,18 @@ expr_type <- function(x){ #' Check whether symbols exist before they are parsed #' @param x A (single) quosure -#' @importFrom rlang quo_get_expr -#' @importFrom rlang quo_get_env -#' @importFrom rlang eval_tidy -#' @importFrom rlang as_label #' @noRd #' @keywords internal parse_symbol <- function(x){ - if(exists(quo_get_expr(x), where = quo_get_env(x))){ - result <- eval_tidy(x) + if(exists(rlang::quo_get_expr(x), where = rlang::quo_get_env(x))){ + result <- rlang::eval_tidy(x) if(inherits(result, "function")){ # special case for functions like 'data' - as_label(x) # which exist in Global + rlang::as_label(x) # which exist in Global }else{ result } }else{ - as_label(x) + rlang::as_label(x) } } @@ -268,20 +231,14 @@ parse_symbol <- function(x){ #' galah behavior. So `x <- 1; y <- 10; filter(y == x)` will parse to #' `list(y = 1)` not `list(10 = 1)`. Advanced R suggests using `:=` for these #' cases, which could be added to `switch` below -#' @importFrom rlang abort -#' @importFrom rlang as_quosure -#' @importFrom rlang as_string -#' @importFrom rlang eval_tidy -#' @importFrom rlang quo_get_expr -#' @importFrom rlang quo_get_env #' @noRd #' @keywords internal parse_call <- function(x, ...){ - y <- quo_get_expr(x) - env_tr <- quo_get_env(x) + y <- rlang::quo_get_expr(x) + env_tr <- rlang::quo_get_env(x) switch_lookup <- y[[1]] |> deparse() |> - as_string() |> + rlang::as_string() |> function_type() switch(switch_lookup, # i.e. switch depending on what function is called "relational_operator" = parse_relational(x, ...), @@ -291,7 +248,7 @@ parse_call <- function(x, ...){ "is.na" = parse_is_na(x, ...), "between" = parse_between(x, ...), "%in%" = parse_in(x, ...), - eval_tidy(x) # if unknown, parse + rlang::eval_tidy(x) # if unknown, parse # {filter_error()} # if unknown, error ) } @@ -321,33 +278,21 @@ function_type <- function(x){ # assumes x is a string #' Take standard filter-style queries and parse to `galah_filter()`-style `tibble` #' Called by `parse_call` -#' @importFrom dplyr all_of -#' @importFrom dplyr rename -#' @importFrom dplyr select -#' @importFrom rlang as_label -#' @importFrom rlang as_quosure -#' @importFrom rlang as_string -#' @importFrom rlang f_lhs -#' @importFrom rlang is_empty -#' @importFrom rlang is_bare_environment -#' @importFrom rlang parse_expr -#' @importFrom rlang f_rhs -#' @importFrom tibble tibble #' @noRd #' @keywords internal parse_relational <- function(x, ...){ - expr <- quo_get_expr(x) + expr <- rlang::quo_get_expr(x) if(length(expr) != 3L){filter_error()} - lhs <- f_lhs(expr) |> - as_label() |> + lhs <- rlang::f_lhs(expr) |> + rlang::as_label() |> dequote() - rhs <- as_quosure(f_rhs(expr), - env = quo_get_env(x)) |> + rhs <- rlang::as_quosure(rlang::f_rhs(expr), + env = rlang::quo_get_env(x)) |> switch_expr_type() |> as.character() - result <- tibble( + result <- tibble::tibble( variable = lhs, logical = as.character(expr[[1]]), # should probably be `relational` value = rhs) @@ -371,33 +316,29 @@ parse_relational <- function(x, ...){ } #' Handle & and | statements -#' @importFrom rlang as_quosure -#' @importFrom rlang as_string -#' @importFrom rlang quo_get_env #' @noRd #' @keywords internal parse_logical <- function(x, ...){ - provided_string <- quo_get_expr(x)[[1]] |> as_string() + provided_string <- rlang::quo_get_expr(x)[[1]] |> + rlang::as_string() if(grepl("\\|{1,2}", provided_string)){ logical_string <- " OR " }else{ logical_string <- " AND " } - linked_statements <- lapply(quo_get_expr(x)[-1], - function(a){ - switch_expr_type( - as_quosure(a, env = quo_get_env(x)), ...) - }) |> - bind_rows() + linked_statements <- purrr::map(as.list(rlang::quo_get_expr(x)[-1]), + \(a){ + a |> + rlang::as_quosure(env = rlang::quo_get_env(x)) |> + switch_expr_type(...) + }) |> + dplyr::bind_rows() concatenate_logical_tibbles(linked_statements, provided_string = provided_string, logical_string = logical_string) } #' Internal function to handle concatenation of logicals -#' @importFrom glue glue -#' @importFrom glue glue_collapse -#' @importFrom tibble tibble #' @noRd #' @keywords Internal concatenate_logical_tibbles <- function(df, @@ -406,65 +347,60 @@ concatenate_logical_tibbles <- function(df, if(all(df$variable == "assertions")){ query_text <- df$query |> gsub("^-", "", x = _) |> - glue_collapse(sep = logical_string) + glue::glue_collapse(sep = logical_string) if(all(df$logical == "!=")){ - query_text <- glue("-({query_text})") + query_text <- glue::glue("-({query_text})") } }else{ query_text <- df$query |> - glue_collapse(sep = logical_string) + glue::glue_collapse(sep = logical_string) } - tibble( - variable = glue_collapse(df$variable, sep = provided_string), - logical = glue_collapse(df$logical, sep = provided_string), - value = glue_collapse(df$value, sep = provided_string), - query = as.character(glue("{query_text}"))) + tibble::tibble( + variable = glue::glue_collapse(df$variable, sep = provided_string), + logical = glue::glue_collapse(df$logical, sep = provided_string), + value = glue::glue_collapse(df$value, sep = provided_string), + query = as.character(glue::glue("{query_text}"))) } #' Parse `call`s that contain brackets #' Where this happens, they are always length-2, with "(" as the first entry. -#' @importFrom rlang as_quosure -#' @importFrom rlang quo_get_expr -#' @importFrom rlang quo_get_env #' @noRd #' @keywords internal parse_brackets <- function(x, ...){ - if(length(quo_get_expr(x)) != 2L){filter_error()} - switch_expr_type(as_quosure(quo_get_expr(x)[[-1]], - env = quo_get_env(x)), - ...) # pass this down the chain + if(length(rlang::quo_get_expr(x)) != 2L){ + filter_error() + } + rlang::quo_get_expr(x)[[-1]] |> + rlang::as_quosure(env = rlang::quo_get_env(x)) |> + switch_expr_type(...) # pass this down the chain } #' Parse `call`s that contain exclamations #' Where this happens, they are always length-2, with "(" as the first entry. -#' @importFrom rlang as_quosure -#' @importFrom rlang quo_get_expr -#' @importFrom rlang quo_get_env #' @noRd #' @keywords internal parse_exclamation <- function(x){ # extract call after `!`, preserves that `!` = TRUE - switch_expr_type(as_quosure(quo_get_expr(x)[[-1]], - env = quo_get_env(x)), - excl = TRUE) # pass this down the chain + rlang::quo_get_expr(x)[[-1]] |> + rlang::as_quosure(env = rlang::quo_get_env(x)) |> + switch_expr_type(excl = TRUE) # pass this down the chain } #' Parse `call`s that contain `is.na()` #' Where this happens, they are always length-2, with "(" as the first entry. -#' @importFrom rlang as_quosure -#' @importFrom rlang is_empty -#' @importFrom rlang quo_get_expr -#' @importFrom rlang quo_get_env #' @noRd #' @keywords internal parse_is_na <- function(x, ...){ - if(length(quo_get_expr(x)) != 2L){filter_error()} + if(length(rlang::quo_get_expr(x)) != 2L){ + filter_error() + } dots <- list(...) - logical <- ifelse(is_empty(dots), "==", "!=") + logical <- ifelse(rlang::is_empty(dots), "==", "!=") # for LA cases - result <- tibble( - variable = switch_expr_type(as_quosure(quo_get_expr(x)[[2]], - env = quo_get_env(x))), + result <- tibble::tibble( + variable = rlang::quo_get_expr(x)[[2]] |> + rlang::as_quosure(env = rlang::quo_get_env(x)) |> + switch_expr_type(), logical = logical, value = as.character("")) result$query <- parse_solr(result) @@ -473,94 +409,93 @@ parse_is_na <- function(x, ...){ #' Parse `call`s that contain `dplyr::between()` #' Where this happens, they are always length-4, with "between" as the first entry. -#' @importFrom rlang as_quosure #' @noRd #' @keywords internal parse_between <- function(x, excl){ - if(length(quo_get_expr(x)) < 4L){filter_error()} + if(length(rlang::quo_get_expr(x)) < 4L){ + filter_error() + } # for LA cases if(isTRUE(excl)) { logical <- c(as.character(">"), c(as.character("<"))) } else{ logical <- c(as.character("<"), c(as.character(">"))) } - result <- tibble( - variable = c(rep(as_label(quo_get_expr(x)[[2]]))), + result <- tibble::tibble( + variable = c(rep(rlang::as_label(rlang::quo_get_expr(x)[[2]]))), logical = logical, value = as.character( - c(switch_expr_type(as_quosure(quo_get_expr(x)[[3]], - env = quo_get_env(x))), - switch_expr_type(as_quosure(quo_get_expr(x)[[4]], - env = quo_get_env(x)))))) - result$query <- c(parse_solr(result[1,]), parse_solr(result[2,])) + c(switch_expr_type(rlang::as_quosure(rlang::quo_get_expr(x)[[3]], + env = rlang::quo_get_env(x))), + switch_expr_type(rlang::as_quosure(rlang::quo_get_expr(x)[[4]], + env = rlang::quo_get_env(x)))))) + result$query <- c(parse_solr(result[1,]), + parse_solr(result[2,])) return(result) } #' Parse `call`s that contain `%in%` #' #' Where this happens, they are always length-3, with "%in%" as the first entry. -#' @importFrom glue glue -#' @importFrom glue glue_collapse -#' @importFrom rlang as_quosure -#' @importFrom rlang enquo -#' @importFrom rlang parse_expr #' @noRd #' @keywords internal parse_in <- function(x, excl){ # convert to logical format using OR statements - variable <- as_label(quo_get_expr(x)[[2]]) + variable <- rlang::quo_get_expr(x)[[2]] |> + rlang::as_label() logical <- ifelse(missing(excl), "==", "!=") - value <- switch_expr_type(as_quosure(quo_get_expr(x)[[3]], - env = quo_get_env(x))) + value <- rlang::quo_get_expr(x)[[3]] |> + rlang::as_quosure(env = rlang::quo_get_env(x)) |> + switch_expr_type() # handle apostrophes (') - if(any(str_detect(value, "\\'"))) { + if(any(stringr::str_detect(value, "\\'"))) { value <- gsub("'", "\\\\'", value) } # convert to formula - in_as_or_statements <- rlang::parse_expr( - glue::glue_collapse( - glue("{variable} {logical} '{value}'"), - sep = " | " - )) + in_as_or_statements <- glue::glue_collapse( + glue::glue("{variable} {logical} '{value}'"), + sep = " | " + ) |> + rlang::parse_expr() # convert to quosure and pass to `parse_logical()` - as_quosure(in_as_or_statements, quo_get_env(x)) |> + rlang::as_quosure(x = in_as_or_statements, + env = rlang::quo_get_env(x)) |> parse_logical() } #' Parse `call`s that contain `c()` #' Where this happens, they are always length-2, with "c()" as the first entry. -#' @importFrom glue glue -#' @importFrom glue glue_collapse -#' @importFrom rlang as_quosure -#' @importFrom rlang enquo -#' @importFrom rlang parse_expr -#' @importFrom rlang quo_get_env -#' @importFrom rlang quo_get_expr #' @noRd #' @keywords internal parse_c <- function(x, excl){ - if(length(quo_get_expr(x)) < 2L){filter_error()} + if(length(rlang::quo_get_expr(x)) < 2L){ + filter_error() + } # convert to logical format using OR statements - variable <- quo_get_expr(x)[[1]] |> - as_label() + variable <- rlang::quo_get_expr(x)[[1]] |> + rlang::as_label() logical <- ifelse(missing(excl), "==", "!=") - value <- as_quosure(quo_get_expr(x)[[3]], - env = quo_get_env(x)) |> + value <- rlang::quo_get_expr(x)[[3]] |> + rlang::as_quosure(env = rlang::quo_get_env(x)) |> switch_expr_type() - in_as_or_statements <- glue_collapse( - glue("{variable} {logical} '{value}'"), + in_as_or_statements <- glue::glue_collapse( + glue::glue("{variable} {logical} '{value}'"), sep = " | ") |> - parse_expr() - parse_logical(enquo(in_as_or_statements), quo_get_env(x)) # pass this to parse_logical + rlang::parse_expr() + parse_logical(rlang::enquo(in_as_or_statements), + rlang::quo_get_env(x)) # pass this to parse_logical } + +## -- SOLR conversion -- ## + #' Convert information in a `tibble` to a `solr` query #' Previously `galah_filter.R/parse_logical`, but altered to support multi-row tibbles #' @noRd #' @keywords internal parse_solr <- function(df){ if(nrow(df) > 1){ - lapply( + purrr::map( split(df, seq_len(nrow(df))), switch_solr) |> unlist() @@ -570,54 +505,53 @@ parse_solr <- function(df){ } #' Internal function to `parse_solr()` -#' @importFrom glue glue_data #' @noRd #' @keywords internal switch_solr <- function(df){ switch(df$logical, "==" = query_term(df$variable, df$value, TRUE), "!=" = query_term(df$variable, df$value, FALSE), - ">=" = glue_data(df, "{variable}:[{value} TO *]"), + ">=" = glue::glue_data(df, "{variable}:[{value} TO *]"), ">" = { lowest_value <- query_term(df$variable, df$value, TRUE) - glue_data(df, "{variable}:[{value} TO *] AND -{lowest_value}")}, - "<=" = glue_data(df, "{variable}:[* TO {value}]"), + glue::glue_data(df, "{variable}:[{value} TO *] AND -{lowest_value}")}, + "<=" = glue::glue_data(df, "{variable}:[* TO {value}]"), "<" = { highest_value <- query_term(df$variable, df$value, TRUE) - glue_data(df, "{variable}:[* TO {value}] AND -{highest_value}")} + glue::glue_data(df, "{variable}:[* TO {value}] AND -{highest_value}")} ) } #' Generic error for unknown cases -#' @importFrom rlang abort #' @noRd #' @keywords internal -filter_error <- function(){abort("Invalid argument passed to `filter()`.")} +filter_error <- function(){ + cli::cli_abort("Invalid argument passed to `filter()`.", + call = rlang::caller_env()) +} #' Subfunction called by `parse_solr()` -#' @importFrom glue glue -#' @importFrom rlang expr_text #' @noRd #' @keywords internal query_term <- function(name, value, include) { # add quotes around value - value <- lapply(value, expr_text) # format query value as solr-readable text + value <- purrr::map(value, rlang::expr_text) # format query value as solr-readable text if(value %in% c("", "\"\"")) { if(include){ - value_str <- glue("(*:* AND -{name}:*)") # queries with "==" + value_str <- glue::glue("(*:* AND -{name}:*)") # queries with "==" }else{ - value_str <- glue("({name}:*)") # queries with "!=" + value_str <- glue::glue("({name}:*)") # queries with "!=" } } else { # assertions do not require brackets if(name == "assertions"){ - value_str <- glue("{name}:{value}") + value_str <- glue::glue("{name}:{value}") }else{ - value_str <- glue("({name}:{value})") + value_str <- glue::glue("({name}:{value})") } # negations have a leading `-` if(!include){ - value_str <- glue("-{value_str}") + value_str <- glue::glue("-{value_str}") } } value_str diff --git a/R/handle_quosures_GBIF.R b/R/handle_quosures_GBIF.R new file mode 100644 index 00000000..75b06cac --- /dev/null +++ b/R/handle_quosures_GBIF.R @@ -0,0 +1,290 @@ +# Duplicate of `handle_quosures.R` with modifications to `parse_quosures_data()` +# to return predicates in place of a data.frame + +# Note that advice on constructing predicates is available here: +# https://techdocs.gbif.org/en/data-use/api-downloads + +## -- Top-level parsers -- ## +# These are called 'first' by `galah_` functions + +#' parse quosures for objects of class `data_request` +#' @noRd +#' @keywords internal +parse_quosures_data_gbif <- function(dots){ + if(length(dots) > 0){ + predicates <- lapply(dots, # NOTE: `map()` raises an error here + switch_expr_type_pred) + # sometimes, because we call `map()`, we end up with predicates + # buried one layer down in the list. Correct this + if(length(predicates) == 1L){ + # if(is.list(predicates[[1]])){ + result <- predicates[[1]] + # } + }else{ + # wipe predicate names + # NOTE: This step is *crucial* + # without it, jsonlite::toJSON() wraps predicates in `{}` instead of `[]` + # which is then rejected by GBIF + names(predicates) <- NULL + result <- list(type = "and", + predicates = predicates) + } + as_predicates_filter(result) + }else{ + NULL + } +} + +## -- Quosure parsing -- ## + +#' Switch functions for quosures +#' @param x A (single) quosure +#' @noRd +#' @keywords internal +switch_expr_type_pred <- function(x, ...){ + switch(expr_type(x), + "symbol" = {parse_symbol(x)}, # identical to `switch_expr_type()` + "call" = {parse_call_pred(x, ...)}, # only 'new' line + "literal" = {rlang::quo_get_expr(x)}, + cli::cli_abort("Quosure type not recognised.", + call = rlang::caller_env()) + ) +} + +#' Internal, recursive function to parse a call +#' +#' Note that most entries passed to `filter` will be of type `call`, making this +#' quite an important function. For example, `filter(y == 1)` is a call, but so +#' are functions, e.g. `filter(list(x = 1))`. +#' +#' Importantly, when using NSE, values are checked to see if they are present +#' in the working environment, but names are not, which is different to previous +#' galah behavior. So `x <- 1; y <- 10; filter(y == x)` will parse to +#' `list(y = 1)` not `list(10 = 1)`. Advanced R suggests using `:=` for these +#' cases, which could be added to `switch` below +#' @noRd +#' @keywords internal +parse_call_pred <- function(x){ + y <- rlang::quo_get_expr(x) + env_tr <- rlang::quo_get_env(x) + switch_lookup <- y[[1]] |> + base::deparse() |> + rlang::as_string() |> + function_type() # galah function + switch(switch_lookup, # i.e. switch depending on what function is called + "relational_operator" = parse_relational_pred(x), + "logical_operator" = parse_logical_pred(x), + "bracket" = parse_brackets_pred(x), + "exclamation" = parse_exclamation_pred(x), + "is.na" = parse_is_na_pred(x), + "between" = parse_between_pred(x), + "%in%" = parse_in_pred(x), + rlang::eval_tidy(x) # if unknown, parse + # {filter_error()} # if unknown, error + ) +} + +#' Take standard filter-style queries and parse to `galah_filter()`-style `tibble` +#' Called by `parse_call` +#' @noRd +#' @keywords internal +parse_relational_pred <- function(x){ + + # get expression + expr <- rlang::quo_get_expr(x) + if(length(expr) != 3L){ + filter_error() + } + + # parse out separate parts + operator <- as.character(expr[[1]]) + + lhs <- rlang::f_lhs(expr) |> + rlang::as_label() |> + dequote() |> # galah function + gbif_upper_case() # galah function + + rhs <- rlang::as_quosure(rlang::f_rhs(expr), + env = rlang::quo_get_env(x)) |> + switch_expr_type_pred() |> + as.character() + + # handle cases where someone passes a vector, i.e. year == c(2001, 2002) + # these can be parse as 'in' + if(length(rhs) > 1){ + list( + type = "in", + key = lhs, + values = rhs) + + # otherwise we assume they are length-1 and continue + }else{ + + # 'does not equal' is handled hierarchically + if(operator == "!="){ + list( + type = "not", + predicate = list(type = "equals", + key = lhs, + value = rhs)) + + # everything else is flat + }else{ + operator_text <- switch(operator, + "==" = "equals", + "<" = "lessThan", + "<=" = "lessThanOrEquals", + ">" = "greaterThan", + ">=" = "greaterThanOrEquals") + list(type = operator_text, + key = lhs, + value = rhs) + } + } +} + +#' Handle & and | statements +#' @noRd +#' @keywords internal +parse_logical_pred <- function(x){ + # get provided info + provided_string <- rlang::quo_get_expr(x)[[1]] |> + rlang::as_string() + + # convert statements to strings + if(grepl("\\|{1,2}", provided_string)){ + logical_string <- "or" + }else{ + logical_string <- "and" + } + + # wrap later predicates in supplied boolean + # NOTE: deliberate use of `lapply()` and NOT `purrr::map()` + subpredicates <- lapply(rlang::quo_get_expr(x)[-1], + \(a){ + rlang::as_quosure(a, + env = rlang::quo_get_env(x)) |> + switch_expr_type_pred() + }) + names(subpredicates) <- NULL + list(type = logical_string, + predicates = subpredicates) +} + +#' Parse `call`s that contain brackets +#' Where this happens, they are always length-2, with "(" as the first entry. +#' @noRd +#' @keywords internal +parse_brackets_pred <- function(x){ + if(length(rlang::quo_get_expr(x)) != 2L){ + filter_error() + } + try_next_quosure_pred(x) +} + +#' Parse `call`s that contain exclamations +#' Where this happens, they are always length-2, with "(" as the first entry. +#' @noRd +#' @keywords internal +parse_exclamation_pred <- function(x){ + next_section <- try_next_quosure_pred(x) + next_length <- length(next_section) + if(next_length == 2 & !is.null(next_section$type)){ + if(next_section$type == "isNull"){ + next_section$type <- "isNotNull" + next_section + }else{ + list(type = "not", + predicate = next_section) + } + }else{ + list(type = "not", + predicate = next_section) + } +} + +#' A common pattern is to parse the first thing, then remove it and +#' keep going. This function is shorthand for that operation. +#' @noRd +#' @keywords internal +try_next_quosure_pred <- function(x){ + + ## This version originally used in exclamation and brackets code + rlang::as_quosure(rlang::quo_get_expr(x)[[-1]], + env = rlang::quo_get_env(x)) |> + switch_expr_type_pred() +} + +#' Parse `call`s that contain `is.na()` +#' Where this happens, they are always length-2, with "(" as the first entry. +#' @noRd +#' @keywords internal +parse_is_na_pred <- function(x){ + if(length(rlang::quo_get_expr(x)) != 2L){ + filter_error() + } + + variable <- rlang::as_label(rlang::quo_get_expr(x)[[2]]) |> + dequote() |> # galah function + gbif_upper_case() # galah function + + list(type = "isNull", + parameter = variable) +} + +#' Parse `call`s that contain `dplyr::between()` +#' Where this happens, they are always length-4, with "between" as the first entry. +#' @noRd +#' @keywords internal +parse_between_pred <- function(x){ + x_expr <- rlang::quo_get_expr(x) + if(length(x_expr) < 4L){ + filter_error() + } + + lhs <- x_expr[[2]] |> + rlang::as_label() |> + dequote() |> # galah function + gbif_upper_case() # galah function + + lower_bound <- list(type = "greaterThanOrEquals", + key = lhs, + value = rlang::as_label(x_expr[[3]])) + + upper_bound <- list(type = "lessThanOrEquals", + key = lhs, + value = rlang::as_label(x_expr[[4]])) + + list(type = "and", + predicates = list(lower_bound, upper_bound)) +} + +#' Parse `call`s that contain `%in%` +#' +#' Where this happens, they are always length-3, with "%in%" as the first entry. +#' @noRd +#' @keywords internal +parse_in_pred <- function(x){ + + # extract relevant information + lhs <- rlang::as_label(rlang::quo_get_expr(x)[[2]]) |> + dequote() |> # galah function + gbif_upper_case() # galah function + + rhs <- rlang::as_quosure(rlang::quo_get_expr(x)[[3]], + env = rlang::quo_get_env(x)) |> + switch_expr_type() + ## NOTE: Not clear that this is correct. + ## Should parse to: `"values": ["cat1", "cat2", "cat3"]` + + # handle apostrophes (') + if(any(stringr::str_detect(rhs, "\\'"))) { + rhs <- gsub("'", "\\\\'", rhs) + } + + # format as list + list( + type = "in", + key = lhs, + values = rhs) +} \ No newline at end of file diff --git a/R/handle_request_objects.R b/R/handle_request_objects.R new file mode 100644 index 00000000..c2b6fb4d --- /dev/null +++ b/R/handle_request_objects.R @@ -0,0 +1,134 @@ +#' This should parse out a request object and return quosures thereafter +#' @noRd +#' @keywords Internal +detect_request_object <- function(dots){ + if (length(dots) > 0) { + call_string <- rlang::get_expr(dots)[[1]] |> + rlang::quo_get_expr() |> + deparse() |> + glue::glue_collapse(sep = " ") # captures multi-lines + # note: no leading "^" below, + # because pipes can parse to e.g. `galah_identify(galah_call(...` + types <- c( + "galah_call\\(", + "request_data\\(", + "request_metadata\\(", + "request_files\\(", + "^~.$", + "^.$") |> + paste(collapse = "|") + if (stringr::str_detect(call_string, types)) { # note: "~." or "." indicate presence of the magrittr pipe (%>%) + eval_request <- rlang::eval_tidy(dots[[1]]) + c(list(eval_request), dots[-1]) + }else{ + dots + } + }else{ + NULL + } +} + +#' Internal function to update a `data_request` or `metadata_request` +#' @param x an object to update +#' @param ... named entry to add +#' @noRd +#' @keywords Internal +update_request_object <- function(x, + ..., + error_call = rlang::caller_env()){ + # collect supplied information + x_class <- class(x) + x_names <- names(x) + dots <- list(...) + dot_names <- names(dots) + + # ensure only one value is supplied + if(length(dots) > 1){ + cli::cli_warn("Can only update a request with one object at a time; skipping") + x + } + + # ensure it is named + if(length(dot_names) < 1){ + cli::cli_warn("Error updating `data_request` object - all entries must be named - skipping", + call = error_call) + x + } + + # if this slot is already populated, update or overwrite + if(any(x_names == dot_names)){ + x[[dot_names]] <- switch(dot_names, + "identify" = { + bind_unique_rows(x[[dot_names]], + dots[[dot_names]], + "search_term") + }, + "filter" = { + update_filter(x[[dot_names]], + dots[[dot_names]], + "query") + }, + "select" = { + update_select(x[[dot_names]], + dots[[dot_names]]) + }, + # for below, we assume that in all other circumstances we + # simply pass the most recent result (i.e. overwrite) + dots[[dot_names]] # default + ) + structure(x, class = x_class) + }else{ # if not already present, add to end of object + structure(c(x, dots), class = x_class) + } +} + +#' Internal function to join together two `select` objects +#' @noRd +#' @keywords Internal +update_select <- function(x, y){ + quosure_check_x <- purrr::map(x, rlang::is_quosure) |> unlist() + quosure_check_y <- purrr::map(y, rlang::is_quosure) |> unlist() + if(any(quosure_check_y)){ + result <- append(x[quosure_check_x], y[quosure_check_y]) + }else if(any(quosure_check_x)){ + result <- x[quosure_check_x] + }else{ + result <- list() + } + group_vec <- unique(c(x$group, y$group)) + if(length(group_vec) < 1){ + group_vec <- NULL + } + result |> + generate_summary() |> + add_group(group = group_vec) +} + +## FIXME: do we need `update_identify()` to support GBIF, +## using same logic as `update_filter()`? + +#' Internal function to join together two `filter` objects +#' @noRd +#' @keywords Internal +update_filter <- function(x, y, column){ + if(!all(class(x) == class(y))){ + cli::cli_abort("Cannot join unlike filter objects") + } + # first join predicates + if(inherits(x, "predicates_filter") ){ + join_predicates(x, y) + }else{ # then tibbles + bind_unique_rows(x, y, column) + } +} + + +#' Internal function to join tibbles by row +#' @noRd +#' @keywords Internal +bind_unique_rows <- function(x, y, column){ + result <- list(x, y) |> + dplyr::bind_rows() |> + tibble::tibble() + dplyr::filter(result, !duplicated(result[[column]])) +} \ No newline at end of file diff --git a/R/messages.R b/R/messages.R index ca7ce9da..5ebc40b3 100644 --- a/R/messages.R +++ b/R/messages.R @@ -1,16 +1,14 @@ #' Internal function called by `check_login()` #' @noRd #' @keywords Internal -abort_email_missing <- function(error_call = caller_env()){ - bullets <- c( +abort_email_missing <- function(error_call = rlang::caller_env()){ + c( "No user email was found.", - i = glue( - "To download occurrence records or species lists you must provide a valid email \\ - address registered with the selected atlas." - ), - i = glue("Provide your email address using `galah_config(email = )`.") - ) - abort(bullets, call = error_call) + i = "To download occurrence records, species lists, or (for GBIF) occurrence + counts, \\ + you must provide a valid email address registered with the selected atlas.", + i = "Provide your email address using `galah_config(email = )`.") |> + cli::cli_abort(call = error_call) } # Internal function called by `check_login()` @@ -27,11 +25,12 @@ abort_email_missing <- function(error_call = caller_env()){ #' System-wide, generic failure message #' @noRd #' @keywords Internal -system_down_message <- function(function_name){ - bullets <- c( - glue("Calling the API failed for `{function_name}`."), +system_down_message <- function(function_name, + error_call = rlang::caller_env()){ + c( + "Calling the API failed for `{function_name}`.", i = "This might mean that the API is down, or that you are not connected to the internet.", i = "Double check that your query is correct, or try again later." - ) - inform(bullets) + ) |> + cli::cli_abort(call = error_call) } \ No newline at end of file diff --git a/R/onload.R b/R/onload.R index 03003fe9..caa431f5 100644 --- a/R/onload.R +++ b/R/onload.R @@ -1,30 +1,42 @@ #' Set-up for galah during loading #' @noRd #' @keywords Internal -#' @importFrom cli col_magenta -#' @importFrom glue glue -#' @importFrom potions brew -.onLoad <- function(libname, pkgname) { +.onAttach <- function(libname, pkgname) { if (pkgname == "galah") { - brew(.pkg = "galah") - galah_config() # to cache defaults - options(list( - "check_internal_cache" = galah_internal_cached)) - # add a note to the user + + # set up storage of standard information via {potions} + potions::brew(.pkg = "galah") # set up caching of behaviour + quiet_config <- purrr::quietly(galah_config) + config_info <- quiet_config() # to cache defaults without raising a message + + # get information to display to the user + ## get the galah version, if we can galah_version <- "version unknown" suppressWarnings( try(galah_version <- utils::packageDescription("galah")[["Version"]], - silent = TRUE)) ## get the galah version, if we can - bullets <- c( - glue("galah: version {galah_version}"), - i = col_magenta('Default node set to ALA (ala.org.au).'), - i = col_magenta('See all supported GBIF nodes with `show_all(atlases)`.'), - i = col_magenta('To change nodes, use e.g. `galah_config(atlas = \"GBIF\")`.') - ) - inform(bullets, - class = c("packageStartupMessage", # see ?packageStartupMessage (required by `check()`) - "simpleMessage", - "message", - "condition")) + silent = TRUE)) + + # show currently-selected atlas + current_node <- potions::pour("atlas", .pkg = "galah") |> + purrr::pluck("acronym") + current_url <- show_all_atlases() |> + dplyr::filter(.data$acronym == current_node) |> + dplyr::pull("url") |> + stringr::str_replace("^https://", "") + + # display a message + # NOTE: This message *must* have the following classes to enable them + # to be controlled programmatically. + # see ?packageStartupMessage (required by `check()`) + c( + glue::glue("galah version {galah_version}"), + "\n", # note: glue wipes newlines, so have to be outside + cli::col_magenta(glue::glue('This package is currently configured to query {current_node} ({current_url}).\n')), + "\n", + i = cli::col_magenta('- You can change this at any time using e.g. `galah_config(atlas = \"GBIF\")`.'), + "\n", + i = cli::col_magenta('- To see all supported organisations, run `show_all(atlases)`.') + ) |> + packageStartupMessage() } } diff --git a/R/parse_checks.R b/R/parse_checks.R deleted file mode 100644 index f2bcc024..00000000 --- a/R/parse_checks.R +++ /dev/null @@ -1,44 +0,0 @@ -#' Internal function to run metadata checks -#' This is useful for testing, particularly in testing `galah_select()` -#' called by `collapse()` -#' @noRd -#' @keywords Internal -parse_checks <- function(.query){ - # "data/" functions require pre-processing of metadata, - # as do `unnest()`/`show_values()` functions - if(grepl("^data/", .query$type) | - grepl("-unnest$", .query$type)){ - # some checks should happen regardless of `run_checks` - .query <- .query |> - check_identifiers() |> - check_select() - if(pour("package", "run_checks")) { - .query <- .query |> - check_login() |> - check_reason() |> - check_fields() |> - check_profiles() - } - if(.query$type == "data/distributions" & !is.null(.query[["metadata/distributions"]])){ - .query$url <- tibble(url = glue(utils::URLdecode(.query$url), - id = .query[["metadata/distributions"]]$id)) - } - .query <- remove_metadata(.query) - } - .query -} - -#' Internal function to reduce size of internally computed objects -#' called by `compute.query()` -#' @noRd -#' @keywords Internal -remove_metadata <- function(.query){ - names_lookup <- grepl("^metadata/", names(.query)) - if(any(names_lookup)){ - x <- .query[!names_lookup] - }else{ - x <- .query - } - class(x) <- "query" - x -} \ No newline at end of file diff --git a/R/parse_metadata.R b/R/parse_metadata.R deleted file mode 100644 index 5dca92f0..00000000 --- a/R/parse_metadata.R +++ /dev/null @@ -1,56 +0,0 @@ -#' Internal function to `compute()` lists -#' Required for pagination -#' Should run a query with `max = 0` to get total n -#' Then use `max` and `offset` to paginate up to `n` -#' @importFrom dplyr select -#' @noRd -#' @keywords Internal -parse_lists <- function(.query){ - url <- url_parse(.query$url) - n_requested <- as.integer(url$query$max) - # make decisions about how much pagination is needed - if(n_requested <= 500){ # we haven't hit pagination limit - .query - }else{ # more lists are requested - n <- get_max_n(.query) - n_pages <- ceiling(n$max_requested / n$paginate) - offsets <- (seq_len(n_pages) - 1) * n$paginate - result <- tibble( - offset = offsets, - max = c( - rep(n$paginate, n_pages - 1), - n$max_requested - offsets[n_pages])) - result$url <- lapply( - split(result, seq_len(nrow(result))), - function(a){ - url$query <- list(offset = a$offset, max = a$max) - url_build(url) - }) |> - unlist() - .query$url <- select(result, "url") - } - .query -} - -#' Internal function to retrieve max number of entries for an API -#' @noRd -#' @keywords Internal -get_max_n <- function(.query){ - url <- url_parse(.query$url) - if(is_gbif()){ - count_field <- "count" - }else{ - count_field <- "listCount" - } - n <- list(requested = as.integer(url$query$max), - paginate = 500, - max_available = { - url$query <- list(max = 0) - list(url = url_build(url), - headers = .query$headers) |> - query_API() |> - pluck(count_field) # NOTE: only tested for ALA - }) - n$max_requested <- min(c(n$requested, n$max_available)) - return(n) -} diff --git a/R/parse_metadata_unnest.R b/R/parse_metadata_unnest.R deleted file mode 100644 index db6a6780..00000000 --- a/R/parse_metadata_unnest.R +++ /dev/null @@ -1,71 +0,0 @@ -#' Internal function to call `compute` for `request_metadata(type = "profiles-unnest")` -#' @noRd -#' @keywords Internal -parse_profile_values <- function(.query){ - url <- .query |> - pluck("url") |> - url_parse() - profile_name <- extract_profile_name(url) - short_name <- profile_short_name(profile_name) - if (!pour("atlas", "region") == "Spain") { - path_name <- url |> - pluck("path") |> - dirname() - url$path <- glue("{path_name}/{short_name}") - } - result <- list(type = .query$type, - url = url_build(url)) - class(result) <- "query" - return(result) -} -# this doesn't print for some reason - -#' Internal function to convert between long and short names -#' for data profiles. Only used by `compute_profile_values()` -#' @noRd -#' @keywords Internal -profile_short_name <- function(profile) { - valid_profiles <- show_all_profiles() - short_name <- NA - if (suppressWarnings(!is.na(as.numeric(profile)))) { - # assume a profile id has been provided - short_name <- valid_profiles[match(as.numeric(profile), - valid_profiles$id),]$shortName - } else { - # try to match a short name or a long name - if (profile %in% valid_profiles$name) { - short_name <- valid_profiles[match(profile, - valid_profiles$name), ]$shortName - } else { - if (profile %in% valid_profiles$shortName) { - short_name <- profile - } - } - } - if (is.na(short_name)) { - bullets <- c( - "Unknown profile detected.", - i = "See a listing of valid data quality profiles with `show_all_profiles()`." - ) - abort(bullets, call = caller_env()) - }else{ - short_name - } -} - -#' Internal function to extract profile name from url -#' for data profiles. Only used by `compute_profile_values()` -#' @noRd -#' @keywords Internal -extract_profile_name <- function(url) { - atlas <- pour("atlas", "region") - if (atlas == "Spain") { - profile_name <- url |> - pluck("query", "profileName") - } else { - profile_name <- url |> - pluck("path") |> - basename() - } - return(profile_name) -} diff --git a/R/parse_query.R b/R/parse_query.R deleted file mode 100644 index 29c95046..00000000 --- a/R/parse_query.R +++ /dev/null @@ -1,16 +0,0 @@ -#' Internal function to parse a `query_set` into a single `query` -#' @param x a `query_set` -#' @noRd -#' @keywords Internal -parse_query <- function(x){ - switch(x$type, - "data/occurrences-count-groupby" = parse_occurrences_count(x), - "data/occurrences-count" = parse_occurrences_count(x), - "data/species-count" = parse_species_count(x), - # "-unnest" functions require some checks - "metadata/profiles-unnest" = parse_profile_values(x), # check this - # some "metadata/" functions require pagination under some circumstances - "metadata/lists" = parse_lists(x), # always paginates - x # remaining "metadata/" functions are passed as-is # fixme to make a new object type - ) -} \ No newline at end of file diff --git a/R/parse_species_count.R b/R/parse_species_count.R deleted file mode 100644 index 6b0f5b6c..00000000 --- a/R/parse_species_count.R +++ /dev/null @@ -1,74 +0,0 @@ -#' Internal function to compute for species counts -#' @importFrom tibble as_tibble -#' @noRd -#' @keywords Internal -parse_species_count <- function(.query){ - if(.query$expand){ - .query <- build_species_query_list(.query) - }else{ - .query$url <- as_tibble(data.frame(url = .query$url)) - } - .query -} - -#' Internal function to generate correct set of species-count queries when -#' `group_by()` is set -#' @importFrom dplyr bind_cols -#' @importFrom dplyr select -#' @importFrom httr2 url_build -#' @importFrom httr2 url_parse -#' @importFrom tibble tibble -#' @noRd -#' @keywords Internal -build_species_query_list <- function(.query){ - - # remove `species_facets()` from query - url <- url_parse(.query$url) - query_temp <- url$query - query_temp <- query_temp[-which( - unlist(query_temp) == species_facets() & - names(query_temp) == "facets")] - n_facet_terms <- length(which(names(query_temp) == "facets")) - url$query <- c(query_temp, list(pageSize = 0)) - - # rebuild a .query object for this query - data_temp <- .query - data_temp$type <- "data/occurrences-count" - data_temp$url <- url_build(url) - data_temp$expand <- ifelse(n_facet_terms > 1, TRUE, FALSE) - - # collect using `occurrences-count` code (to parse expand correctly) - df <- collect(data_temp) - - # create new set of fq args - fq_args <- lapply( - split(df, seq_len(nrow(df))), - function(a){ - x <- a[, - ncol(a)] - paste( - paste(names(x), x, sep = ":"), - collapse = " AND ") - }) |> unlist() - - # modify url to only have `species_facets()` in facets slot - url <- url_parse(.query$url) - query <- url$query - query <- query[-which( - unlist(query_temp) != species_facets() & - names(query_temp) == "facets")] - query$flimit <- 1 - url$query <- query - - # create new fq urls - new_fqs <- paste(url$query$fq, fq_args, sep = " AND ") - urls <- lapply(new_fqs, function(a, x){ - x$query$fq <- a - url_build(x) - }, x = url) |> unlist() - - # convert to a tibble to pass back to .query - .query$url <- bind_cols( - select(df, -count), - tibble(url = urls)) - return(.query) -} diff --git a/R/print.R b/R/print.R index fcb3a0d8..baeb48ec 100644 --- a/R/print.R +++ b/R/print.R @@ -62,21 +62,23 @@ print.metadata_request <- function(x, ...){ #' @noRd #' @keywords Internal format_request_text <- function(x, object_type){ - filled_slots <- !unlist(lapply(x, is.null)) - formatted_object <- galah_pink(glue("`{object_type}`")) + filled_slots <- !unlist(purrr::map(x, is.null)) if(any(filled_slots)){ - inform(glue("Object of type {formatted_object} containing:")) + cli::cli_text("Object of type {galah_pink(object_type)} containing:") x_names <- names(x)[filled_slots] - lapply(x_names, function(a){ - slot_name <- galah_green(a) - slot_content <- switch_slot_text(x, a) - glue("{slot_name} {galah_grey(slot_content)}") - }) |> - unlist() |> - format_error_bullets() |> - cat() + purrr::map(x_names, + function(a){ + slot_name <- galah_green(a) + if(a == "filter"){ + slot_content <- utils::capture.output(print(x[[a]])) # calls `print.data_filter()` etc. + }else{ + slot_content <- switch_slot_text(x, a) + } + glue::glue("{slot_name} {galah_grey(slot_content)}") + }) |> + cli::cli_li() }else{ - inform(glue("An empty object of type {formatted_object}")) + cli::cli_text("An empty object of type {galah_pink(object_type)}") } } @@ -92,47 +94,33 @@ switch_slot_text <- function(x, a){ first_entry <- x[[a]][[1]][1] n_entries <- nrow(x[[a]]) if(n_entries > 1){ - glue("{first_col}s: {first_entry} + {n_entries - 1} more") + glue::glue("{first_col}s: {first_entry} + {n_entries - 1} more") }else{ - glue("{first_col}: {first_entry}") + glue::glue("{first_col}: {first_entry}") } }, - "filter" = { - if(ncol(x[[a]]) > 2){ - df <- x[[a]][, 1:3] - }else{ - df <- x[[a]] - } - if(nrow(df) > 1){ - df <- df[1, ] - } - glue_collapse( - apply(df, 1, function(b){paste(b, collapse = " ")}), - sep = " | ") - }, "select" = x[[a]]$summary, - "group_by" = glue_collapse(x[[a]]$name, sep = " | "), - "data_profile" ={x[[a]][1]}, + "group_by" = glue::glue_collapse(x[[a]]$name, sep = " | "), + "apply_profile" ={x[[a]][1]}, "mint_doi" = {x[[a]][1]}, "") } #' @rdname print_galah_objects -#' @importFrom crayon silver #' @export print.query <- function(x, ...){ if(!is.null(x$arrange)){ - arrange <- galah_pale_green(glue("\n + arrange <- galah_pale_green(glue::glue("\n arrange: {x$arrange$variable} ({x$arrange$direction})")) if(x$arrange$slice_called == TRUE){ - slice <- galah_pale_green(glue("\n + slice <- galah_pale_green(glue::glue("\n slice: {x$arrange$slice_n}")) }else{ - slice <- "" + slice <- NULL } }else{ - arrange <-"" - slice <- "" + arrange <- NULL + slice <- NULL } if(!is.null(x$url)){ if(inherits(x$url, "data.frame")){ @@ -141,10 +129,10 @@ print.query <- function(x, ...){ url_temp <- paste0(substr(url_temp, 1, 70), "...") } if(nrow(x$url) > 1){ - url_text <- glue("\n + url_text <- glue::glue("\n url: {url_temp} + {nrow(x$url) - 1} more") }else{ - url_text <-glue("\n + url_text <- glue::glue("\n url: {url_temp}") } }else{ @@ -152,45 +140,62 @@ print.query <- function(x, ...){ if(nchar(url_temp) > 70){ url_temp <- paste0(substr(url_temp, 1, 70), "...") } - url_text <-glue("\n + url_text <- glue::glue("\n url: {url_temp}") } subtext <- galah_grey(url_text) }else if(!is.null(x$data)){ - subtext <- galah_grey(glue("\n + subtext <- galah_grey(glue::glue("\n data: {x$data[1]}")) }else if(!is.null(x$status)){ - subtext <- galah_grey(glue("\n + subtext <- galah_grey(glue::glue("\n status: {x$status[1]}")) }else{ - subtext <- "" + subtext <- NULL } - cat(c( - silver("Object of class"), - galah_pink("query"), - silver("with type"), - galah_green(x$type), - subtext, # note: need code for url tibbles - arrange, - slice)) + if(!is.null(x$select)){ + select <- galah_grey(glue::glue("\n + select: {x$select$summary}")) + }else{ + select <- NULL + } + + # keep only populated levels + print_list <- list(subtext, # note: need code for url tibbles + select, + arrange, + slice) + print_list <- print_list[!unlist(purrr::map(print_list, is.null))] + + # print + class_tr <- class(x)[1] + cli::cli_text("Object of class {galah_pink(class_tr)} with type {galah_green(x$type)}") + cli::cli_li(print_list) } +#' @rdname print_galah_objects +#' @export +print.prequery <- print.query + #' @rdname print_galah_objects #' @export print.computed_query <- function(x, ...){ + # calculate arrange/slice info if(!is.null(x$arrange)){ - arrange <- galah_pale_green(glue("\n + arrange <- galah_pale_green(glue::glue("\n arrange: {x$arrange$variable} ({x$arrange$direction})")) if(x$arrange$slice_called == TRUE){ - slice <- galah_pale_green(glue("\n + slice <- galah_pale_green(glue::glue("\n slice: {x$arrange$slice_n}")) }else{ - slice <- "" + slice <- NULL } }else{ - arrange <-"" - slice <- "" + arrange <- NULL + slice <- NULL } + + # add url if(!is.null(x$url)){ if(inherits(x$url, "data.frame")){ url_temp <- x$url$url[1] @@ -198,10 +203,10 @@ print.computed_query <- function(x, ...){ url_temp <- paste0(substr(url_temp, 1, 70), "...") } if(nrow(x$url) > 1){ - url_text <- glue("\n + url_text <- glue::glue("\n url: {url_temp} + {nrow(x$url) - 1} more") }else{ - url_text <-glue("\n + url_text <- glue::glue("\n url: {url_temp}") } }else{ @@ -209,40 +214,53 @@ print.computed_query <- function(x, ...){ if(nchar(url_temp) > 70){ url_temp <- paste0(substr(url_temp, 1, 70), "...") } - url_text <-glue("\n + url_text <- glue::glue("\n url: {url_temp}") } subtext <- galah_grey(url_text) }else if(!is.null(x$data)){ - subtext <- galah_grey(glue("\n + subtext <- galah_grey(glue::glue("\n data: {x$data[1]}")) }else if(!is.null(x$status)){ - subtext <- galah_grey(glue("\n + subtext <- galah_grey(glue::glue("\n status: {x$status[1]}")) }else{ - subtext <- "" + subtext <- NULL + } + + # add a status ID + if(!is.null(x$status_url)){ + split_url <- strsplit(x$status_url, "\\/")[[1]] + id <- galah_grey(glue::glue("\n + id: {split_url[[length(split_url)]]}")) + }else{ + id <- NULL } - cat(c( - silver("Object of class"), - galah_pink("computed_query"), - silver("with type"), - galah_green(x$type), - subtext, # note: need code for url tibbles - arrange, - slice)) + + # keep only populated levels + print_list <- list(id, + subtext, # note: need code for url tibbles + arrange, + slice) + print_list <- print_list[!unlist(purrr::map(print_list, is.null))] + + # print + cli::cli_text("Object of class {galah_pink(\"computed query\")} with type {galah_green(x$type)}") + cli::cli_li(print_list) } #' @rdname print_galah_objects #' @export print.query_set <- function(x, ...){ n_queries <- length(x) - message(c(silver("Object of class "), - galah_pink("`query_set` "), - silver(glue("containing ")), - ifelse(n_queries > 1, - silver(glue("{n_queries} queries:")), - silver("1 query:")))) - lapply(x, function(a){ + header_text <- c("Object of class ", + galah_pink("query_set "), + "containing ", + ifelse(n_queries > 1, + "{n_queries} queries:", + "1 query:")) + cli::cli_text(header_text) + purrr::map(x, function(a){ type_text <- galah_green(a$type) if(!is.null(a$url)){ url_temp <- a$url[1] @@ -250,51 +268,58 @@ print.query_set <- function(x, ...){ if(sum(c(pretext_length, nchar(url_temp))) > 80){ url_temp <- paste0(substr(url_temp, 1, (80 - pretext_length - 3)), "...") } - subtext <- galah_grey(glue("url: {url_temp}")) + subtext <- galah_grey(glue::glue("url: {url_temp}")) }else if(!is.null(a$data)){ - subtext <- galah_grey(glue("data: {a$data[1]}")) + subtext <- galah_grey(glue::glue("data: {a$data[1]}")) }else{ subtext <- "" } - glue("{type_text} {subtext}") + glue::glue("{type_text} {subtext}") }) |> - unlist() |> - format_error_bullets() |> - cat() + cli::cli_li() } #' @rdname print_galah_objects -#' @importFrom rlang format_error_bullets #' @export print.galah_config <- function(x, ...){ - inform(galah_pink("Package")) - package_settings <- galah_green(c("verbose", "run_checks", "send_email")) - package_lookup <- unlist(x$package[1:3]) |> as.integer() + 1 - names(package_settings) <- c("x", "v")[package_lookup] + cli::cli_par() + cli::cli_text("`galah` package configuration") + cli::cli_end() + cli::cli_par() + # print package settings + cli::cli_text("{galah_pink(\"Package\")}") + package_info <- purrr::pluck(x, "package") + package_logical_check <- purrr::map(package_info, is.logical) |> + unlist() + logical_values <- package_info[package_logical_check] |> + unlist() + package_settings <- names(logical_values) |> + galah_green() + names(package_settings) <- c("x", "v")[as.integer(logical_values) + 1] package_settings <- c(package_settings, - "i" = glue("{galah_green('directory')}: {galah_grey(x$package$directory)}")) |> - format_error_bullets() |> - cat() - cat("\n") - inform(galah_pink("User")) - values <- c( + "i" = glue::glue("{galah_green('directory')}: {galah_grey(x$package$directory)}")) |> + cli::cli_bullets() + cli::cli_end() + # print user settings + cli::cli_par() + cli::cli_text("{galah_pink(\"User\")}") + user_settings <- c( + "{galah_green('authentication')}", "{galah_green('username')} {galah_grey(hide_secrets(x$user$username))}", "{galah_green('email')} {galah_grey(x$user$email)}", "{galah_green('password')} {galah_grey(hide_secrets(x$user$password))}", - "{galah_green('api_key')} {galah_grey(hide_secrets(x$user$api_key))}", "{galah_green('download_reason_id')} {galah_grey(x$user$download_reason_id)}") - password_settings <- lapply(values, - function(a, x){glue_data(x, a)}, x = x) |> - unlist() |> - format_error_bullets() |> - cat() - cat("\n") - inform(galah_pink("Atlas")) + names(user_settings)[1] <- purrr::pluck(x, "user", "authenticate") |> + isTRUE() |> + ifelse("v", "x") + cli::cli_bullets(user_settings) + cli::cli_end() + cli::cli_par() + cli::cli_text("{galah_pink(\"Atlas\")}") atlas_text <- galah_green(x$atlas$organisation) - atlas_subtext <- galah_grey(glue("({x$atlas$acronym}), {x$atlas$region}")) - atlas_settings <- glue("{atlas_text} {atlas_subtext}") |> - format_error_bullets() |> - cat() + atlas_subtext <- galah_grey(glue::glue("({x$atlas$acronym}), {x$atlas$region}")) + cli::cli_bullets("{atlas_text} {atlas_subtext}") + cli::cli_end() } #' Internal function to prevent showing secret information in the console @@ -309,25 +334,23 @@ hide_secrets <- function(string){ } #' Pink for printing primary text (e.g. object names) to the console +#' Note: `@importFrom` here added to avoid CRAN checks flagging crayon as not required #' @importFrom crayon make_style #' @noRd #' @keywords Internal -galah_pink <- make_style("#bf2a6d") +galah_pink <- crayon::make_style("#bf2a6d") #' Green for printing secondary text (e.g. object types) to the console -#' @importFrom crayon make_style #' @noRd #' @keywords Internal -galah_green <- make_style("#176666") +galah_green <- crayon::make_style("#176666") #' Green for printing non-emphasized text to the console -#' @importFrom crayon make_style #' @noRd #' @keywords Internal -galah_pale_green <- make_style("#60a3a3") +galah_pale_green <- crayon::make_style("#60a3a3") #' Grey for printing non-emphasized text (e.g. urls) to the console -#' @importFrom crayon make_style #' @noRd #' @keywords Internal -galah_grey <- make_style("#8c8c8c") +galah_grey <- crayon::make_style("#8c8c8c") diff --git a/R/query_API.R b/R/query_API.R index 2802470c..c15ac0e3 100644 --- a/R/query_API.R +++ b/R/query_API.R @@ -3,23 +3,15 @@ #' Note that this is a wrapper to `query_API_internal()` to handle single or #' multiple urls. Multiple urls *must* be given as a tibble, which *must* have a #' column named `url`. -#' @importFrom dplyr bind_cols -#' @importFrom dplyr bind_rows -#' @importFrom dplyr select -#' @importFrom dplyr slice -#' @importFrom purrr map #' @noRd #' @keywords Internal -query_API <- function(.query, error_call = caller_env()) { +query_API <- function(.query, + error_call = rlang::caller_env()) { + # first try situation when many urls are supplied + # this is common for living atlases, where many urls are generated for + # e.g. paginated queries, grouped counts etc if(inherits(.query$url, "data.frame")){ - verbose <- pour("package", "verbose", .pkg = "galah") & nrow(.query$url) > 1 - if(verbose){ - progress_bar <- list(name = "Querying API", - clear = TRUE) - }else{ - progress_bar <- FALSE - } - map(.x = seq_len(nrow(.query$url)), + purrr::map(.x = seq_len(nrow(.query$url)), .f = function(a){ data_tr <- .query data_tr$url <- .query$url$url[[a]] @@ -27,58 +19,101 @@ query_API <- function(.query, error_call = caller_env()) { data_tr$download <- TRUE data_tr$file <- .query$url$path[[a]] } - query_API_internal(data_tr) + query_API_internal(data_tr, + error_call = error_call) }, - .progress = progress_bar) + .progress = set_progress_bar_behaviour(nrow(.query$url) > 1) + ) + # next handle multiple `body` arguments + # this is currently limited to GBIF count requests with > 1 `group_by` args + }else if(inherits(.query$body, "data.frame")){ + purrr::map(.x = split(.query$body, + seq_len(nrow(.query$body))), + .f = function(a){ + data_tr <- .query + data_tr$body <- a$predicate[[1]] + a$result <- list(query_API_internal(data_tr, + error_call = error_call)) + a + }, + .progress = set_progress_bar_behaviour(nrow(.query$url) > 1) + ) |> + dplyr::bind_rows() + # finally, some queries are 'simple'; one `url`, one or no `body` args + # these we just run without any looping. }else{ - query_API_internal(.query) + query_API_internal(.query, + error_call = error_call) } } #' Internal function to run an API call using httr2 +#' @param criteria length-1 logical statement as to whether to proceed or not #' @noRd #' @keywords Internal -#' @importFrom dplyr bind_rows -#' @importFrom httr2 request -#' @importFrom httr2 req_error -#' @importFrom httr2 req_headers -#' @importFrom httr2 req_perform -#' @importFrom httr2 req_timeout -#' @importFrom httr2 resp_body_json -#' @importFrom httr2 resp_body_string -#' @importFrom purrr pluck -#' @importFrom rlang abort -#' @importFrom rlang inform -query_API_internal <- function(.query, error_call = caller_env()) { - query <- request(.query$url) |> +set_progress_bar_behaviour <- function(criteria){ + verbose <- all( + potions::pour("package", "verbose", .pkg = "galah") & + isTRUE(criteria)) + if(verbose){ + list(name = "Querying API", + clear = TRUE) + }else{ + FALSE + } +} + +#' Internal function to run an API call using httr2 +#' @noRd +#' @keywords Internal +query_API_internal <- function(.query, + error_call = rlang::caller_env()) { + query <- httr2::request(.query$url) |> add_headers(.query$headers) |> add_options(.query$options) |> # used by GBIF add_body(.query$body) # NOTE: adding `body` converts from GET to POST - # handle downloads first + + # set authentication behaviour + if(!is.null(.query$request$authenticate) & + .query$type != "metadata/config" # necessary to prevent circular problems + ){ + + # check whether config data is available + auth_info <- get_auth_info() + query <- query |> + httr2::req_oauth_auth_code( + client = auth_info$client, + auth_url = dplyr::pull(auth_info$config, "authorize_url"), + scope = dplyr::pull(auth_info$config, "scopes"), + pkce = TRUE, + cache_disk = FALSE) # purrr::pluck(.query, "authenticate", "cache_disk")) + } + + # then handle downloads if(!is.null(.query$download)){ check_directory(.query$file) # handle thumbnails (which might fail if missing) - if (any(str_detect(.query$url, "thumbnail"))) { + if(any(stringr::str_detect(.query$url, "thumbnail"))) { query |> - req_error(is_error = \(resp) FALSE) |> - req_perform(path = .query$file, - verbosity = 0) + httr2::req_error(is_error = \(resp) FALSE) |> + httr2::req_perform(path = .query$file, + verbosity = 0) } else { query |> - req_perform(path = .query$file, - verbosity = 0) + httr2::req_perform(path = .query$file, + verbosity = 0) } # then other pings, which should resolve quickly # and can be allowed to fail otherwise }else{ res <- query |> - req_timeout(seconds = 20) |> - req_perform(verbosity = 0) + httr2::req_timeout(seconds = 20) |> + httr2::req_perform(verbosity = 0) if(grepl("^https://api.gbif.org/v1/occurrence/download/request", .query$url)){ - resp_body_string(res) + httr2::resp_body_string(res) }else{ - resp_body_json(res) # may not work for invalid URLs + httr2::resp_body_json(res) # may not work for invalid URLs } } } @@ -86,7 +121,6 @@ query_API_internal <- function(.query, error_call = caller_env()) { #' If supplied, add `headers` arg to a `request()` #' @noRd #' @keywords Internal -#' @importFrom potions pour add_headers <- function(req, headers){ if(!is.null(headers)){ req$headers <- headers @@ -99,10 +133,9 @@ add_headers <- function(req, headers){ #' If supplied, add `body` arg to a `request()` #' @noRd #' @keywords Internal -#' @importFrom httr2 req_body_raw add_body <- function(req, body){ if(!is.null(body)){ - req <- req |> req_body_raw(body) + req <- req |> httr2::req_body_raw(body) # note: this is not `req_body_json()` because # we have already converted our list to json text # by this point @@ -119,3 +152,35 @@ add_options <- function(req, options){ } req } + +#' get a client, and if it doesn't exist, make one +#' @noRd +#' @keywords Internal +get_auth_info <- function(error_call = rlang::caller_env()){ + x <- retrieve_cache("client") # this is cached by build_auth_client() + auth_config <- show_all_config() # handle download /retrieval of config info + if(is.null(x)){ + x <- build_auth_client(auth_config) + } + # if still can't get a client, you might be offline + if(is.null(x)){ + cli::cli_abort(c("Unable to generate an authentication client", + i = "You might be offline"), + call = error_call) + } + list(config = auth_config, + client = x) +} + +#' create a client object +#' @noRd +#' @keywords Internal +build_auth_client <- function(config){ + result <- httr2::oauth_client( + id = dplyr::pull(config, "client_id"), + token_url = dplyr::pull(config, "token_url"), + auth = "body", + name = "galah") + update_cache(client = result) + result +} \ No newline at end of file diff --git a/R/read_zip.R b/R/read_zip.R index e338234b..d9d09fd3 100644 --- a/R/read_zip.R +++ b/R/read_zip.R @@ -1,8 +1,6 @@ #' Read downloaded data from a zip file #' #' @description -#' `r lifecycle::badge("experimental")` -#' #' Living atlases supply data downloads as zip files. This function reads these #' data efficiently, i.e. without unzipping them first, using the `readr` #' package. Although this function has been part of galah for some time, it was @@ -29,16 +27,16 @@ read_zip <- function(file){ # basic checks if(missing(file)){ - rlang::abort("`file` is missing, with no default") + cli::cli_abort("`file` is missing, with no default") } if(!is.character(file) | length(file) > 1){ - rlang::abort("Argument `file` should be a length-1 character") + cli::cli_abort("Argument `file` should be a length-1 character") } if(!file.exists(file)){ - rlang::abort("`.zip` file not found") + cli::cli_abort("`.zip` file not found") } if(!grepl(".zip$", file)){ - rlang::abort("`file` should end in `.zip`") + cli::cli_abort("`file` should end in `.zip`") } # get names of files stored in .zip all_files <- utils::unzip(file, list = TRUE)$Name @@ -52,20 +50,24 @@ read_zip <- function(file){ suppressWarnings() # Note: DOIs for GBIF are stored in `compute()` stage, not in the zip file }else{ - available_files <- all_files[grepl(".csv$", all_files) & - grepl("^data|records", all_files)] - result <- lapply(available_files, - function(a, x){ - # create connection to a specific file within zip - conn <- unz(description = x, - filename = a, - open = "rb") - out <- readr::read_csv(conn, - col_types = readr::cols()) |> - suppressWarnings() - close(conn) - return(out) - }, x = file) |> + available_files <- all_files[stringr::str_detect(all_files, ".csv$") & + !(all_files %in% c("citation.csv", "headings.csv"))] + # grepl("^data|records", all_files)] + # typically files start with data or records, + # but downloads sometimes have the name of the zip file as the csv file + + result <- purrr::map(available_files, + function(a, x){ + # create connection to a specific file within zip + conn <- unz(description = x, + filename = a, + open = "rb") + out <- readr::read_csv(conn, + col_types = readr::cols()) |> + suppressWarnings() + close(conn) + return(out) + }, x = file) |> dplyr::bind_rows() # # add doi when mint_doi = TRUE if(any(all_files == "doi.txt")){ @@ -89,7 +91,7 @@ read_zip <- function(file){ cite_check <- grepl("cite", names(readme)) if(any(cite_check)){ attr(result, "citation") <- readme[cite_check] |> - glue_collapse(sep = "") + glue::glue_collapse(sep = "") } } } @@ -99,7 +101,7 @@ read_zip <- function(file){ trimws() # exit safely if(is.null(result)){ - rlang::abort("No data loaded") + cli::cli_abort("No data loaded") }else{ result } diff --git a/R/reexports.R b/R/reexports.R index 69868a4c..9ee74e9c 100644 --- a/R/reexports.R +++ b/R/reexports.R @@ -1,3 +1,7 @@ +#' @importFrom dplyr add_count +#' @export +dplyr::add_count + #' @importFrom dplyr arrange #' @export dplyr::arrange @@ -14,33 +18,37 @@ dplyr::compute #' @export dplyr::collapse -#' @importFrom graphics identify +#' @importFrom dplyr count #' @export -graphics::identify +dplyr::count + +#' @importFrom dplyr distinct +#' @export +dplyr::distinct #' @importFrom dplyr filter #' @export dplyr::filter -#' @importFrom dplyr select +#' @importFrom dplyr glimpse #' @export -dplyr::select +dplyr::glimpse #' @importFrom dplyr group_by #' @export dplyr::group_by +#' @importFrom dplyr select +#' @export +dplyr::select + #' @importFrom dplyr slice_head #' @export dplyr::slice_head -# @importFrom dplyr slice_tail -# @export -# dplyr::slice_tail - -#' @importFrom dplyr count +#' @importFrom graphics identify #' @export -dplyr::count +graphics::identify #' @importFrom sf st_crop #' @export diff --git a/R/search_all.R b/R/search_all.R index 1cc5c203..1af3beb9 100644 --- a/R/search_all.R +++ b/R/search_all.R @@ -10,9 +10,9 @@ #' search term within the valid options for the information specified by the #' suffix. #' -#' **For more information about taxonomic searches using `search_taxa()`, see `?taxonomic_searches`**. +#' **For more information about taxonomic searches using `search_taxa()`, see** +#' \code{\link[=taxonomic_searches]{?taxonomic_searches}}. #' -#' `r lifecycle::badge("stable")` #' `search_all()` is a helper function that can do searches for multiple #' types of information, acting as a wrapper around many `search_` sub-functions. #' See `Details` (below) for accepted values. @@ -20,9 +20,12 @@ #' @param type A string to specify what type of parameters should be searched. #' @param query A string specifying a search term. Searches are not #' case-sensitive. -#' @param ... A set of strings or a tibble to be queried; see -#' Details. -#' @details There are five categories of information, each with their own +#' @param all_fields `r lifecycle::badge("experimental")` If `TRUE`, +#' `show_values()` also returns all columns available from the API, rather +#' than the 'default' columns traditionally provided via galah. +#' @param ... One or more objects accepted by the taxonomic lookup services. See +#' [taxonomic_searches] for details +#' @details There are six categories of information, each with their own #' specific sub-functions to look-up each type of information. #' The available types of information for `search_all()` are: #' @@ -43,6 +46,7 @@ #' |data providers|`providers`| Search for which institutions have provided data | `search_providers()`| #' | |`collections`|Search for the specific collections within those institutions| `search_collections()`| #' | |`datasets`|Search for the data groupings within those collections| `search_datasets()`| +#' |media|`media`|Search for images or sounds using a vector of IDs|`search_media()`| #' #' #' @aliases search_all @@ -86,10 +90,10 @@ #' collect() |> #' dplyr::filter(grepl("date", id)) #' } -#' @importFrom rlang as_name -#' @importFrom rlang .data #' @export -search_all <- function(type, query){ +search_all <- function(type, + query, + all_fields = FALSE){ # vector of valid types for this function valid_types <- c( @@ -99,9 +103,10 @@ search_all <- function(type, query){ "collections", "datasets", "fields", + "identifiers", "licences", "lists", - "identifiers", + "media", "profiles", "providers", "reasons", @@ -112,52 +117,79 @@ search_all <- function(type, query){ if(missing(type)){ type <- "fields" }else{ - type <- parse_quosures_basic(enquos(type)) + type <- rlang::enquos(type) |> + parse_quosures_basic() if(!inherits(type, "character") | length(type) > 1){ - abort("`type` must be a length-1 vector of class 'character'") + cli::cli_abort("`type` must be a length-1 vector of class 'character'") } check_type_valid(type, valid_types) } check_if_missing(query) + run_subsequent_query <- FALSE if(type == "taxa"){ check_if_in_pipe(query) - request_metadata(type = "taxa") |> - identify(query[[1]]) |> - collect() + request <- request_metadata(type = "taxa") |> + identify(query) }else if(type == "identifiers"){ - request_metadata() |> - filter("identifier" == query) |> - collect() + request <- request_metadata() |> + filter("identifier" == query) + }else if(type == "media"){ + request <- request_metadata() |> + filter("media" == query) }else{ if(is_gbif() & type %in% c("collections", "datasets", "providers")){ # these support `q` arg in API - request_metadata() |> - filter({{type}} == query) |> - collect() + request <- request_metadata() |> + filter({{type}} == query) }else{ - request_metadata(type = type) |> - collect() |> - search_text_cols(query = query) + request <- request_metadata(type = type) + run_subsequent_query <- TRUE } } + + # add all_fields if requested + if(isTRUE(all_fields)){ + request <- request |> + dplyr::select(tidyselect::everything()) + } + + # collect the supplied `request` + result <- collect(request) + + # add search, or not, depending on behaviour + if(isTRUE(run_subsequent_query) & nrow(result) > 0){ + search_text_cols(result, query) + }else{ + result + } } #' Internal function to run a query over a tibble -#' @importFrom dplyr filter -#' @importFrom purrr list_transpose #' @noRd #' @keywords Internal search_text_cols <- function(df, query){ + if(nrow(df) < 1){ + return(df) + } + query <- tolower(query) - keep_cols <- unlist(lapply(df, is.character)) & + keep_cols <- unlist(purrr::map(df, is.character)) & colnames(df) != "type" - check_list <- lapply(df[, keep_cols], - function(a){grepl(query, tolower(a))}) - check_vector <- lapply(list_transpose(check_list), any) |> unlist() - result <- df |> filter({{check_vector}}) + + check_list <- purrr::map(df[, keep_cols], + \(a){stringr::str_detect(tolower(a), query)}) + + if(length(check_list) < 1){ + return(df) + } + + check_vector <- purrr::list_transpose(check_list) |> + purrr::map(any) |> + unlist() + result <- df |> dplyr::filter({{check_vector}}) # order search_all() results if ("id" %in% colnames(result)) { @@ -172,16 +204,14 @@ search_text_cols <- function(df, query){ #' Internal function to check for missingness #' @noRd #' @keywords Internal -#' @importFrom rlang abort check_if_missing <- function(query, parent_function, - error_call = caller_env()) { + error_call = rlang::caller_env()) { if (missing(query)) { - bullets <- c( + c( "We didn't detect a search query.", - i = "Try entering a string to search for matching values." - ) - abort(bullets, call = error_call) + i = "Try entering a string to search for matching values.") |> + cli::cli_abort(call = error_call) } } @@ -189,70 +219,129 @@ check_if_missing <- function(query, #' `galah_call()` instead of `galah_identify()` #' @noRd #' @keywords Internal -check_if_in_pipe <- function(..., error_call = caller_env()) { +check_if_in_pipe <- function(..., + error_call = rlang::caller_env()){ dots <- list(...) col_type_present <- grepl("type", names(unlist(dots))) - if (any(col_type_present)) { - bullets <- c( - "Can't pipe `search_taxa()` in a `galah_call()`.", - i = "Did you mean to use `galah_identify()`?" - ) - abort(bullets, call = error_call) + if(any(col_type_present)){ + c("Can't pipe `search_taxa()` in a `galah_call()`.", + i = "Did you mean to use `galah_identify()`?") |> + cli::cli_abort(call = error_call) } } #' @rdname search_all #' @export -search_assertions <- function(query){search_all("assertions", query)} +search_assertions <- function(query, + all_fields = FALSE){ + search_all("assertions", query, all_fields) +} + +#' @rdname search_all +#' @export +search_apis <- function(query, + all_fields = FALSE){ + search_all("apis", query, all_fields) +} #' @rdname search_all #' @export -search_apis <- function(query){search_all("apis", query)} +search_atlases <- function(query, + all_fields = FALSE){ + search_all("atlases", query, all_fields) +} #' @rdname search_all #' @export -search_atlases <- function(query){search_all("atlases", query)} +search_collections <- function(query, + all_fields = FALSE){ + search_all("collections", query, all_fields) +} #' @rdname search_all #' @export -search_collections <- function(query){search_all("collections", query)} +search_datasets <- function(query, + all_fields = FALSE){ + search_all("datasets", query, all_fields) +} #' @rdname search_all #' @export -search_datasets <- function(query){search_all("datasets", query)} +search_fields <- function(query, + all_fields = FALSE){ + search_all("fields", query, all_fields) +} #' @rdname search_all #' @export -search_fields <- function(query){search_all("fields", query)} +search_identifiers <- function(..., + all_fields = FALSE){ + search_all("identifiers", + unlist(list(...)), + all_fields = all_fields) +} #' @rdname search_all #' @export -search_identifiers <- function(...){search_all("identifiers", unlist(list(...)))} +search_licences <- function(query, + all_fields = FALSE){ + search_all("licences", query, all_fields) +} #' @rdname search_all #' @export -search_licences <- function(query){search_all("licences", query)} +search_lists <- function(query, + all_fields = FALSE){ + search_all("lists", query, all_fields) +} #' @rdname search_all #' @export -search_lists <- function(query){search_all("lists", query)} +search_media <- function(query, + all_fields = FALSE){ + search_all("media", query, all_fields) +} #' @rdname search_all #' @export -search_profiles <- function(query){search_all("profiles", query)} +search_profiles <- function(query, + all_fields = FALSE){ + search_all("profiles", query, all_fields) +} #' @rdname search_all #' @export -search_providers <- function(query){search_all("providers", query)} +search_providers <- function(query, + all_fields = FALSE){ + search_all("providers", query, all_fields) +} #' @rdname search_all #' @export -search_ranks <- function(query){search_all("ranks", query)} +search_ranks <- function(query, + all_fields = FALSE){ + search_all("ranks", query, all_fields) +} #' @rdname search_all #' @export -search_reasons <- function(query){search_all("reasons", query)} +search_reasons <- function(query, + all_fields = FALSE){ + search_all("reasons", query, all_fields) +} #' @rdname search_all #' @export -search_taxa <- function(...){search_all("taxa", list(...))} \ No newline at end of file +search_taxa <- function(..., + all_fields = FALSE){ + dots <- list(...) + if(length(dots) == 1L){ + if(inherits(dots[[1]], "data.frame")){ + search_all("taxa", dots[[1]], all_fields) + }else{ + search_all("taxa", dots, all_fields) + } + }else{ + search_all("taxa", dots, all_fields) + } +} \ No newline at end of file diff --git a/R/show_all.R b/R/show_all.R index 8cc1e4a8..788704e6 100644 --- a/R/show_all.R +++ b/R/show_all.R @@ -9,12 +9,14 @@ #' Functions prefixed with `show_all_` do this, displaying all valid options #' for the information specified by the suffix. #' -#' `r lifecycle::badge("stable")` #' `show_all()` is a helper function that can display multiple types of #' information from `show_all_` sub-functions. #' @param ... String showing what type of information is to be requested. See #' `Details` (below) for accepted values. #' @param limit Optional number of values to return. Defaults to NULL, i.e. all records +#' @param all_fields `r lifecycle::badge("experimental")` If `TRUE`, +#' `show_values()` also returns all columns available from the API, rather +#' than the 'default' columns traditionally provided via galah. #' @details There are five categories of information, each with their own #' specific sub-functions to look-up each type of information. #' The available types of information for `show_all_` are: @@ -23,6 +25,7 @@ #' |---|---|---|---| #' | Configuration |`atlases`| Show what atlases are available | `show_all_atlases()` | #' | |`apis`| Show what APIs & functions are available for each atlas | `show_all_apis()` | +#' | |`config`| Show information necessary for authentication | `show_all_config()`| #' | |`reasons`| Show what values are acceptable as 'download reasons' for a specified atlas | `show_all_reasons()` | #' | Data providers|`providers`| Show which institutions have provided data | `show_all_providers()` | #' | |`collections`|Show the specific collections within those institutions| `show_all_collections()` | @@ -58,36 +61,50 @@ #' # `show_all()` is synonymous with `request_metadata() |> collect()` #' request_metadata(type = "fields") |> #' collect() +#' +#' # using `all_fields = TRUE` is synonymous with `select(everything())` +#' request_metadata(type = "fields") |> +#' select(everything()) |> +#' collect() #' } -#' @importFrom rlang as_label #' @export -show_all <- function(..., limit = NULL){ - dots <- enquos(..., .ignore_empty = "all") +show_all <- function(..., + limit = NULL, + all_fields = FALSE){ + dots <- rlang::enquos(..., .ignore_empty = "all") if(length(dots) < 1){ type_text <- "fields" }else{ - type_text <- gsub("\"", "", as_label(dots[[1]])) # handle case where type is quoted + type_text <- gsub("\"", + "", + rlang::as_label(dots[[1]])) # handle case where type is quoted } - show_all_generic(type = type_text, limit = limit) + show_all_generic(type = type_text, + limit = limit, + all_fields = all_fields) } #' Internal function to handle `show_all` calls #' This is needed to handle slight differences between syntax of #' `show_all()` and `collect()` -#' @importFrom dplyr slice_head #' @noRd #' @keywords Internal -show_all_generic <- function(type, limit){ +show_all_generic <- function(type, + limit, + all_fields){ x <- request_metadata(type = type) if(!is.null(limit)){ - x <- x |> slice_head(n = limit) + x <- x |> dplyr::slice_head(n = limit) + } + if(isTRUE(all_fields)){ + x <- x |> dplyr::select(tidyselect::everything()) } result <- collect(x) # `show_all()` always returns requested number of records # this differs from `collect()` which always returns what the API gives you if(!is.null(limit)){ if(nrow(result) > limit){ - result <- slice_head(result, n = limit) + result <- dplyr::slice_head(result, n = limit) } } result @@ -95,79 +112,126 @@ show_all_generic <- function(type, limit){ #' @rdname show_all #' @export -show_all_apis <- function(limit = NULL){ - show_all_generic(type = "apis", limit = limit) +show_all_apis <- function(limit = NULL, + all_fields = FALSE){ + show_all_generic(type = "apis", + limit = limit, + all_fields = all_fields) +} + +#' @rdname show_all +#' @export +show_all_assertions <- function(limit = NULL, + all_fields = FALSE){ + show_all_generic(type = "assertions", + limit = limit, + all_fields = all_fields) } #' @rdname show_all #' @export -show_all_assertions <- function(limit = NULL){ - show_all_generic(type = "assertions", limit = limit) +show_all_atlases <- function(limit = NULL, + all_fields = FALSE){ + show_all_generic(type = "atlases", + limit = limit, + all_fields = all_fields) } #' @rdname show_all #' @export -show_all_atlases <- function(limit = NULL) { - show_all_generic(type = "atlases", limit = limit) +show_all_collections <- function(limit = NULL, + all_fields = FALSE){ + show_all_generic(type = "collections", + limit = limit, + all_fields = all_fields) } #' @rdname show_all #' @export -show_all_collections <- function(limit = NULL){ - show_all_generic(type = "collections", limit = limit) +show_all_config <- function(){ + show_all_generic(type = "config", + limit = NULL, + all_fields = TRUE) } #' @rdname show_all #' @export -show_all_datasets <- function(limit = NULL){ - show_all_generic(type = "datasets", limit = limit) +show_all_datasets <- function(limit = NULL, + all_fields = FALSE){ + show_all_generic(type = "datasets", + limit = limit, + all_fields = all_fields) } #' @rdname show_all #' @noRd #' @keywords Internal -show_all_distributions <- function(limit = NULL){ - show_all_generic(type = "distributions", limit = limit) +show_all_distributions <- function(limit = NULL, + all_fields = FALSE){ + show_all_generic(type = "distributions", + limit = limit, + all_fields = all_fields) } #' @rdname show_all #' @export -show_all_fields <- function(limit = NULL){ - show_all_generic(type = "fields", limit = limit) +show_all_fields <- function(limit = NULL, + all_fields = FALSE){ + show_all_generic(type = "fields", + limit = limit, + all_fields = all_fields) } #' @rdname show_all #' @export -show_all_licences <- function(limit = NULL){ - show_all_generic(type = "licences", limit = limit) +show_all_licences <- function(limit = NULL, + all_fields = FALSE){ + show_all_generic(type = "licences", + limit = limit, + all_fields = all_fields) } #' @rdname show_all #' @export -show_all_lists <- function(limit = NULL){ - show_all_generic(type = "lists", limit = limit) +show_all_lists <- function(limit = NULL, + all_fields = FALSE){ + show_all_generic(type = "lists", + limit = limit, + all_fields = all_fields) } #' @rdname show_all #' @export -show_all_profiles <- function(limit = NULL) { - show_all_generic(type = "profiles", limit = limit) +show_all_profiles <- function(limit = NULL, + all_fields = FALSE){ + show_all_generic(type = "profiles", + limit = limit, + all_fields = all_fields) } #' @rdname show_all #' @export -show_all_providers <- function(limit = NULL){ - show_all_generic(type = "providers", limit = limit) +show_all_providers <- function(limit = NULL, + all_fields = FALSE){ + show_all_generic(type = "providers", + limit = limit, + all_fields = all_fields) } #' @rdname show_all #' @export -show_all_ranks <- function(limit = NULL) { - show_all_generic(type = "ranks", limit = limit) +show_all_ranks <- function(limit = NULL, + all_fields = FALSE){ + show_all_generic(type = "ranks", + limit = limit, + all_fields = all_fields) } #' @rdname show_all #' @export -show_all_reasons <- function(limit = NULL){ - show_all_generic(type = "reasons", limit = limit) +show_all_reasons <- function(limit = NULL, + all_fields = FALSE){ + show_all_generic(type = "reasons", + limit = limit, + all_fields = all_fields) } \ No newline at end of file diff --git a/R/show_values.R b/R/show_values.R index 92cdac96..cbbbcb70 100644 --- a/R/show_values.R +++ b/R/show_values.R @@ -12,7 +12,7 @@ #' * The `field` "year" contains values 2021, 2020, 2019, etc. #' * The `field` "stateProvince" contains values New South Wales, Victoria, Queensland, etc. #' These are used to narrow queries with -#' \code{\link[=filter.data_request]{filter()}} or [galah_filter()]. +#' \code{\link[=filter.data_request]{filter()}}. #' #' Each **Profile** consists of many individual quality filters. #' For example, the "ALA" profile consists of values: @@ -29,17 +29,18 @@ #' @param df A search result from [search_fields()], [search_profiles()] or #' [search_lists()]. #' @param all_fields `r lifecycle::badge("experimental")` If `TRUE`, -#' `show_values()` also returns all raw data columns -#' (columns included prior to the dataset's ingestion into the ALA). -#' For many lists, this will include raw scientific names and vernacular -#' names. -#' For conservation lists like the EPBC list, this also includes columns -#' containing each species' conservation status information. -#' Default is set to `FALSE`. -#' Currently only implemented for metadata type `lists`. +#' `show_values()` also returns all columns available from the API, rather +#' than the 'default' columns traditionally provided via galah. +#' +#' For lists, this will include 'raw' columns; columns included prior to the +#' dataset's ingestion into the ALA, and will often include raw scientific +#' names and vernacular names. For conservation lists like the EPBC list, this +#' also includes columns containing each species' conservation status +#' information. +#' +#' For other forms of metadata, setting this to `TRUE` may return more +#' information than you want or need. Default is set to `FALSE`. #' @return A `tibble` of values for a specified field, profile or list. -#' @importFrom tibble tibble -#' @importFrom cli col_yellow #' @examples \dontrun{ #' # Show values in field 'cl22' #' search_fields("cl22") |> @@ -70,46 +71,43 @@ show_values <- function(df, match_column <- switch(type, "fields" = "id", "lists" = "species_list_uid", - "profiles" = "shortName", + "profiles" = "short_name", "taxa" = "taxon_concept_id", "uid" # last option selected if above are exhausted ) match_name <- df[[match_column]][1] - - # add_fields for lists only - if(isTRUE(all_fields) && type != "lists") { - cli::cli_warn("`all_fields` only applies to type `lists`. Ignoring `all_fields = TRUE`.") - all_fields <- FALSE - } - + # specify the number matched fields # specify for which field the values are displayed if(nrow(df) > 1) { n_matches <- nrow(df) df <- df[1, ] - inform( - bullets <- c( - "!" = glue("Search returned {n_matches} matched {type}."), - "*" = glue("Showing values for '{match_name}'.") - )) + c("!" = "Search returned {n_matches} matched {type}.", + "*" = "Showing values for '{match_name}'.") |> + cli::cli_bullets() } else { if (is.na(match_name)) { - inform(cli::col_yellow(glue("`search_all()` returned no matched `{type}`."))) - tibble() + cli::col_yellow("`search_all()` returned no matched `{type}`.") |> + cli::cli_text() + tibble::tibble() } else { - inform( - bullets <- c( - # glue("Search returned 1 matched {type}."), - "*" = glue("Showing values for '{match_name}'.") - ) - ) + c("*" = "Showing values for '{match_name}'.") |> + cli::cli_bullets() } } - request_metadata() |> - filter({{type}} == {{match_name}}) |> - unnest() |> - `attr<-`("all_fields", all_fields) |> - collect() + + if(isTRUE(all_fields)){ + request_metadata() |> + filter({{type}} == {{match_name}}) |> + select(tidyselect::everything()) |> + unnest() |> + collect() + }else{ + request_metadata() |> + filter({{type}} == {{match_name}}) |> + unnest() |> + collect() + } } #' @param query A string specifying a search term. Not case sensitive. @@ -127,35 +125,30 @@ search_values <- function(df, query) { #' Internal function to check inputs to `show_values()` & `search_values()` #' @noRd #' @keywords Internal -check_values_input <- function(df, error_call = caller_env()) { +check_values_input <- function(df, + error_call = rlang::caller_env()) { # Check if missing input if(missing(df) || is.null(df)) { - bullets <- c( - "Missing information for values lookup.", + c("Missing information for values lookup.", i = "Field, profile or list must be provided as a tibble created by `search_all()`.", - i = "e.g. `search_all(fields, \"year\") |> show_values()`." - ) - abort(bullets, call = error_call) + i = "e.g. `search_all(fields, \"year\") |> show_values()`.") |> + cli::cli_abort(call = error_call) } # Check that original data.frame is from a `show_all` or `search_all` if(is.null(attr(df, "call"))) { - bullets <- c( - "Wrong input provided.", + c("Wrong input provided.", i = "Must supply a tibble created by `search_all()` or `show_all()`.", - i = "e.g. `search_all(fields, \"year\") |> show_values()`." - ) - abort(bullets, call = error_call) + i = "e.g. `search_all(fields, \"year\") |> show_values()`.") |> + cli::cli_abort(call = error_call) } # Input must be from valid `show_all` or `search_all` tibble valid_calls <- c("fields", "lists", "profiles", "taxa") if(!any(valid_calls == attr(df, "call"))){ type <- attr(df, "call") - bullets <- c( - glue("Can't lookup values for metadata type `{type}`."), - x = "Values lookup accepts `fields`, `lists`, `profiles` or `taxa`." - ) - abort(bullets, call = error_call) + c("Can't lookup values for metadata type `{type}`.", + x = "Values lookup accepts `fields`, `lists`, `profiles` or `taxa`.") |> + cli::cli_abort(call = error_call) } } \ No newline at end of file diff --git a/R/sysdata.rda b/R/sysdata.rda index a50a7612..1a7ab2f9 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/R/taxonomic-searches.R b/R/taxonomic-searches.R index ca40f019..fc0c9509 100644 --- a/R/taxonomic-searches.R +++ b/R/taxonomic-searches.R @@ -3,7 +3,7 @@ #' @title Look up taxon information #' #' @description -#' `search_taxa()` allows users to look up taxonomic names, and ensure they are +#' [search_taxa()] allows users to look up taxonomic names, and ensure they are #' being matched correctly, before downloading data from the specified #' organisation. #' @@ -16,7 +16,7 @@ #' A more common use-case is to distinguish between homonyms by listing higher #' taxonomic units, by supplying columns like `kingdom`, `phylum` or `class`. #' -#' `search_identifiers()` allows users to look up matching taxonomic names using +#' [search_identifiers()] allows users to look up matching taxonomic names using #' their unique `taxonConceptID`. In the ALA, all records are associated with #' an identifier that uniquely identifies the taxon to which that record belongs. #' Once those identifiers are known, this function allows you to use them to @@ -25,13 +25,14 @@ #' identifiers. #' #' Note that when taxonomic look-up is required within a pipe, the equivalent -#' to `search_taxa()` is \code{\link[=identify.data_request]{identify()}} (or -#' [galah_identify()]). The equivalent to `search_identifiers()` is to use +#' to [search_taxa()] is \code{\link[=identify.data_request]{identify()}} (or +#' [galah_identify()]). The equivalent to [search_identifiers()] is to use #' \code{\link[=filter.data_request]{filter()}} to filter by `taxonConceptId`. #' #' @details #' `search_taxa()` returns the taxonomic match of a supplied text string, along #' with the following information: +#' #' * `search_term`: The search term used by the user. When multiple search #' terms are provided in a tibble, these are displayed in this column, #' concatenated using `_`. @@ -48,6 +49,17 @@ #' * `taxonomic names` (e.g. `kingdom`, `phylum`, `class`, `order`, #' `family`, `genus`) #' +#' When querying using [request_metadata()], you have the option to pass +#' \code{\link[=select.metadata_request]{select()}} within the query. The +#' easiest way to do this is `select(everything())`, but for completeness, the +#' following additional fields are available: +#' +#' * `success`: Logical indicating success or failure of the search +#' * `scientific_name_authorship`: Author and year for the name in question +#' * `name_type`: Usually `"SCIENTIFIC"` +#' * `lft` and `rgt`: Numeric indices for taxonomic lookups +#' * `species_group` and `species_subgroup`: List-columns giving group names +#' * `_id` fields for `rank` and any taxonomic rank fields (`kingdom_id`, `phylum_id` etc.) #' #' @seealso [search_all()] for how to get names if taxonomic identifiers #' are already known. \code{\link[=filter.data_request]{filter()}}, @@ -78,7 +90,26 @@ #' family = c("pardalotidae", "maluridae"), #' scientificName = c("Pardalotus striatus striatus", "malurus cyaneus"))) #' +#' # Use OOP for the same effect +#' # `identify()` tells the code that we want to search for _taxonomic_ metadata. +#' request_metadata() |> +#' identify("crinia") |> +#' collect() +#' +#' # This approach has the advantage that we can call `select()` +#' request_metadata() |> +#' identify("crinia") |> +#' select(everything()) |> +#' collect() +#' #' # Look up a unique taxon identifier #' search_identifiers(query = "https://id.biodiversity.org.au/node/apni/2914510") +#' +#' # OOP process for identifiers uses `filter()`, not `identify()` +#' # In these cases the `field` argument is used to specify `type` +#' request_metadata() |> +#' filter(identifier = "https://id.biodiversity.org.au/node/apni/2914510") |> +#' select(everything()) |> +#' collect() #' } NULL \ No newline at end of file diff --git a/R/tidyr-unnest.R b/R/tidyr-unnest.R new file mode 100644 index 00000000..ed068c11 --- /dev/null +++ b/R/tidyr-unnest.R @@ -0,0 +1,56 @@ +#' Unnest a query +#' +#' This syntax is borrowed from `tidyr`, and is conceptually used in the same +#' way here, but in galah unnest amends the query to unnest information +#' server-side, rather than on your machine. It powers all of the +#' [show_values()] functions in galah. +#' @details +#' Re-implementing existing functions has the consequence of supporting +#' consistent syntax with tidyverse, at the cost of potentially introducing +#' conflicts. This can be avoided by using the `::` operator where required. +#' @param .query An object of class `metadata_request` +#' @returns An object of class `metadata_request` +#' @examples \dontrun{ +#' # Return values of field `basisOfRecord` +#' request_metadata() |> +#' unnest() |> +#' filter(field == basisOfRecord) |> +#' collect() +#' +#' # Using `galah::unnest()` in this way is equivalent to: +#' show_all(fields, "basisOfRecord") |> +#' show_values() +#' +#' # to add information to a species list: +#' request_metadata() |> +#' filter(list == "dr650") |> +#' select(everything()) |> +#' unnest() |> +#' collect() +#' } +#' @export +unnest <- function(.query){ + if(!inherits(.query, "metadata_request")){ + cli::cli_abort("`galah::unnest()` can only be used with objects of class `metadata_request`.") + } + if(!is.null(.query$filter)){ + # check whether `type` is supplied as singular (i.e. `field` not `fields`) + supplied_type <- .query$filter$variable[1] + if(supplied_type != "taxa" & !grepl("s$", supplied_type)){ + supplied_type <- glue::glue("{supplied_type}s") + } + }else if(!is.null(.query$identify)){ + supplied_type <- "taxa" + }else{ + supplied_type <- .query$type + } + # ensure only used with certain query types + valid_types <- c("fields", "lists", "profiles", "taxa") + if(!(supplied_type %in% valid_types)){ + c("Invalid `type` supplied to `unnest()`", + i = "Valid types are `fields`, `lists`, `profiles` or `taxa`") |> + cli::cli_abort() + } + .query$type <- glue::glue("{supplied_type}-unnest") + .query +} diff --git a/R/tidyverse.R b/R/tidyverse.R deleted file mode 100644 index 982babc2..00000000 --- a/R/tidyverse.R +++ /dev/null @@ -1,84 +0,0 @@ -#' Non-generic tidyverse functions -#' -#' Several useful functions from tidyverse packages are `generic`, meaning -#' that we can define class-specific versions of those functions and implement -#' them in galah; examples include `filter()`, `select()` and `group_by()`. -#' However, there are also functions that are only defined within tidyverse -#' packages and are not generic. In a few cases we have re-implemented these -#' functions in galah. This has the consequence of supporting consistent -#' syntax with tidyverse, at the cost of potentially introducing conflicts. -#' This can be avoided by using the `::` operator where required (see examples). -#' -#' The following functions are included: -#' - `desc()` (`dplyr`): Use within `arrange()` to specify arrangement should be descending -#' - `unnest()` (`tidyr`): Use to 'drill down' into nested information on `fields`, `lists`, `profiles`, or `taxa` -#' -#' These galah versions all use lazy evaluation. -#' @returns -#' - `galah::desc()` returns a `tibble` used by `arrange.data_request()` to arrange rows of a query. -#' - `galah::unnest()` returns an object of class `metadata_request`. -#' @seealso \code{\link[=arrange.data_request]{arrange()}}, [galah_call()] -#' @examples \dontrun{ -#' # Arrange grouped record counts by descending year -#' galah_call() |> -#' identify("perameles") |> -#' filter(year > 2019) |> -#' count() |> -#' arrange(galah::desc(year)) |> -#' collect() -#' -#' # Return values of field `basisOfRecord` -#' request_metadata() |> -#' galah::unnest() |> -#' filter(field == basisOfRecord) |> -#' collect() -#' -#' # Using `galah::unnest()` in this way is equivalent to: -#' show_all(fields, "basisOfRecord") |> -#' show_values() -#' } -#' @name tidyverse_functions -NULL - -# @rdname tidyverse_functions -# @export -# between <- function(){} - -#' @rdname tidyverse_functions -#' @param ... column to order by -#' @export -desc <- function(...){ - dots <- enquos(..., .ignore_empty = "all") - parsed_dots <- parse_quosures_basic(dots) - tibble(variable = parsed_dots, - direction = "descending") -} - -#' @rdname tidyverse_functions -#' @param .query An object of class `metadata_request` -#' @export -unnest <- function(.query){ - if(!inherits(.query, "metadata_request")){ - abort("`galah::unnest()` can only be used with objects of class `metadata_request`.") - } - if(!is.null(.query$filter)){ - supplied_type <- .query$filter$variable[1] - if(supplied_type != "taxa" & - !grepl("s$", supplied_type)){ - supplied_type <- paste0(supplied_type, "s") - } - }else if(!is.null(.query$identify)){ - supplied_type <- "taxa" - }else{ - supplied_type <- .query$type - } - valid_types <- c("fields", "lists", "profiles", "taxa") - if(!(supplied_type %in% valid_types)){ - bullets <- c( - "Invalid `type` supplied to `unnest()`", - i = "Valid types are `fields`, `lists`, `profiles` or `taxa`") - abort(bullets, call = caller_env()) - } - .query$type <- paste0(supplied_type, "-unnest") - .query -} diff --git a/R/update_data_request.R b/R/update_data_request.R deleted file mode 100644 index 864652ff..00000000 --- a/R/update_data_request.R +++ /dev/null @@ -1,86 +0,0 @@ -#' Internal function to update a `data_request` -#' @noRd -#' @keywords Internal -update_data_request <- function(data_request, ...){ - dots <- list(...) - if(length(dots)[[1]] == 1){ - if(inherits(dots[[1]], "list") & is.null(names(dots))){ - dots <- dots[[1]] - } - } - result <- lapply( - names(data_request), # i.e. for all slots in object of class `data_request` - function(a){ - if(any(names(dots) == a)){ # object is present in `data_request` - if(is.null(data_request[[a]])){ # slot in `data_request` is empty - dots[[a]] - }else{ # slot is filled - if(is.null(dots[[a]])){ # if nothing has been supplied, retain source - data_request[[a]] - }else{ # both supplied and source contain data - switch(a, - "identify" = { - bind_unique_rows(data_request[[a]], dots[[a]], "search_term") - }, - "filter" = { - bind_unique_rows(data_request[[a]], dots[[a]], "query") - }, - "select" = { - update_select(data_request[[a]], dots[[a]]) - }, - # for below, we assume that in all other circumstances we - # simply pass the most recent result (i.e. overwrite) - dots[[a]] # default - ) - } - } - }else{ # if supplied object is not named in `data_request` - data_request[[a]] - } - }) - names(result) <- names(data_request) - - # check if any names in `dots` have been missed from `results` - missing_names <- !(names(dots) %in% names(result)) - if(any(missing_names)){ - result <- append(result, dots[missing_names]) - } - class(result) <- "data_request" - result -} - -#' Internal function to join together two `select` objects -#' @importFrom rlang is_quosure -#' @noRd -#' @keywords Internal -update_select <- function(x, y){ - quosure_check_x <- lapply(x, is_quosure) |> unlist() - quosure_check_y <- lapply(y, is_quosure) |> unlist() - if(any(quosure_check_y)){ - result <- append(x[quosure_check_x], y[quosure_check_y]) - }else if(any(quosure_check_x)){ - result <- x[quosure_check_x] - }else{ - result <- list() - } - group_vec <- unique(c(x$group, y$group)) - if(length(group_vec) < 1){ - group_vec <- NULL - } - result |> - add_summary() |> - add_group(group = group_vec) -} - -#' Internal function to join tibbles by row -#' @importFrom dplyr bind_rows -#' @importFrom dplyr filter -#' @importFrom tibble tibble -#' @noRd -#' @keywords Internal -bind_unique_rows <- function(x, y, column){ - result <- list(x, y) |> - bind_rows() |> - tibble() - filter(result, !duplicated(result[[column]])) -} \ No newline at end of file diff --git a/R/url_lookup.R b/R/url_lookup.R index 5dfe28cb..5b7321ff 100644 --- a/R/url_lookup.R +++ b/R/url_lookup.R @@ -9,46 +9,40 @@ #' calling `verbose` via `pour`. This is so the developer can suppress messages #' independently of user preferences, since this function is often called #' internally. -#' @importFrom dplyr filter -#' @importFrom dplyr pull -#' @importFrom glue glue_data -#' @importFrom glue glue -#' @importFrom potions pour -#' @importFrom rlang abort #' @noRd #' @keywords internal url_lookup <- function(type, ..., quiet = FALSE, - error_call = caller_env()){ + error_call = rlang::caller_env()){ dots <- list(...) - current_atlas <- pour("atlas", "region") + current_atlas <- potions::pour("atlas", "region") # get requested url if(missing(type)){ type <- dots$type } url_string <- node_config |> - filter(node_config$type == {{type}}, - node_config$atlas == {{current_atlas}}) |> - pull(url) + dplyr::filter(.data$type == {{type}} & + .data$atlas == {{current_atlas}}) |> + dplyr::pull(url) # parse as needed if(length(url_string) > 0){ if(length(dots) > 0){ - glue_data(dots, url_string) |> + glue::glue_data(dots, url_string) |> as.character() |> utils::URLencode() }else{ - url_string |> utils::URLencode() + url_string |> + utils::URLencode() } }else{ if(quiet){ return(NULL) }else{ - bullets <- c( - glue("No API is available for type `{type}`"), - i = glue("Selected atlas: {current_atlas}"), - i = "Use `show_all_apis()` to list valid API calls") - abort(bullets, call = error_call) + c("No API is available for type `{type}`", + i = "Selected atlas: {current_atlas}", + i = "Use `show_all_apis()` to list valid API calls") |> + cli::cli_abort(call = error_call) } } } \ No newline at end of file diff --git a/R/utilities_caching.R b/R/utilities_caching.R new file mode 100644 index 00000000..ab5d6aa5 --- /dev/null +++ b/R/utilities_caching.R @@ -0,0 +1,73 @@ +# Internal functions to store objects generated from some `request_metadata` calls +# This increases speed by ensuring that the atlas is only queried when needed. + +#' Internal function to overwrite a cached list in a specified place +#' @param x list +#' @noRd +#' @keywords Internal +overwrite_cache <- function(x){ + result <- list(x) + names(result) <- "check_internal_cache" + options(result) +} + +#' Internal function to reset cache to package defaults +#' @noRd +#' @keywords Internal +reset_cache <- function(){ + overwrite_cache(galah_internal_cached) +} + +#' Internal function to add a slot to current cache +#' @noRd +#' @keywords Internal +update_cache <- function(...){ + dots <- list(...) + if(length(dots) < 1){ + cli::cli_abort("cache not updated") + } + result <- retrieve_cache() + for(i in seq_along(dots)){ + result[[names(dots)[i]]] <- dots[[i]] + } + overwrite_cache(result) +} + +#' Internal function to retrieve current state of the cache +#' @param slot_name (optional) slot to extract +#' @noRd +#' @keywords Internal +retrieve_cache <- function(slot_name){ + full_cache <- getOption("check_internal_cache") + if(missing(slot_name)){ + full_cache + }else{ + if(any(names(full_cache) == slot_name)){ + full_cache[[slot_name]] + }else{ + NULL + } + } +} + +#' Internal function to decide whether to update the internal cache +#' @noRd +#' @keywords Internal +check_if_cache_update_needed <- function(function_name){ + # get data for checking + df <- retrieve_cache(function_name) + current_atlas <- potions::pour("atlas", "region", .pkg = "galah") + # build some checks + caching_disabled <- !potions::pour("package", "caching", .pkg = "galah") + is_local <- !is.null(attr(df, "ARCHIVED")) + is_wrong_atlas <- attr(df, "region") != current_atlas + is_too_short <- nrow(df) < 1 # somewhat arbitrary, but catches empty tibbles + # evaluate those checks + # if any are TRUE, update is needed + result <- is_local | is_wrong_atlas | is_too_short | caching_disabled + if(length(result) < 1){ # bug catcher + TRUE + }else{ + result + } +} \ No newline at end of file diff --git a/R/utilities_internal.R b/R/utilities_internal.R index 212e7d04..969d0112 100644 --- a/R/utilities_internal.R +++ b/R/utilities_internal.R @@ -2,92 +2,246 @@ ## Output formatting functions -- ##--------------------------------------------------------------- -# Select column names to return -# Subsets data returned by webservices to useful columns -wanted_columns <- function(type) { +#' Internal function to run `eval_tidy()` on captured `select()` requests. +#' This is the *enactment* phase and is usually called by `collect()`. +#' Critically, this function is *NOT* called by `select()`. This matters because +#' we have to eval `unnest()` before `select()` for it to work, and this can +#' only happen at the end of a pipe. +#' @noRd +#' @keywords Internal +parse_select <- function(df, .query){ + # get quosures captured by `select()` + quo_list <- purrr::pluck(.query, "request", "select", "quosure") + # map() over list of quosures + # honestly I don't know why `!!quo_list` fails here, but it does, so used this instead + pos <- purrr::map(quo_list, \(a){ + tidyselect::eval_select(expr = a, data = df) + }) |> + unlist() + # apply tidy selection to `df` + # note: this code taken from `tidyselect` documentation; it could be argued that `df[pos]` is sufficient + rlang::set_names(df[pos], names(pos)) +} + +#' equivalent to `parse_select()` but for filter +#' mainly called for delayed filter arugments on APIs that don't support `q` +#' @noRd +#' @keywords Internal +parse_filter <- function(df, query){ + filter_entry <- query$request$filter + if(!is.null(filter_entry) & ncol(df) > 0){ + search_col <- switch(query$type, + "metadata/fields" = "id", + "metadata/profiles" = "short_name", + colnames(df)[1]) + value <- filter_entry$value + df |> dplyr::filter(.data[[search_col]] == value) + }else{ + df + } +} + +#' Internal function to rename specific columns. Note this is safer than calling +#' `dplyr::rename()` directly, because it only seeks to rename columns that +#' are actually present, and so won't fail. +#' @noRd +#' @keywords Internal +parse_rename <- function(df, .query){ + cols <- colnames(df) + rename_vec <- .query$type |> + stringr::str_remove("^metadata/") |> + stringr::str_remove("-single$|-multiple$") |> # so that `taxa` args are matched + lookup_rename_columns() + # check whether renaming information is given + if(!is.null(rename_vec)){ + # check whether these are actually present in the supplied `tibble` + col_lookup <- rename_vec %in% cols + # if they are, rename + if(any(col_lookup)){ + rename_cols <- as.list(rename_vec[col_lookup]) + dplyr::rename(df, !!!rename_cols) + # otherwise, return source `tibble` + }else{ + df + } + # if no lookup information supplied, return source `tibble` + }else{ + df + } +} + +#' Simple internal function to `arrange()` by first column +#' @noRd +#' @keywords Internal +parse_arrange <- function(df){ + dplyr::arrange(df, dplyr::pull(df, 1)) +} + +#' Choose column names to pass to `select()`. +#' NOTE: this isn't especially subtle wrt different atlases +#' NOTE: this assumes `dplyr::rename_with(camel_to_snake_case)` has been run +#' @noRd +#' @keywords Internal +lookup_select_columns <- function(type) { switch(type, - "taxa" = c("search_term", "scientific_name", - "scientific_name_authorship", - "taxon_concept_id", # ALA - "taxon_concept_lsid", # Austria, Guatemala - "authority", # OpenObs - "usage_key", # GBIF - "guid", # species search - "canonical_name", "status", - "rank", - "match_type", "kingdom", "phylum", "class", "order", - "family", "genus", "species", "vernacular_name", - "issues","subkingdom", "superclass", "infraclass", - "subclass", "subinfraclass", "suborder", "superorder", - "infraorder", "infrafamily", "superfamily", "subfamily", - "subtribe", "subgenus", "subspecies"), - "extended_taxa" = c("subkingdom", "superclass", "infraclass", - "subclass", "subinfraclass", "suborder", - "superorder", "infraorder", "infrafamily", - "superfamily", "subfamily", "subtribe", - "subgenus"), - "profile" = c("id", "shortName", "name", "description"), - "media" = c("image_id", - "creator", "license", + "assertions" = c("id", + "description", + "category", + "type"), + "fields" = c("id", + "description", + "type"), + "identifiers" = lookup_select_columns_taxa(), + "licences" = c("id", + "name", + "acronym", + "url"), + "lists" = c("species_list_uid", + "list_name", + "description", + "list_type", + "item_count"), + "lists-unnest" = c("scientific_name", + "vernacular_name", + "taxon_concept_id"), + "media" = c("media_id", + "occurrence_id", + "creator", + "license", "data_resource_uid", - "date_taken", "date_uploaded", - "mime_type", "mimetype", - "width", "height", "size_in_bytes", - "image_url" - ), - "layer" = c("id", "description", "source_link"), - "fields" = c("id", "description"), - "assertions" = c("id", "description", "category"), - "quality_filter" = c("description", "filter"), - "reasons" = c("id", "name")) + "date_taken", + "date_uploaded", + "mime_type", + "size_in_bytes", + "success"), + "profiles" = c("id", + "short_name", + "name", + "description"), + "profiles-unnest" = c("id", + "description", + "filter", + "enabled"), + "reasons" = c("id", + "name"), + "taxa" = lookup_select_columns_taxa(), + "taxa-unnest" = c("name", + "taxon_concept_id", + "parent_taxon_concept_id", + "rank"), + NULL # When no defaults are set, sending NULL tells the code to call `everything()` + ) } -#' Internal function to rename specific columns, and convert to snake_case +#' `lookup_select_columns()` but for taxa and identifier queries #' @noRd #' @keywords Internal -rename_columns <- function(varnames, type) { - varnames <- camel_to_snake_case(varnames) - switch(type, - "media" = { - varnames[varnames %in% c("image_identifier")] <- "image_id" - varnames[varnames == "mime_type"] <- "mimetype" - }, - "taxa" = { - varnames[varnames == "classs"] <- "class" - varnames[varnames %in% c("usage_key", "usageKey", "guid", "reference_id", "referenceId")] <- "taxon_concept_id" - varnames[varnames %in% c("genus_name", "genusName")] <- "genus" - varnames[varnames %in% c("family_name", "familyName")] <- "family" - varnames[varnames %in% c("order_name", "orderName")] <- "order" - varnames[varnames %in% c("class_name", "className")] <- "class" - varnames[varnames %in% c("phylum_name", "phylumName")] <- "phylum" - varnames[varnames %in% c("kingdom_name", "kingdomName")] <- "kingdom" - varnames[varnames %in% c("rank_name", "rankName")] <- "rank" - varnames[varnames %in% c("french_vernacular_name", "frenchVernacularName")] <- "vernacular_name" - }, - "assertions" = { - varnames[varnames == "name"] <- "id" - }, - "checklist" = { - varnames[1] <- "taxon_concept_id" - varnames[varnames %in% c("counts", "number_of_records")] <- "count" - } +lookup_select_columns_taxa <- function(){ + c("search_term", + "scientific_name", + "scientific_name_authorship", + "taxon_concept_id", # ALA + "taxon_concept_lsid", # Austria, Guatemala + "authority", # OpenObs + "key", # GBIF + "usage_key", # GBIF + "guid", # species search + "canonical_name", "status", + "rank", + "match_type", + "confidence", + "time_taken", + "vernacular_name", + "issues", + # taxonomic ranks (basic only) + "kingdom", + "phylum", + "class", + "order", + "family", + "genus", + "species" + # if all are needed, use this instead + # {show_all_ranks() |> dplyr::pull("name")} ) - varnames } +#' Choose which columns to rename +#' @noRd +#' @keywords Internal +lookup_rename_columns <- function(type){ + switch(type, + "assertions" = c("id" = "name"), + "identifiers" = c("taxonConceptID" = "key"), + "lists" = c("species_list_uid" = "data_resource_uid"), + "lists-unnest" = c("taxon_concept_id" = "lsid"), + "media" = c("media_id" = "image_identifier"), + "taxa" = c("class" = "classs", + "taxon_concept_id" = "usage_key", + "taxon_concept_id" = "guid", + "taxon_concept_id" = "reference_id", + "taxon_concept_id" = "key", + "genus" = "genus_name", + "family" = "family_name", + "order" = "order_name", + "phylum" = "phylum_name", + "kingdom" = "kingdom_name", + "rank" = "rank_name", + "vernacular_name" = "french_vernacular_name"), + "taxa-unnest" = c("taxon_concept_id" = "guid", + "parent_taxon_concept_id" = "parent_guid"), + NULL + ) +} + +##--------------------------------------------------------------- +## Cases -- +##--------------------------------------------------------------- + #' Internal function to make text to snake case #' @noRd #' @keywords Internal -camel_to_snake_case <- function(x){ - x |> +camel_to_snake_case <- function(string){ + string |> gsub("([a-z])([A-Z])", "\\1_\\L\\2", x = _, perl = TRUE) |> trimws(which = "both") |> # end spaces gsub("\\.+|\\s+", "_", x = _) |> # internal dots or spaces tolower() } +#' Internal function to handle conversion from camelCase to upper snake case +#' @noRd +#' @keywords internal +gbif_upper_case <- function(string){ + gsub("(?=[[:upper:]])", "_", string, perl = TRUE) |> + toupper() +} + +#' Internal function to handle conversion from upper snake case to camelCase +#' Primarily for reversing the action of `gbif_upper_case()` (above) +#' vectorized (kinda) 2026-02-05 +#' @noRd +#' @keywords internal +snake_to_camel_case <- function(string){ + # first split into words + string_list <- string |> + tolower() |> + strsplit("_") + # then merge multi-word strings + n_words <- lengths(string_list) + if(any(n_words > 1)){ + x <- purrr::map(string_list[n_words > 1], + \(a){ + c(a[[1]], stringr::str_to_title(a[seq(2, length(a))])) |> + paste0(collapse = "") + }) + string_list[n_words > 1] <- x + } + unlist(string_list) +} + ##--------------------------------------------------------------- -## Other helpful functions -- +## Set API header arguments -- ##--------------------------------------------------------------- # Construct the user agent string, consisting of the galah version @@ -97,41 +251,75 @@ galah_version_string <- function() { suppressWarnings( try(version_string <- utils::packageDescription("galah")[["Version"]], silent = TRUE)) ## get the galah version, if we can - paste0("galah-R ", version_string) + glue::glue("galah-R {version_string}") } -#' Internal function for determining if we should call GBIF or not -#' @importFrom potions pour #' @noRd #' @keywords Internal -is_gbif <- function(){ - pour("atlas", "region") == "Global" +source_type_id_lookup <- function(region){ + switch(region, + "Austria" = 1, + "United Kingdom" = 2001, + "2004") # ALA default for galah } -#' Internal function for determining whether a Living Atlas supports reasons API. -#' This affects whether a reason is appended to a query in `collapse()` (and -#' checked in `compute()`) -#' @importFrom potions pour +##---------------------------------------------------------------- +## Functions to add information to occurrence queries -- +##---------------------------------------------------------------- +## Note these now follow `tidyverse` convention of accepting and +## returning same object type + +#' Add a logical flag re: whether user should receive an email +#' @param x a list #' @noRd #' @keywords Internal -atlas_supports_reasons_api <- function(){ - atlas <- pour("atlas", "region") - supports_reasons <- c("Australia", "Austria", "Guatemala", "Portugal", - "Spain", "Sweden", "United Kingdom") - atlas %in% supports_reasons - - ## List of atlases that support reasons can be checked by running: - # show_all(apis) |> - # dplyr::filter(type == "metadata/reasons") |> - # dplyr::pull(atlas) +add_email_notify <- function(x) { + notify <- as.logical(potions::pour("package", "send_email")) + if(is.na(notify)) { + notify <- FALSE + } + x$emailNotify <- ifelse(notify, "true", "false") + x } -##--------------------------------------------------------------- -## Data request helper functions -- -##--------------------------------------------------------------- +#' Add an email address, but *only* when JWT tokens are not given +#' @noRd +#' @keywords Internal +add_email_address <- function(x, query){ + if(is.null(query$authenticate)){ + x$email <- potions::pour("user", "email") + } + x +} +#' Add a DOI request +#' @noRd +#' @keywords Internal +add_doi_request <- function(x, mint_doi = FALSE){ + if(isTRUE(mint_doi) & + potions::pour("atlas", "region") == "Australia"){ + x$mintDoi <- TRUE + } + x +} -## show_all_atlases / search_atlases --------------------------# +##---------------------------------------------------------------- +## Functions to change behaviour depending on selected `atlas` -- +##---------------------------------------------------------------- + +#' Internal function for determining if we should call GBIF or not +#' @noRd +#' @keywords Internal +is_gbif <- function(){ + potions::pour("atlas", "region") == "Global" +} + +#' Internal function for determining if we should call ALA or not +#' @noRd +#' @keywords Internal +is_ala <- function(){ + potions::pour("atlas", "region") == "Australia" +} #' Internal function to populate `groups` arg in `select()` #' @noRd @@ -162,97 +350,108 @@ preset_groups <- function(group_name) { #' @noRd #' @keywords Internal default_columns <- function() { - atlas <- pour("atlas", "region") - switch (atlas, - "Austria" = c("id", - "taxon_name", - "taxon_concept_lsid", - "latitude", - "longitude", - "occurrence_date", - "occurrence_status", - "data_resource_uid"), - "Brazil" = c("id", - "taxon_name", - "taxon_concept_lsid", - "latitude", - "longitude", - "occurrence_date", - "occurrence_status", - "data_resource_uid"), - "France" = c("id", - "scientificName", - "taxonConceptID", - "decimalLatitude", - "decimalLongitude", - "eventDate", - "occurrenceStatus", - "dataResourceUid"), - "Guatemala" = c("id", - "taxon_name", - "taxon_concept_lsid", - "latitude", - "longitude", - "occurrence_date", - "occurrence_status", - "data_resource_uid"), - "Portugal" = c("id", - "taxon_name", - "taxon_concept_lsid", - "latitude", - "longitude", - "occurrence_date", - "occurrence_status", - "data_resource_uid"), - "Spain" = c("recordID", - "scientificName", - "taxonConceptID", - "decimalLatitude", - "decimalLongitude", - "eventDate", - "occurrenceStatus", - "dataResourceUid"), - "United Kingdom" = c("id", - "taxon_name", - "taxon_concept_lsid", - "latitude", - "longitude", - "occurrence_date", - "occurrence_status", - "data_resource_uid"), - c("recordID", # note this requires that the ALA name (`id`) be corrected - "scientificName", - "taxonConceptID", - "decimalLatitude", - "decimalLongitude", - "eventDate", - "occurrenceStatus", - "dataResourceName") - ) + atlas <- potions::pour("atlas", "region") + if(atlas %in% c("Austria", + "Brazil", + "Guatemala", + "Portugal")){ + c("id", + "taxon_name", + "taxon_concept_lsid", + "latitude", + "longitude", + "occurrence_date", + "basis_of_record", + "occurrence_status", + "data_resource_uid") + }else if(atlas %in% c("France")){ + c("id", # only difference from ALA + "scientificName", + "taxonConceptID", + "decimalLatitude", + "decimalLongitude", + "eventDate", + "basisOfRecord", + "occurrenceStatus", + "dataResourceName") + }else if(atlas %in% c("Australia", + "Flanders", + "Kew", + "Spain", + "Sweden", + "United Kingdom")){ + c("recordID", # note this requires that the ALA name (`id`) be corrected + "scientificName", + "taxonConceptID", + "decimalLatitude", + "decimalLongitude", + "eventDate", + "basisOfRecord", + "occurrenceStatus", + "dataResourceName") + }else{ + cli::cli_abort("Unknown `atlas`") + } } #' @noRd #' @keywords Internal image_fields <- function() { - atlas <- pour("atlas", "region") - switch (atlas, - "Austria" = "all_image_url", - "Australia" = c("multimedia", "images", "sounds", "videos"), - "Brazil" = "all_image_url", - "Guatemala" = "all_image_url", - "Portugal" = "all_image_url", - "Spain" = c("multimedia", "images", "sounds", "videos"), - "Sweden" = c("multimedia", "images", "videos", "sounds"), - "United Kingdom" = "all_image_url" - # Guatemala ? + atlas <- potions::pour("atlas", "region") + if(atlas %in% c("Austria", + "Brazil", + "Guatemala", + "Portugal")){ + "all_image_url" + }else if(atlas %in% c("Australia", + "Flanders", + "Spain", + "Sweden", + "United Kingdom")){ + c("multimedia", "images", "sounds", "videos") + }else if(atlas %in% c("Kew")){ + c("multimedia", "images") + }else{ + cli::cli_abort("Unknown `atlas`") + } +} + +#' Set filters that work for media in each atlas +#' @noRd +#' @keywords Internal +image_filters <- function(present_fields, + error_call = rlang::caller_env()){ + + atlas <- potions::pour("atlas", "region") + switch(atlas, + "Austria" = "(all_image_url:*)", + "Australia" = glue::glue("({present_fields}:*)"), + "Brazil" = "(all_image_url:*)", + "Flanders" = "(images:*)", + "Guatemala" = "(all_image_url:*)", + "Kew" = "(images:*)", + "Portugal" = "(all_image_url:*)", + "Spain" = "(multimedia:*)", + "Sweden" = {filter_fields <- present_fields |> + stringr::str_remove("s$") |> + paste0("IDsCount") + glue::glue("{filter_fields}:[1 TO *]")}, + "United Kingdom" = "(all_image_url:*)", + cli::cli_abort("`atlas_media` is not supported for atlas = {atlas}", + call = error_call) ) } #' @noRd #' @keywords Internal species_facets <- function(){ - atlas <- pour("atlas", "region") - if(atlas %in% c("Australia", "France", "Spain", "Sweden")) { + atlas <- potions::pour("atlas", "region") + if(atlas %in% c("Australia", + "Flanders", + "France", + "Spain", + "Sweden", + "United Kingdom")) { "speciesID" }else{ "species_guid" @@ -261,9 +460,39 @@ species_facets <- function(){ #' @noRd #' @keywords Internal -source_type_id_lookup <- function(region){ - switch(region, - "Austria" = 1, - "United Kingdom" = 2001, - "2004") # ALA default for galah +profiles_supported <- function(){ + atlas <- potions::pour("atlas", "region") + if(atlas %in% c("Australia", + "Flanders", + "Sweden", + "Spain")) { + TRUE + }else{ + FALSE + } +} + +#' Internal function for determining whether a Living Atlas supports reasons API. +#' This affects whether a reason is appended to a query in `collapse()` (and +#' checked in `compute()`) +#' @noRd +#' @keywords Internal +reasons_supported <- function(){ + atlas <- potions::pour("atlas", "region") + supported_atlases <- request_metadata(type = "apis") |> + collect() |> + dplyr::filter(.data$type == "metadata/reasons") |> + dplyr::pull("atlas") + atlas %in% supported_atlases +} + +#' @noRd +#' @keywords Internal +media_supported <- function(){ + atlas <- potions::pour("atlas", "region", + .pkg = "galah") + unsupported_atlases <- c("France", "Global") + if(atlas %in% unsupported_atlases){ + cli::cli_abort("`atlas_media` is not supported for atlas = {atlas}") + } } \ No newline at end of file diff --git a/R/utilities_occurrences.R b/R/utilities_occurrences.R deleted file mode 100644 index f0898cb1..00000000 --- a/R/utilities_occurrences.R +++ /dev/null @@ -1,54 +0,0 @@ -# Q: delete this? - - -# check_count <- function(count, max_count, error_call = caller_env()) { -# if (count < 1) { -# abort("This query does not match any records.", call = error_call) -# } else if (count > max_count) { -# too_many_records(max_count) -# } else { -# if (pour("package", "verbose")) { -# count_text <- formatC(count, big.mark = ",", format = "f", digits = 0) -# inform(glue("This query will return {count_text} records")) -# } -# } -# } - -# too_many_records <- function(max_count){ -# max_text <- formatC(max_count, big.mark = ",", format = "f", digits = 0) -# bullets <- c( -# "Your data request was too large.", -# i = glue("A maximum of {max_text} records can be retrieved at once."), -# i = "Please narrow the query and try again." -# ) -# abort(bullets, call = caller_env()) -# } - - -email_notify <- function() { - notify <- as.logical(pour("package", "send_email")) - if (is.na(notify)) { - notify <- FALSE - } - # ala api requires lowercase - ifelse(notify, "true", "false") -} - -# NOTE: Do we need this anymore? Delete? -occ_error_handler <- function(code, error_call = rlang::caller_env()) { - if (code == 403) { - bullets <- c( - "Status code 403 was returned.", - i = glue("Is the email you provided to `galah_config()` registered with the selected atlas?") - ) - inform(bullets) - } - if (code == 504) { - bullets <- c( - "Status code 504 was returned.", - i = "This usually means that the selected API is down.", - i = "If you continue to receive this error, please email support@ala.org.au" - ) - inform(bullets) - } -} \ No newline at end of file diff --git a/README.Rmd b/README.Rmd index d74ff021..960be095 100644 --- a/README.Rmd +++ b/README.Rmd @@ -51,7 +51,7 @@ If you have any comments, questions or suggestions, please [contact us](mailto:s ## Getting started - The [quick start guide](https://galah.ala.org.au/R/articles/quick_start_guide.html) provides an introduction to the package functions. -- For an outline of the package structure, and a list of all the available functions, run `?galah` or view the [reference page](https://galah.ala.org.au/R/index.html). +- For an outline of the package structure, and a list of all the available functions, run `?galah` or view the [reference page](https://galah.ala.org.au/R/reference/index.html). diff --git a/README.md b/README.md index 016882c3..41ee44f6 100644 --- a/README.md +++ b/README.md @@ -9,6 +9,7 @@ status](https://www.r-pkg.org/badges/version/galah)](https://cran.r-project.org/package=galah) [![Codecov test coverage](https://codecov.io/gh/AtlasOfLivingAustralia/galah-R/branch/main/graph/badge.svg)](https://app.codecov.io/gh/AtlasOfLivingAustralia/galah-R?branch=main) +[![R-CMD-check](https://github.com/AtlasOfLivingAustralia/galah-R/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/AtlasOfLivingAustralia/galah-R/actions/workflows/R-CMD-check.yaml) ## Overview @@ -45,7 +46,7 @@ us](mailto:support@ala.org.au). provides an introduction to the package functions. - For an outline of the package structure, and a list of all the available functions, run `?galah` or view the [reference - page](https://galah.ala.org.au/R/index.html). + page](https://galah.ala.org.au/R/reference/index.html). ## Installation diff --git a/_pkgdown.yml b/_pkgdown.yml index 3f6d290b..d214d9fc 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -25,66 +25,68 @@ navbar: articles: text: Articles menu: - - text: Get started - - text: Choosing an atlas - href: articles/choosing_an_atlas.html - - text: Look up information + - text: Further information + - text: Looking up information href: articles/look_up_information.html - - text: Narrow your results - href: articles/narrow_your_results.html - - text: Download data - href: articles/download_data.html - - text: --- - - text: Advanced - - text: Object-oriented programming - href: articles/object_oriented_programming.html + - text: Accessing sensitive data + href: articles/accessing_sensitive_data.html - text: Reproduciblility href: articles/download-data-reproducibly.html + - text: Object oriented programming + href: articles/object-oriented-programming.html + - text: --- + - text: Filtering - text: Taxonomic filtering href: articles/taxonomic_filtering.html - text: Spatial filtering href: articles/spatial_filtering.html - text: Temporal filtering - href: articles/temporal_filtering.html - + href: articles/temporal_filtering.html news: text: News href: news/index.html reference: - title: Getting started contents: - - galah_call - galah_config - - show_all - - search_all - - search_taxa - - search_identifiers - - search_fields - - search_values - - show_all_profiles - - show_all_fields - - show_all_atlases - - show_all_reasons - - show_all_ranks - - show_values -- title: Amend a query + - galah_call +- title: Update a request object contents: - apply_profile - arrange.data_request + - authenticate - count.data_request - - desc + - distinct.data_request - filter.data_request - geolocate + - glimpse.data_request - group_by.data_request - identify.data_request - select.data_request - slice_head.data_request - reexports -- title: Execute a query via API + - unnest +- title: Create and execute a query contents: + - capture + - compound - collapse.data_request - compute.data_request - collect.data_request +- title: Wrappers for accessing data + contents: + - show_all + - search_all + - search_taxa + - search_identifiers + - search_fields + - search_values + - show_all_profiles + - show_all_fields + - show_all_atlases + - show_all_reasons + - show_all_ranks + - show_values - atlas_occurrences - atlas_counts - atlas_species @@ -94,7 +96,7 @@ reference: - title: Miscellaneous functions contents: - taxonomic_searches - - print_galah_objects - read_zip - atlas_citation -- title: internal + - as_data_filter + - print_galah_objects diff --git a/data-raw/1_gbif_web_scraping.R b/data-raw/1_gbif_web_scraping.R index 34a0914e..1d1d1925 100644 --- a/data-raw/1_gbif_web_scraping.R +++ b/data-raw/1_gbif_web_scraping.R @@ -7,32 +7,34 @@ library(tibble) # generate tibbles library(dplyr) # data manipulation library(purrr) # extraction from lists library(rvest) # web scraping assertions from gbif.org +library(stringr) -# tibble of available fields: -gbif_parameters_url <- "https://www.gbif.org/developer/occurrence#parameters" -data_raw <- read_html(gbif_parameters_url) |> - html_node("body")|> - html_nodes("table") - -data_text <- data_raw |> - pluck(7) |> # poor practice to hard-code this; checks may be needed - html_nodes("tr") |> - html_text() - -lapply(strsplit(data_text, "\n"), function(a){ - tibble( - id = trimws(a[[1]]), - description = trimws(paste(a[-1], collapse = ""))) -}) |> - bind_rows() |> - slice(-1) |> # header row gets imported as a row by mistake - mutate(type = "fields") |> - filter( - !grepl("^facet", id), - !(id %in% c("geometry", "geodistance", "q", "hl", "format"))) |> - write_csv("./data-raw/gbif_fields.csv") - +# Legacy code: this is now available via API +# # tibble of available fields: +# gbif_parameters_url <- "https://www.gbif.org/developer/occurrence#parameters" +# data_raw <- read_html(gbif_parameters_url) |> +# html_node("body")|> +# html_nodes("table") +# +# data_text <- data_raw |> +# pluck(7) |> # poor practice to hard-code this; checks may be needed +# html_nodes("tr") |> +# html_text() +# +# purrr::map(strsplit(data_text, "\n"), function(a){ +# tibble( +# id = trimws(a[[1]]), +# description = trimws(paste(a[-1], collapse = ""))) +# }) |> +# bind_rows() |> +# slice(-1) |> # header row gets imported as a row by mistake +# mutate(type = "fields") |> +# filter( +# !grepl("^facet", id), +# !(id %in% c("geometry", "geodistance", "q", "hl", "format"))) |> +# write_csv("./data-raw/gbif_fields.csv") +# Assertions, however, don't appear to have an API (yet) # tibble of assertions, scraped from gbif developer docs: gbif_assertions_url <- "https://gbif.github.io/gbif-api/apidocs/org/gbif/api/vocabulary/OccurrenceIssue.html" data_raw <- read_html(gbif_assertions_url) |> html_node("body") @@ -52,4 +54,22 @@ lapply(assertions_list, function(a){ }) |> bind_rows() |> mutate(type = "assertions") |> - write_csv("./data-raw/gbif_assertions.csv") \ No newline at end of file + write_csv("./data-raw/gbif_assertions.csv") + +## Also, fields that exist are *not* the same as those that +## can be used for search or faceting. +## Download and store these separately + +gbif_search_url <- "https://raw.githubusercontent.com/gbif/gbif-api/refs/heads/dev/src/main/java/org/gbif/api/model/occurrence/search/OccurrenceSearchParameter.java" +data_raw <- readLines(gbif_search_url) +field_strings <- data_raw[str_detect(data_raw, "^\\s+public final static")] |> + str_replace("^\\s+public final static OccurrenceSearchParameter ", "") |> + str_extract("^\\s*[:graph:]+") |> + trimws() |> + sort() +# can be compared to: +# https://gbif.github.io/gbif-api/apidocs/org/gbif/api/model/occurrence/search/OccurrenceSearchParameter.html + +tibble::tibble(id = snake_to_camel_case(field_strings)) |> + write_csv("./data-raw/gbif_search_fields.csv") + diff --git a/data-raw/2_internal_data.R b/data-raw/2_internal_data.R index 87ec4829..432e6a55 100644 --- a/data-raw/2_internal_data.R +++ b/data-raw/2_internal_data.R @@ -100,10 +100,11 @@ galah_internal_archived <- list( # cached versions of some show_all functions # NOTE: may be necessary to expand this given changes to `show_all()` stored_types <- c("assertions", "fields", "profiles", "reasons") -galah_internal_cached <- lapply( +galah_internal_cached <- purrr::map( stored_types, function(a){ - result <- request_metadata(type = a) |> collect() + result <- tibble::tibble() # i.e. ship blank tibbles to save space + # request_metadata(type = a) |> collect() # old code to actually populate the cache attr(result, "ARCHIVED") <- TRUE attr(result, "region") <- "Australia" result @@ -114,7 +115,8 @@ names(galah_internal_cached) <- stored_types # Import web-scraped gbif data as csv gbif_internal_archived <- list( assertions = read_csv("./data-raw/gbif_assertions.csv"), - fields = read_csv("./data-raw/gbif_fields.csv"), + # fields = read_csv("./data-raw/gbif_fields.csv"), + search_fields = read_csv("./data-raw/gbif_search_fields.csv"), ranks = tibble( id = seq_len(9), name = c("kingdom", "phylum", "class", @@ -130,3 +132,14 @@ use_data( gbif_internal_archived, internal = TRUE, overwrite = TRUE) + +# clean up +rm(galah_internal_archived, + galah_internal_cached, + gbif_internal_archived, + node_config, + node_metadata, + stored_types, + test_biocache, + test_lists, + use_test_system) \ No newline at end of file diff --git a/data-raw/gbif_fields.csv b/data-raw/gbif_fields.csv deleted file mode 100644 index a1c7615a..00000000 --- a/data-raw/gbif_fields.csv +++ /dev/null @@ -1,79 +0,0 @@ -id,description,type -basisOfRecord,"Basis of record, as defined in our BasisOfRecord enum",fields -catalogNumber,"An identifier of any form assigned by the source within a physical collection or digital dataset for the record which may not be unique, but should be fairly unique in combination with the institution and collection code.",fields -classKey,Class classification key.,fields -collectionCode,An identifier of any form assigned by the source to identify the physical collection or digital dataset uniquely within the context of an institution.,fields -continent,"Continent, as defined in our Continent enum",fields -coordinateUncertaintyInMeters,The horizontal distance (in meters) from the given decimalLatitude and decimalLongitude describing the smallest circle containing the whole of the Location. Supports range queries.,fields -country,The 2-letter country code (as per ISO-3166-1) of the country in which the occurrence was recorded.,fields -crawlId,Crawl attempt that harvested this record.,fields -datasetId,The ID of the dataset.,fields -datasetKey,The occurrence dataset key (a uuid).,fields -datasetName,The name of the dataset.,fields -decimalLatitude,Latitude in decimals between -90 and 90 based on WGS 84. Supports range queries.,fields -decimalLongitude,Longitude in decimals between -180 and 180 based on WGS 84. Supports range queries.,fields -depth,Depth in meters relative to altitude. For example 10 meters below a lake surface with given altitude. Supports range queries.,fields -elevation,Elevation (altitude) in meters above sea level. Supports range queries.,fields -establishmentMeans,"EstablishmentMeans, as defined in our EstablishmentMeans enum",fields -eventDate,"Occurrence date in ISO 8601 format: yyyy, yyyy-MM, yyyy-MM-dd, or MM-dd. Supports range queries.",fields -eventId,An identifier for the information associated with a sampling event.,fields -familyKey,Family classification key.,fields -fromDate,"Start partial date of a date range, accepts the format yyyy-MM, for example: 2015-11",fields -gadmGid,"A GADM geographic identifier at any level, for example AGO, AGO.1_1, AGO.1.1_1 or AGO.1.1.1_1",fields -gadmLevel,"A GADM region level, valid values range from 0 to 3",fields -gadmLevel0Gid,"A GADM geographic identifier at the zero level, for example AGO",fields -gadmLevel1Gid,"A GADM geographic identifier at the first level, for example AGO.1_1",fields -gadmLevel2Gid,"A GADM geographic identifier at the second level, for example AFG.1.1_1",fields -gadmLevel3Gid,"A GADM geographic identifier at the third level, for example AFG.1.1.1_1",fields -genusKey,Genus classification key.,fields -geoDistance,"Filters to match occurrence records with coordinate values within a specified distance of a coordinate, it supports units: in (inch), yd (yards), ft (feet), km (kilometers), mmi (nautical miles), mm (millimeters), cm centimeters, mi (miles), m (meters), for example /occurrence/search?geoDistance=90,100,5km",fields -hasCoordinate,Limits searches to occurrence records which contain a value in both latitude and longitude (i.e. hasCoordinate=true limits to occurrence records with coordinate values and hasCoordinate=false limits to occurrence records without coordinate values).,fields -hasGeospatialIssue,"Includes/excludes occurrence records which contain spatial issues (as determined in our record interpretation), i.e. hasGeospatialIssue=true returns only those records with spatial issues while hasGeospatialIssue=false includes only records without spatial issues. The absence of this parameter returns any record with or without spatial issues.",fields -identifiedBy,The person who provided the taxonomic identification of the occurrence.,fields -identifiedByID,Identifier (e.g. ORCID) for the person who provided the taxonomic identification of the occurrence.,fields -institutionCode,An identifier of any form assigned by the source to identify the institution the record belongs to. Not guaranteed to be unique.,fields -issue,A specific interpretation issue as defined in our OccurrenceIssue enum,fields -kingdomKey,Kingdom classification key.,fields -lastInterpreted,"This date the record was last modified in GBIF, in ISO 8601 format: yyyy, yyyy-MM, yyyy-MM-dd, or MM-dd. Supports range queries. Note that this is the date the record was last changed in GBIF, not necessarily the date the record was first/last changed by the publisher. Data is re-interpreted when we change the taxonomic backbone, geographic data sources, or interpretation processes.",fields -license,The type license applied to the dataset or record.,fields -limit,"The maximum number of results to return. This can't be greater than 300, any value greater is set to 300.",fields -locality,The specific description of the place.,fields -mediaType,The kind of multimedia associated with an occurrence as defined in our MediaType enum,fields -modified,"The most recent date-time on which the resource was changed, according to the publisher",fields -month,"The month of the year, starting with 1 for January. Supports range queries.",fields -networkKey,The GBIF Network to which the occurrence belongs.,fields -occurrenceId,A single globally unique identifier for the occurrence record as provided by the publisher.,fields -occurrenceStatus,Either 'ABSENT' or 'PRESENT'; the presence or absence of the occurrence.,fields -orderKey,Order classification key.,fields -organismId,An identifier for the Organism instance (as opposed to a particular digital record of the Organism). May be a globally unique identifier or an identifier specific to the data set.,fields -organismQuantity,A number or enumeration value for the quantity of organisms.,fields -organismQuantityType,The type of quantification system used for the quantity of organisms.,fields -otherCatalogNumbers,Previous or alternate fully qualified catalog numbers.,fields -phylumKey,Phylum classification key.,fields -preparations,Preparation or preservation method for a specimen.,fields -programme,"A group of activities, often associated with a specific funding stream, such as the GBIF BID programme.",fields -projectId,"The identifier for a project, which is often assigned by a funded programme.",fields -protocol,Protocol or mechanism used to provide the occurrence record.,fields -publishingCountry,The 2-letter country code (as per ISO-3166-1) of the owining organization's country.,fields -publishingOrg,The publishing organization key (a uuid).,fields -publishingOrgKey,The publishing organization key (a uuid).,fields -recordedBy,The person who recorded the occurrence.,fields -recordedByID,Identifier (e.g. ORCID) for the person who recorded the occurrence.,fields -recordNumber,An identifier given to the record at the time it was recorded in the field.,fields -relativeOrganismQuantity,The relative measurement of the quantity of the organism (i.e. without absolute units).,fields -repatriated,Searches for records whose publishing country is different to the country where the record was recorded in.,fields -sampleSizeUnit,"The unit of measurement of the size (time duration, length, area, or volume) of a sample in a sampling event.",fields -sampleSizeValue,"A numeric value for a measurement of the size (time duration, length, area, or volume) of a sample in a sampling event.",fields -samplingProtocol,"The name of, reference to, or description of the method or protocol used during a sampling event",fields -scientificName,"A scientific name from the GBIF backbone. All included and synonym taxa are included in the search. Under the hood a call to the species match service is done first to retrieve a taxonKey. Only unique scientific names will return results, homonyms (many monomials) return nothing! Consider to use the taxonKey parameter instead and the species match service directly",fields -speciesKey,Species classification key.,fields -stateProvince,"he name of the next smaller administrative region than country (state, province, canton, department, region, etc.) in which the Location occurs.",fields -subgenusKey,Subgenus classification key.,fields -taxonKey,"A taxon key from the GBIF backbone. All included and synonym taxa are included in the search, so a search for aves with taxonKey=212 (i.e. /occurrence/search?taxonKey=212) will match all birds, no matter which species.",fields -toDate,"End partial date of a date range, accepts the format yyyy-MM, for example: 2019-12",fields -typeStatus,"Nomenclatural type (type status, typified scientific name, publication) applied to the subject.",fields -userCountry,Country country of the user who made the requested,fields -verbatimScientificName,"The scientific name provided to GBIF by the data publisher, before interpretation and processing by GBIF.",fields -verbatimTaxonId,The taxon identifier provided to GBIF by the data publisher.,fields -waterBody,The name of the water body in which the Locations occurs.,fields -year,The 4 digit year. A year of 98 will be interpreted as AD 98. Supports range queries.,fields diff --git a/data-raw/gbif_search_fields.csv b/data-raw/gbif_search_fields.csv new file mode 100644 index 00000000..a844ba7e --- /dev/null +++ b/data-raw/gbif_search_fields.csv @@ -0,0 +1,127 @@ +id +acceptedTaxonKey +associatedSequences +basisOfRecord +bed +biostratigraphy +catalogNumber +checklistKey +classKey +collectionCode +collectionKey +continent +coordinateUncertaintyInMeters +country +crawlId +datasetId +datasetKey +datasetName +day +decimalLatitude +decimalLongitude +degreeOfEstablishment +depth +distanceFromCentroidInMeters +dnaSequenceId +dwcaExtension +earliestAgeOrLowestStage +earliestEonOrLowestEonothem +earliestEpochOrLowestSeries +earliestEraOrLowestErathem +earliestPeriodOrLowestSystem +elevation +endDayOfYear +establishmentMeans +eventDate +eventDateGte +eventId +familyKey +fieldNumber +formation +gadmGid +gadmLevel0Gid +gadmLevel1Gid +gadmLevel2Gid +gadmLevel3Gid +gbifId +gbifRegion +genusKey +geoDistance +geologicalTime +geometry +georeferencedBy +group +hasCoordinate +hasGeospatialIssue +higherGeography +highestBiostratigraphicZone +hostingOrganizationKey +identifiedBy +identifiedById +installationKey +institutionCode +institutionKey +isInCluster +isSequenced +island +islandGroup +issue +iucnRedListCategory +kingdomKey +lastInterpreted +latestAgeOrHighestStage +latestEonOrHighestEonothem +latestEpochOrHighestSeries +latestEraOrHighestErathem +latestPeriodOrHighestSystem +license +lifeStage +lithostratigraphy +locality +lowestBiostratigraphicZone +mediaType +member +modified +month +networkKey +occurrenceId +occurrenceStatus +orderKey +organismId +organismQuantity +organismQuantityType +otherCatalogNumbers +parentEventId +pathway +phylumKey +preparations +previousIdentifications +programme +projectId +protocol +publishedByGbifRegion +publishingCountry +publishingOrg +recordNumber +recordedBy +recordedById +relativeOrganismQuantity +repatriated +sampleSizeUnit +sampleSizeValue +samplingProtocol +scientificName +sex +speciesKey +startDayOfYear +stateProvince +subgenusKey +taxonConceptId +taxonId +taxonKey +taxonomicIssue +taxonomicStatus +typeStatus +verbatimScientificName +waterBody +year diff --git a/data-raw/node_config.csv b/data-raw/node_config.csv index f5d7f3fa..6213c730 100644 --- a/data-raw/node_config.csv +++ b/data-raw/node_config.csv @@ -7,9 +7,10 @@ Australia,data/occurrences-count-groupby,https://api.ala.org.au/occurrences/occu Australia,data/occurrences-doi,https://api.ala.org.au/doi/api/doi/{doi_string}/download,TRUE Australia,data/species,https://api.ala.org.au/occurrences/occurrences/facets/download,TRUE Australia,data/species-count,https://api.ala.org.au/occurrences/occurrences/facets,TRUE -Australia,files/media,https://api.ala.org.au/images/ws/image/{id}/original,TRUE +Australia,files/media,https://api.ala.org.au/images/image/{id}/{size},TRUE Australia,metadata/assertions,https://api.ala.org.au/occurrences/assertions/codes,TRUE Australia,metadata/collections,https://api.ala.org.au/metadata/ws/collection,TRUE +Australia,metadata/config,https://api.ala.org.au/common/api/getAuthConfig,TRUE Australia,metadata/datasets,https://api.ala.org.au/metadata/ws/dataResource,TRUE Australia,metadata/distributions,https://api.ala.org.au/spatial-service/distributions,FALSE Australia,metadata/fields,https://api.ala.org.au/occurrences/index/fields,TRUE @@ -18,7 +19,7 @@ Australia,metadata/identifiers,https://api.ala.org.au/namematching/api/getByTaxo Australia,metadata/licences,https://api.ala.org.au/images/ws/licence,TRUE Australia,metadata/lists,https://api.ala.org.au/specieslist/ws/speciesList,TRUE Australia,metadata/lists-unnest,https://api.ala.org.au/specieslist/ws/speciesListItems/{list_id},TRUE -Australia,metadata/media,https://api.ala.org.au/images/ws/getImageInfoForIdList,TRUE +Australia,metadata/media,https://api.ala.org.au/images/ws/image/{id},TRUE Australia,metadata/profiles,https://api.ala.org.au/dqf-service/api/v1/data-profiles?enabled=true,TRUE Australia,metadata/profiles-unnest,https://api.ala.org.au/dqf-service/api/v1/data-profiles/{profile},TRUE Australia,metadata/providers,https://api.ala.org.au/metadata/ws/dataProvider,TRUE @@ -31,6 +32,7 @@ Austria,data/occurrences-count,https://biocache.biodiversityatlas.at/ws/occurren Austria,data/occurrences-count-groupby,https://biocache.biodiversityatlas.at/ws/occurrence/facets,TRUE Austria,data/species,https://biocache.biodiversityatlas.at/ws/occurrences/facets/download,TRUE Austria,data/species-count,https://biocache.biodiversityatlas.at/ws/occurrence/facets,TRUE +Austria,files/media,https://images.biodiversityatlas.at/image/{id}/{size},TRUE Austria,metadata/assertions,https://biocache.biodiversityatlas.at/ws/assertions/codes,TRUE Austria,metadata/collections,https://collectory.biodiversityatlas.at/ws/collection,TRUE Austria,metadata/datasets,https://collectory.biodiversityatlas.at/ws/dataResource,TRUE @@ -39,7 +41,7 @@ Austria,metadata/fields-unnest,https://biocache.biodiversityatlas.at/ws/occurren Austria,metadata/licences,https://images.biodiversityatlas.at/ws/licence,TRUE Austria,metadata/lists,https://lists.biodiversityatlas.at/ws/speciesList/,TRUE Austria,metadata/lists-unnest,https://lists.biodiversityatlas.at/ws/speciesListItems/{list_id},TRUE -Austria,metadata/media,https://images.biodiversityatlas.at/ws/imageInfoForList,TRUE +Austria,metadata/media,https://images.biodiversityatlas.at/ws/image/{id},TRUE Austria,metadata/providers,https://collectory.biodiversityatlas.at/ws/dataProvider,TRUE Austria,metadata/reasons,https://logger.biodiversityatlas.at/service/logger/reasons,TRUE Austria,metadata/taxa-single,https://bie.biodiversityatlas.at/ws/search?q={name}&pageSize=5,TRUE @@ -49,15 +51,16 @@ Brazil,data/occurrences-count,https://biocache-service.sibbr.gov.br/biocache-ser Brazil,data/occurrences-count-groupby,https://biocache-service.sibbr.gov.br/biocache-service/occurrence/facets,TRUE Brazil,data/species,https://biocache-service.sibbr.gov.br/biocache-service/occurrences/facets/download,TRUE Brazil,data/species-count,https://biocache-service.sibbr.gov.br/biocache-service/occurrence/facets,TRUE +Brazil,files/media,https://images.sibbr.gov.br/image/{id}/{size},TRUE Brazil,metadata/assertions,https://biocache-service.sibbr.gov.br/biocache-service/assertions/codes,TRUE Brazil,metadata/collections,https://collectory.sibbr.gov.br/collectory/ws/collection,TRUE Brazil,metadata/datasets,https://collectory.sibbr.gov.br/collectory/ws/dataResource,TRUE Brazil,metadata/fields,https://biocache-service.sibbr.gov.br/biocache-service/index/fields,TRUE Brazil,metadata/fields-unnest,https://biocache-service.sibbr.gov.br/biocache-service/occurrence/facets,TRUE -Brazil,metadata/licences,https://images.sibbr.gov.br/images/ws/licence,TRUE +Brazil,metadata/licences,https://images.sibbr.gov.br/ws/licence,TRUE Brazil,metadata/lists,https://specieslist.sibbr.gov.br/ws/speciesList/,TRUE Brazil,metadata/lists-unnest,https://specieslist.sibbr.gov.br/ws/speciesListItems/{list_id},TRUE -Brazil,metadata/media,https://images.sibbr.gov.br/ws/getImageInfoForIdList,TRUE +Brazil,metadata/media,https://images.sibbr.gov.br/ws/image/details?id={id},TRUE Brazil,metadata/providers,https://collectory.sibbr.gov.br/collectory/ws/dataProvider,TRUE Brazil,metadata/taxa-single,https://bie-webservice.sibbr.gov.br/bie-index/search?q={name}&pageSize=5,TRUE Brazil,metadata/taxa-unnest,https://bie-webservice.sibbr.gov.br/bie-index/childConcepts/{id},TRUE @@ -73,26 +76,28 @@ Estonia,metadata/fields-unnest,https://elurikkus.ee/biocache-service/occurrence/ Estonia,metadata/providers,https://elurikkus.ee/collectory/ws/dataProvider,TRUE Estonia,metadata/taxa-single,https://elurikkus.ee/bie-index/search?q={name}&pageSize=5,TRUE Estonia,metadata/taxa-unnest,https://elurikkus.ee/bie-index/childConcepts/{id},TRUE -Flanders,data/metadata/fields-unnest,https://natuurdata.dev.inbo.be/biocache-service/occurrence/facets,TRUE -Flanders,data/occurrences,https://natuurdata.dev.inbo.be/biocache-service/occurrences/offline/download,TRUE -Flanders,data/occurrences-count,https://natuurdata.dev.inbo.be/biocache-service/occurrences/search,TRUE -Flanders,data/occurrences-count-groupby,https://natuurdata.dev.inbo.be/biocache-service/occurrence/facets,TRUE -Flanders,data/species,https://natuurdata.dev.inbo.be/biocache-service/occurrences/facets/download,TRUE -Flanders,data/species-count-,https://natuurdata.dev.inbo.be/biocache-service/occurrence/facets,TRUE -Flanders,files/media,https://natuurdata.dev.inbo.be/image-service/ws/image/{id}/original,TRUE -Flanders,metadata/assertions,https://natuurdata.dev.inbo.be/biocache-service/assertions/codes,TRUE -Flanders,metadata/collections,https://natuurdata.dev.inbo.be/collectory/ws/collection,TRUE -Flanders,metadata/datasets,https://natuurdata.dev.inbo.be/collectory/ws/dataResource,TRUE -Flanders,metadata/fields,https://natuurdata.dev.inbo.be/biocache-service/index/fields,TRUE -Flanders,metadata/licences,https://natuurdata.dev.inbo.be/image-service/ws/licence,TRUE -Flanders,metadata/lists,https://natuurdata.dev.inbo.be/species-list/ws/speciesList/,TRUE -Flanders,metadata/lists-unnest,https://natuurdata.dev.inbo.be/species-list/ws/speciesListItems/{list_id},TRUE -Flanders,metadata/media,https://natuurdata.dev.inbo.be/image-service/ws/getImageInfoForIdList,TRUE -Flanders,metadata/profiles,https://natuurdata.dev.inbo.be/dqf-service/api/v1/data-profiles/,TRUE -Flanders,metadata/profiles-unnest,https://natuurdata.dev.inbo.be/dqf-service/api/v1/quality/activeProfile?profileName={profile},TRUE -Flanders,metadata/providers,https://natuurdata.dev.inbo.be/collectory/ws/dataProvider,TRUE -Flanders,metadata/reasons,https://natuurdata.dev.inbo.be/logger/service/logger/reasons,TRUE -Flanders,metadata/taxa-single,https://api.gbif.org/v1/species/match?verbose=FALSE&name={name},TRUE +Flanders,data/occurrences,https://natuurdata.inbo.be/biocache-service/occurrences/offline/download,TRUE +Flanders,data/occurrences-count,https://natuurdata.inbo.be/biocache-service/occurrences/search,TRUE +Flanders,data/occurrences-count-groupby,https://natuurdata.inbo.be/biocache-service/occurrence/facets,TRUE +Flanders,data/species,https://natuurdata.inbo.be/biocache-service/occurrences/facets/download,TRUE +Flanders,data/species-count,https://natuurdata.inbo.be/biocache-service/occurrence/facets,TRUE +Flanders,files/media,https://natuurdata.inbo.be/image-service/image/{id}/{size},TRUE +Flanders,metadata/assertions,https://natuurdata.inbo.be/biocache-service/assertions/codes,TRUE +Flanders,metadata/collections,https://natuurdata.inbo.be/collectory/ws/collection,TRUE +Flanders,metadata/datasets,https://natuurdata.inbo.be/collectory/ws/dataResource,TRUE +Flanders,metadata/fields,https://natuurdata.inbo.be/biocache-service/index/fields,TRUE +Flanders,metadata/fields-unnest,https://natuurdata.inbo.be/biocache-service/occurrence/facets,TRUE +Flanders,metadata/identifiers,https://api.gbif.org/v1/species/{id},TRUE +Flanders,metadata/licences,https://natuurdata.inbo.be/image-service/ws/licence,TRUE +Flanders,metadata/lists,https://natuurdata.inbo.be/species-list/ws/speciesList/,TRUE +Flanders,metadata/lists-unnest,https://natuurdata.inbo.be/species-list/ws/speciesListItems/{list_id},TRUE +Flanders,metadata/media,https://natuurdata.inbo.be/image-service/ws/image/{id},TRUE +Flanders,metadata/profiles,https://natuurdata.inbo.be/data-quality-filter-service/api/v1/data-profiles,TRUE +Flanders,metadata/profiles-unnest,https://natuurdata.inbo.be/data-quality-filter-service/api/v1/data-profiles/{profile},TRUE +Flanders,metadata/providers,https://natuurdata.inbo.be/collectory/ws/dataProvider,TRUE +Flanders,metadata/reasons,https://natuurdata.inbo.be/logger/service/logger/reasons,TRUE +Flanders,metadata/taxa-single,https://api.gbif.org/v2/species/match?verbose=FALSE&scientificName={name},TRUE +Flanders,metadata/taxa-multiple,https://api.gbif.org/v2/species/match,TRUE Flanders,metadata/taxa-unnest,https://api.gbif.org/v1/species/{id}/children,TRUE France,data/occurrences,https://openobs.mnhn.fr/biocache-service/occurrences/offline/download,TRUE France,data/occurrences-count,https://openobs.mnhn.fr/biocache-service/occurrences/search,TRUE @@ -109,12 +114,17 @@ France,metadata/providers,https://openobs.mnhn.fr/api/datasets/providers,TRUE France,metadata/taxa-single,https://taxref.mnhn.fr/api/taxa/search?scientificNames={name}&page=1&size=5,TRUE France,metadata/taxa-unnest,https://taxref.mnhn.fr/api/taxa/{id}/children,TRUE Global,data/occurrences,https://api.gbif.org/v1/occurrence/download/request,TRUE -Global,data/occurrences-count,https://api.gbif.org/v1/occurrence/search,TRUE +Global,data/occurrences-doi,https://api.gbif.org/v1/occurrence/download/{doi_string},TRUE +Global,data/occurrences-count,https://api.gbif.org/v1/occurrence/search/predicate,TRUE +Global,data/occurrences-count-groupby,https://api.gbif.org/v1/occurrence/search/predicate,TRUE Global,metadata/collections,https://api.gbif.org/v1/grscicoll/collection,TRUE Global,metadata/datasets,https://api.gbif.org/v1/dataset,TRUE +Global,metadata/fields,https://api.gbif.org/v1/occurrence/term,TRUE Global,metadata/fields-unnest,https://api.gbif.org/v1/occurrence/search,TRUE +Global,metadata/identifiers,https://api.gbif.org/v1/species/{id},TRUE Global,metadata/providers,https://api.gbif.org/v1/organization,TRUE -Global,metadata/taxa-single,https://api.gbif.org/v1/species/match?verbose=FALSE&name={name},TRUE +Global,metadata/taxa-single,https://api.gbif.org/v2/species/match?verbose=FALSE&scientificName={name},TRUE +Global,metadata/taxa-multiple,https://api.gbif.org/v2/species/match,TRUE Global,metadata/taxa-unnest,https://api.gbif.org/v1/species/{id}/children,TRUE Global,,https://api.gbif.org/v1/grscicoll/search,TRUE Global,,https://api.gbif.org/v1/dataset/search,TRUE @@ -123,32 +133,54 @@ Guatemala,data/occurrences-count,https://snib.conap.gob.gt/registros-ws/occurren Guatemala,data/occurrences-count-groupby,https://snib.conap.gob.gt/registros-ws/occurrence/facets,TRUE Guatemala,data/species,https://snib.conap.gob.gt/registros-ws/occurrences/facets/download,FALSE Guatemala,data/species-count,https://snib.conap.gob.gt/registros-ws/occurrence/facets,TRUE +Guatemala,files/media,https://imagenes.snib.conap.gob.gt/image/{id}/{size},TRUE Guatemala,metadata/assertions,https://snib.conap.gob.gt/registros-ws/assertions/codes,TRUE Guatemala,metadata/collections,https://snib.conap.gob.gt/colecciones/ws/collection,TRUE Guatemala,metadata/datasets,https://snib.conap.gob.gt/colecciones/ws/dataResource,TRUE Guatemala,metadata/fields,https://snib.conap.gob.gt/registros-ws/index/fields,TRUE Guatemala,metadata/fields-unnest,https://snib.conap.gob.gt/registros-ws/occurrence/facets,TRUE Guatemala,metadata/licences,https://imagenes.snib.conap.gob.gt/licence,TRUE -Guatemala,metadata/media,https://imagenes.snib.conap.gob.gt/ws/imageInfoForList,TRUE +Guatemala,metadata/media,https://imagenes.snib.conap.gob.gt/ws/image/{id},TRUE Guatemala,metadata/providers,https://snib.conap.gob.gt/colecciones/ws/dataProvider,TRUE Guatemala,metadata/reasons,https://snib.conap.gob.gt/logger/service/logger/reasons,TRUE Guatemala,metadata/taxa-single,https://snib.conap.gob.gt/especies-ws/search?q={name}&pageSize=5,TRUE Guatemala,metadata/taxa-unnest,https://snib.conap.gob.gt/especies-ws/childConcepts/{id},TRUE +Kew,data/occurrences,https://records-ws.data.kew.org/occurrences/offline/download,TRUE +Kew,data/occurrences-count,https://records-ws.data.kew.org/occurrences/search,TRUE +Kew,data/occurrences-count-groupby,https://records-ws.data.kew.org/occurrences/facets,TRUE +Kew,data/species,https://records-ws.data.kew.org/occurrences/facets/download,TRUE +Kew,data/species-count,https://records-ws.data.kew.org/occurrences/facets,TRUE +Kew,files/media,https://images.data.kew.org/image/{id}/{size},TRUE +Kew,metadata/assertions,https://records-ws.data.kew.org/assertions/codes,TRUE +Kew,metadata/collections,https://collections.data.kew.org/ws/collection,TRUE +Kew,metadata/datasets,https://collections.data.kew.org/ws/dataResource,TRUE +Kew,metadata/fields,https://records-ws.data.kew.org/index/fields,TRUE +Kew,metadata/fields-unnest,https://records-ws.data.kew.org/occurrences/facets,TRUE +Kew,metadata/licences,https://images.data.kew.org/ws/licence,TRUE +Kew,metadata/lists,https://lists.data.kew.org/ws/speciesList,TRUE +Kew,metadata/lists-unnest,https://lists.data/kew.org/ws/speciesListItems/{list_id},TRUE +Kew,metadata/media,https://images.data.kew.org/ws/image/{id},TRUE +Kew,metadata/providers,https://collections.data.kew.org/ws/dataProvider,TRUE +Kew,metadata/reasons,https://logger.data.kew.org/service/logger/reasons,TRUE +Kew,metadata/taxa-single,https://species-ws.data.kew.org/search?q={name}&pageSize=5,TRUE +Kew,metadata/taxa-unnest,https://species-ws.data.kew.org/childConcepts/{id},TRUE Portugal,data/occurrences,https://registos-ws.gbif.pt/occurrences/offline/download,FALSE Portugal,data/occurrences-count,https://registos-ws.gbif.pt/occurrences/search,TRUE Portugal,data/occurrences-count-groupby,https://registos-ws.gbif.pt/occurrence/facets,TRUE Portugal,data/species,https://registos-ws.gbif.pt/occurrences/facets/download,FALSE Portugal,data/species-count,https://registos-ws.gbif.pt/occurrence/facets,TRUE +Portugal,files/media,https://imagens.gbif.pt/image/{id}/{size},TRUE Portugal,metadata/assertions,https://registos-ws.gbif.pt/assertions/codes,TRUE Portugal,metadata/collections,https://metadados.gbif.pt/ws/collection,TRUE Portugal,metadata/datasets,https://metadados.gbif.pt/ws/dataResource,TRUE Portugal,metadata/fields,https://registos-ws.gbif.pt/index/fields,TRUE Portugal,metadata/fields-unnest,https://registos-ws.gbif.pt/occurrence/facets,TRUE Portugal,metadata/licences,https://imagens.gbif.pt/ws/licence,TRUE -Portugal,metadata/media,https://imagens.gbif.pt/ws/imageInfoForList,TRUE +Portugal,metadata/media,https://imagens.gbif.pt/ws/image/{id},TRUE Portugal,metadata/providers,https://metadados.gbif.pt/ws/dataProvider,TRUE Portugal,metadata/reasons,https://logger.gbif.pt/service/logger/reasons,TRUE -Portugal,metadata/taxa-single,https://api.gbif.org/v1/species/match?verbose=FALSE&name={name},TRUE +Portugal,metadata/taxa-single,https://api.gbif.org/v2/species/match?verbose=FALSE&scientificName={name},TRUE +Portugal,metadata/taxa-multiple,https://api.gbif.org/v2/species/match,TRUE Portugal,metadata/taxa-unnest,https://api.gbif.org/v1/species/{id}/children,TRUE Spain,data/occurrences,https://registros-ws.gbif.es/occurrences/offline/download,TRUE Spain,data/occurrences-count,https://registros-ws.gbif.es/occurrences/search,TRUE @@ -156,6 +188,7 @@ Spain,data/occurrences-count-groupby,https://registros-ws.gbif.es/occurrence/fac Spain,data/occurrences-doi,https://doi.gbif.es/doi/{doi_string}/download,TRUE Spain,data/species,https://registros-ws.gbif.es/occurrences/facets/download,TRUE Spain,data/species-count,https://registros-ws.gbif.es/occurrence/facets,TRUE +Spain,files/media,https://imagenes.gbif.es/image/{id}/{size},TRUE Spain,metadata/assertions,https://registros-ws.gbif.es/assertions/codes,TRUE Spain,metadata/collections,https://colecciones.gbif.es/ws/collection,TRUE Spain,metadata/datasets,https://colecciones.gbif.es/ws/dataResource,TRUE @@ -165,7 +198,7 @@ Spain,metadata/identifiers,https://name-matching.gbif.es/api/getByTaxonID,TRUE Spain,metadata/licences,https://imagenes.gbif.es/ws/licence,TRUE Spain,metadata/lists,https://listas.gbif.es/ws/speciesList,TRUE Spain,metadata/lists-unnest,https://listas.gbif.es/ws/speciesListItems/{list_id},TRUE -Spain,metadata/media,https://imagenes.gbif.es/ws/getImageInfoForIdList,TRUE +Spain,metadata/media,https://imagenes.gbif.es/ws/image/details?id={id},TRUE Spain,metadata/profiles,https://data-quality.gbif.es/api/v1/data-profiles,TRUE Spain,metadata/profiles-unnest,https://data-quality.gbif.es/api/v1/quality/activeProfile?profileName={profile},TRUE Spain,metadata/providers,https://colecciones.gbif.es/ws/dataProvider,TRUE @@ -178,7 +211,7 @@ Sweden,data/occurrences-count,https://records.biodiversitydata.se/ws/occurrences Sweden,data/occurrences-count-groupby,https://records.biodiversitydata.se/ws/occurrence/facets,TRUE Sweden,data/species,https://records.biodiversitydata.se/ws/occurrences/facets/download,TRUE Sweden,data/species-count,https://records.biodiversitydata.se/ws/occurrence/facets,TRUE -Sweden,files/media,https://images.biodiversitydata.se/image/{id}/original,TRUE +Sweden,files/media,https://images.biodiversitydata.se/image/{id}/{size},TRUE Sweden,metadata/assertions,https://records.biodiversitydata.se/ws/assertions/codes,TRUE Sweden,metadata/collections,https://collections.biodiversitydata.se/ws/collection,TRUE Sweden,metadata/datasets,https://collections.biodiversitydata.se/ws/dataResource,TRUE @@ -188,7 +221,7 @@ Sweden,metadata/identifiers,https://namematching.biodiversitydata.se/api/getByTa Sweden,metadata/licences,https://images.biodiversitydata.se/ws/licence,TRUE Sweden,metadata/lists,https://lists.biodiversitydata.se/ws/speciesList,TRUE Sweden,metadata/lists-unnest,https://lists.biodiversitydata.se/ws/speciesListItems/{list_id},TRUE -Sweden,metadata/media,https://images.biodiversitydata.se/ws/getImageInfoForIdList,TRUE +Sweden,metadata/media,https://images.biodiversitydata.se/ws/image/{id},TRUE Sweden,metadata/profiles,https://data-quality-service.biodiversitydata.se/api/v1/data-profiles?enabled=true,TRUE Sweden,metadata/profiles-unnest,https://data-quality-service.biodiversitydata.se/api/v1/data-profiles/{profile},TRUE Sweden,metadata/providers,https://collections.biodiversitydata.se/ws/dataProvider,TRUE @@ -196,11 +229,12 @@ Sweden,metadata/reasons,https://logger.biodiversitydata.se/service/logger/reason Sweden,metadata/taxa-multiple,https://namematching.biodiversitydata.se/api/searchByClassification,TRUE Sweden,metadata/taxa-single,https://namematching.biodiversitydata.se/api/search?q={name},TRUE Sweden,metadata/taxa-unnest,https://species.biodiversitydata.se/ws/childConcepts/{id},TRUE -United Kingdom,data/occurrences,https://records-ws.nbnatlas.org/occurrences/index/download,TRUE +United Kingdom,data/occurrences,https://records-ws.nbnatlas.org/occurrences/offline/download,TRUE United Kingdom,data/occurrences-count,https://records-ws.nbnatlas.org/occurrences/search,TRUE United Kingdom,data/occurrences-count-groupby,https://records-ws.nbnatlas.org/occurrence/facets,TRUE United Kingdom,data/species,https://records-ws.nbnatlas.org/occurrences/facets/download,TRUE United Kingdom,data/species-count,https://records-ws.nbnatlas.org/occurrence/facets,TRUE +United Kingdom,files/media,https://images.nbnatlas.org/image/{id}/{size},TRUE United Kingdom,metadata/assertions,https://records-ws.nbnatlas.org/assertions/codes,TRUE United Kingdom,metadata/collections,https://registry.nbnatlas.org/ws/collection,TRUE United Kingdom,metadata/datasets,https://registry.nbnatlas.org/ws/dataResource,TRUE @@ -209,7 +243,7 @@ United Kingdom,metadata/fields-unnest,https://records-ws.nbnatlas.org/occurrence United Kingdom,metadata/licences,https://images.nbnatlas.org/licence,TRUE United Kingdom,metadata/lists,https://lists.nbnatlas.org/ws/speciesList,TRUE United Kingdom,metadata/lists-unnest,https://lists.nbnatlas.org/ws/speciesListItems/{list_id},TRUE -United Kingdom,metadata/media,https://images.nbnatlas.org/ws/getImageInfoForIdList,TRUE +United Kingdom,metadata/media,https://images.nbnatlas.org/ws/image/{id},TRUE United Kingdom,metadata/providers,https://registry.nbnatlas.org/ws/dataProvider,TRUE United Kingdom,metadata/reasons,https://logger.nbnatlas.org/service/logger/reasons,TRUE United Kingdom,metadata/taxa-single,https://species-ws.nbnatlas.org/search?q={name}&pageSize=5,TRUE diff --git a/data-raw/node_metadata.csv b/data-raw/node_metadata.csv index ae386881..583498cb 100644 --- a/data-raw/node_metadata.csv +++ b/data-raw/node_metadata.csv @@ -2,10 +2,11 @@ region,institution,acronym,url,supported Australia,Atlas of Living Australia,ALA,https://www.ala.org.au,TRUE Austria,Biodiversitäts-Atlas Österreich,BAO,https://biodiversityatlas.at,TRUE Brazil,Sistemas de Informações sobre a Biodiversidade Brasileira,SiBBr,https://sibbr.gov.br,TRUE -Flanders,Vlaams Biodiversiteitsportaal,VBP,https://natuurdata.dev.inbo.be,FALSE +Flanders,Vlaams Biodiversiteitsportaal,VBP,https://natuurdata.inbo.be,TRUE France,Portail français d'accès aux données d'observation sur les espèces,OpenObs,https://openobs.mnhn.fr,TRUE Global,Global Biodiversity Information Facility,GBIF,https://gbif.org,TRUE Guatemala,Sistema Nacional de Información sobre Diversidad Biológica de Guatemala,SNIBgt,https://snib.conap.gob.gt,TRUE +Kew,Kew Data Portal,KDP,https://data.kew.org,TRUE Portugal,GBIF Portugal,GBIF.pt,https://www.gbif.pt,TRUE Spain,GBIF Spain,GBIF.es,https://gbif.es,TRUE Sweden,Swedish Biodiversity Data Infrastructure,SBDI,https://biodiversitydata.se,TRUE @@ -21,4 +22,4 @@ Norway,Living Norway,LN,https://data.livingnorway.no/,FALSE Pacific,Pacific Biodiversity Information Facility,PBIF,https://pbif.sprep.org/,FALSE South Africa,South African National Biodiversity Institute,SANBI-GBIF,https://www.sanbi-gbif.org/,FALSE United States and Territories,GBIF US,GBIF.us,https://gbif.us/,FALSE -Vermont,Vermont Atlas of Life,VAL,https://val.vtecostudies.org,FALSE +Vermont,Vermont Atlas of Life,VAL,https://val.vtecostudies.org,FALSE \ No newline at end of file diff --git a/galah.Rproj b/galah.Rproj index 322289aa..3a76475c 100644 --- a/galah.Rproj +++ b/galah.Rproj @@ -1,5 +1,4 @@ Version: 1.0 -ProjectId: c8647342-9948-46f7-9a70-64f6631d1e2c RestoreWorkspace: Default SaveWorkspace: Default diff --git a/inst/CITATION b/inst/CITATION index de1ad268..2738f5f7 100644 --- a/inst/CITATION +++ b/inst/CITATION @@ -6,9 +6,9 @@ citHeader("To cite galah in publications use:") bibentry(bibtype = "Manual", "title" = "galah: Biodiversity Data from the GBIF Node Network", author = c(person("Martin", "Westgate"), - person("Dax", "Kellie"), - person("Matilda", "Stevenson"), - person("Peggy", "Newman")), + person("Dax", "Kellie"), + person("Shandiya", "Balasubramaniam"), + person("Matilda", "Stevenson")), year = year, note = note, url = "https://CRAN.R-project.org/package=galah") diff --git a/man/apply_profile.Rd b/man/apply_profile.Rd index 1e4ddf0a..db289227 100644 --- a/man/apply_profile.Rd +++ b/man/apply_profile.Rd @@ -17,7 +17,7 @@ of a data quality profile to apply to the query. Valid values can be seen using \code{show_all(profiles)}} } \value{ -An updated \code{data_request} with a completed \code{data_profile} slot. +An updated \code{data_request} with a completed \code{apply_profile} slot. } \description{ A 'profile' is a group of filters that are pre-applied by the ALA. Using a diff --git a/man/arrange.data_request.Rd b/man/arrange.data_request.Rd index f93a6c86..f8b1e693 100644 --- a/man/arrange.data_request.Rd +++ b/man/arrange.data_request.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/arrange.R +% Please edit documentation in R/dplyr-arrange.R \name{arrange.data_request} \alias{arrange.data_request} \alias{arrange.metadata_request} @@ -19,8 +19,6 @@ the variables also listed in \code{\link[=group_by.data_request]{group_by()}}.} An amended \code{data_request} with a completed \code{arrange} slot. } \description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} - \code{arrange.data_request()} arranges rows of a query on the server side, meaning that the query is constructed in such a way that information will be arranged when the query is processed. This only has an effect when used in combination diff --git a/man/atlas_.Rd b/man/atlas_.Rd index 9d69aca6..5980ccb8 100644 --- a/man/atlas_.Rd +++ b/man/atlas_.Rd @@ -15,7 +15,7 @@ atlas_occurrences( identify = NULL, filter = NULL, geolocate = NULL, - data_profile = NULL, + apply_profile = NULL, select = NULL, mint_doi = FALSE, doi = NULL, @@ -27,7 +27,7 @@ atlas_counts( identify = NULL, filter = NULL, geolocate = NULL, - data_profile = NULL, + apply_profile = NULL, group_by = NULL, limit = NULL, type = c("occurrences", "species") @@ -38,7 +38,7 @@ atlas_species( identify = NULL, filter = NULL, geolocate = NULL, - data_profile = NULL + apply_profile = NULL ) atlas_media( @@ -47,7 +47,8 @@ atlas_media( filter = NULL, select = NULL, geolocate = NULL, - data_profile = NULL + apply_profile = NULL, + all_fields = FALSE ) atlas_taxonomy( @@ -67,7 +68,7 @@ atlas_taxonomy( \item{geolocate}{\code{string}: generated by a call to \code{\link[=galah_geolocate]{galah_geolocate()}}} -\item{data_profile}{\code{string}: generated by a call to \code{\link[=galah_apply_profile]{galah_apply_profile()}}} +\item{apply_profile}{\code{string}: generated by a call to \code{\link[=galah_apply_profile]{galah_apply_profile()}}} \item{select}{\code{tibble}: generated by a call to \code{\link[=galah_select]{galah_select()}}} @@ -90,8 +91,11 @@ take a while.} \item{type}{\code{string}: one of \code{"occurrences"} or \code{"species"}. Defaults to \code{"occurrences"}, which returns the number of records that match the selected criteria; alternatively returns the number of -species. Formerly accepted arguments (\code{"records"} or \code{"species"}) are -deprecated but remain functional.} +species.} + +\item{all_fields}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} If \code{TRUE}, +\code{show_values()} also returns all columns available from the media metadata +API, rather than the 'default' columns traditionally provided via galah.} \item{constrain_ids}{\code{string}: Optional string to limit which \code{taxon_concept_id}'s are returned. This is useful for restricting taxonomy to particular diff --git a/man/authenticate.Rd b/man/authenticate.Rd new file mode 100644 index 00000000..e46788e6 --- /dev/null +++ b/man/authenticate.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/authenticate.R +\name{authenticate} +\alias{authenticate} +\title{Set up authentication} +\usage{ +authenticate(.data, cache_disk = FALSE) +} +\arguments{ +\item{.data}{An object of class \code{data_request} or \code{metadata_request}} + +\item{cache_disk}{(logical) Should JWT tokens be cached to disk? Defaults +to \code{FALSE}} +} +\value{ +An object of the same class as supplied, but with an added +\code{authenticate} slot. +} +\description{ +Add an authentication slot to a query. That slot is then used by later +code to determine whether to add an OAuth workflow. It is triggered +automatically within \code{\link[=capture]{capture()}} if the \code{authenticate} argument +of \code{\link[=galah_config]{galah_config()}} is set to \code{TRUE}, but only for occurrence queries +to the Atlas of Living Australia. +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}}. +} +\examples{ +\dontrun{ +# use `galah_config()` to set for all occurrence queries +galah_config(authenticate = TRUE) + +x <- galah_call() |> + identify("Wollemia nobilis") |> + collect() + +# use in-pipe for more control +x <- galah_call() |> + identify("Wollemia nobilis") |> + authenticate() |> + collect() +} +} diff --git a/man/capture.data_request.Rd b/man/capture.data_request.Rd new file mode 100644 index 00000000..db7e2247 --- /dev/null +++ b/man/capture.data_request.Rd @@ -0,0 +1,82 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/capture.R +\name{capture.data_request} +\alias{capture.data_request} +\alias{capture} +\alias{capture.metadata_request} +\alias{capture.files_request} +\alias{capture.list} +\title{Capture a request} +\usage{ +capture(x, ...) + +\method{capture}{data_request}(x, mint_doi = FALSE, ...) + +\method{capture}{metadata_request}(x, ...) + +\method{capture}{files_request}(x, thumbnail = FALSE, ...) + +\method{capture}{list}(x, ...) +} +\arguments{ +\item{x}{A \verb{_request} object to convert to a \code{prequery}.} + +\item{...}{Other arguments, currently ignored} + +\item{mint_doi}{Logical: should a DOI be minted for this download? Only +applies to \code{type = "occurrences"} when atlas chosen is "ALA".} + +\item{thumbnail}{Logical: should thumbnail-size images be returned? Defaults +to \code{FALSE}, indicating full-size images are required.} +} +\value{ +Either an object of class \code{prequery} when further processing is +required; or \code{query} when it is not. Both classes are structurally identical, +being list-like and containing at the following slots: +\itemize{ +\item \code{type}: The type of query, serves as a lookup to the corresponding field in \code{show_all(apis)} +\item \code{url}: Either: +\itemize{ +\item a length-1 character giving the API to be queried; or +\item a \code{tibble()} containing at least the field \code{url} and optionally others +} +\item \code{request}: captures the preceeding \verb{_request} object (see \code{\link[=galah_call]{galah_call()}}) +} +} +\description{ +The first step in evaluating a request is to capture and parse the +information it contains. The resulting object has class \code{prequery} +for those requiring further processing or \code{query} for those that don't. +A \code{prequery} object shows the basic structure of what has been requested by +a user in a given \code{\link[=galah_call]{galah_call()}}. +} +\details{ +\code{galah} uses an object-based pipeline to convert piped requests into +valid queries, and to enact those queries with the specified organisation. +Typically, requests open with \code{\link[=galah_call]{galah_call()}} - though \code{\link[=request_metadata]{request_metadata()}} +and \code{\link[=request_files]{request_files()}} are also valid - and end with +\code{\link[=collect.data_request]{collect()}}. Under the hood, +the sequence of functions is as follows: + +\code{\link[=capture]{capture()}} → \code{\link[=compound]{compound()}} → +\code{\link[=collapse.data_request]{collapse()}} → +\code{\link[=compute.data_request]{compute()}} → +\code{\link[=collect.data_request]{collect()}} + +\code{\link[=capture]{capture()}} is the first of the \code{\link[=galah_call]{galah_call()}} workflow, and it parses the +basic structure of a user request, returned as a \code{prequery} object. +A \code{prequery} object shows what has been requested, before those +calls are built by \code{\link[=compound]{compound()}} and evaluated by +\code{\link[=collapse.data_request]{collapse()}}. +For simple cases, this gives the same result as running +\code{\link[=collapse.data_request]{collapse()}} while the \code{run_checks} +argument of \code{\link[=galah_config]{galah_config()}} is set to \code{FALSE}, but is slightly faster. +In complex cases, it is simply a precursor to \code{\link[=compound]{compound()}}. +} +\seealso{ +To open a piped query, see \code{\link[=galah_call]{galah_call()}}. For alternative +operations on \verb{_request} objects, see \code{\link[=compound]{compound()}}, +\code{\link[=collapse.data_request]{collapse()}}, +\code{\link[=compute.data_request]{compute()}} or +\code{\link[=collect.data_request]{collect()}}. +} diff --git a/man/collapse.data_request.Rd b/man/collapse.data_request.Rd index aa8801cd..018842f3 100644 --- a/man/collapse.data_request.Rd +++ b/man/collapse.data_request.Rd @@ -1,45 +1,82 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/collapse.R +% Please edit documentation in R/dplyr-collapse.R \name{collapse.data_request} \alias{collapse.data_request} \alias{collapse.metadata_request} \alias{collapse.files_request} +\alias{collapse.prequery} +\alias{collapse.query} +\alias{collapse.query_set} \title{Generate a query} \usage{ -\method{collapse}{data_request}(x, ..., mint_doi, .expand = FALSE) +\method{collapse}{data_request}(x, ...) -\method{collapse}{metadata_request}(x, .expand = FALSE, ...) +\method{collapse}{metadata_request}(x, ...) -\method{collapse}{files_request}(x, thumbnail = FALSE, ...) -} -\arguments{ -\item{x}{An object of class \code{data_request}, \code{metadata_request} or -\code{files_request}} +\method{collapse}{files_request}(x, ...) -\item{...}{Arguments passed on to other methods} +\method{collapse}{prequery}(x, ...) -\item{mint_doi}{Logical: should a DOI be minted for this download? Only -applies to \code{type = "occurrences"} when atlas chosen is "ALA".} +\method{collapse}{query}(x, ...) -\item{.expand}{Logical: should the \code{query_set} be returned? This object -shows all the requisite data needed to process the supplied query. Defaults -to \code{FALSE}; if \code{TRUE} will append the \code{query_set} to an extra slot in the -\code{query} object.} +\method{collapse}{query_set}(x, ...) +} +\arguments{ +\item{x}{An object to run \code{collapse()} on. Classes supported by \code{galah} +include \code{data_request}, \code{metadata_request} and \code{files_request} for building +queries; and \code{prequery}, \code{query} or \code{query_set} once constructed (via +\code{\link[=capture]{capture()}} or \code{\link[=compound]{compound()}}).} -\item{thumbnail}{Logical: should thumbnail-size images be returned? Defaults -to \code{FALSE}, indicating full-size images are required.} +\item{...}{Arguments passed on to \code{\link[=capture]{capture()}}.} } \value{ -An object of class \code{query}, which is a list-like object containing at -least the slots \code{type} and \code{url}. +An object of class \code{query}, which is a list-like object containing +two or more of the following slots: +\itemize{ +\item \code{type}: The type of query, serves as a lookup to the corresponding field in \code{show_all(apis)} +\item \code{url}: Either: +\itemize{ +\item a length-1 character giving the API to be queried; or +\item a \code{tibble} containing at least the field \code{url} and optionally others +} +\item \code{headers}: headers to be sent with the API call +\item \code{body}: body section of the API call +\item \code{options}: options section of the API call +\item \code{request}: captures the supplied \verb{_request} object (see \code{\link[=galah_call]{galah_call()}}) +} } \description{ -\code{collapse()} constructs a valid query so it can be -inspected before being sent. It typically occurs at the end of a pipe, -traditionally begun with \code{galah_call()}, that is used to define a query. -As of version 2.0, objects of class \code{data_request} (created using -\code{request_data()}), \code{metadata_request} (from \code{request_metadata()}) or -\code{files_request} (from \code{request_files()}) are all supported by \code{collapse()}. -Any of these objects can be created using \code{galah_call()} via the \code{method} -argument. +Constructs a query so it can be inspected before being sent. \code{collapse()} can +be called at the end of a pipe that begins with \code{\link[=galah_call]{galah_call()}} to return the +constructed user query generated by the user's data request +(a \code{query} object). Objects +of class \code{data_request} (created using \code{\link[=request_data]{request_data()}}), \code{metadata_request} +(from \code{\link[=request_metadata]{request_metadata()}}) or \code{files_request} (from \code{\link[=request_files]{request_files()}}) are +all supported. +} +\details{ +\code{galah} uses an object-based pipeline to convert piped requests into +valid queries, and to enact those queries with the specified organisation. +Typically, requests open with \code{\link[=galah_call]{galah_call()}} - though \code{\link[=request_metadata]{request_metadata()}} +and \code{\link[=request_files]{request_files()}} are also valid - and end with +\code{\link[=collect.data_request]{collect()}}. Under the hood, +the sequence of functions is as follows: + +\code{\link[=capture]{capture()}} → \code{\link[=compound]{compound()}} → +\code{\link[=collapse.data_request]{collapse()}} → +\code{\link[=compute.data_request]{compute()}} → +\code{\link[=collect.data_request]{collect()}} + +\code{\link[=collapse.data_request]{collapse()}} constructs a complete +user query, ready to be sent by +\code{\link[=compute.data_request]{compute()}}. +Information required to construct a complete user query are +provided by \code{\link[=capture]{capture()}} and \code{\link[=compound]{compound()}}, preceding functions to +parse and combine all required API calls necessary to build a user's query. +} +\seealso{ +To open a piped query, see \code{\link[=galah_call]{galah_call()}}. For alternative +operations on \verb{_request} objects, see \code{\link[=capture]{capture()}}, \code{\link[=compound]{compound()}}, +\code{\link[=compute.data_request]{compute()}} or +\code{\link[=collect.data_request]{collect()}}. } diff --git a/man/collect.data_request.Rd b/man/collect.data_request.Rd index 9b6faf07..6ee2ad06 100644 --- a/man/collect.data_request.Rd +++ b/man/collect.data_request.Rd @@ -1,10 +1,12 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/collect.R +% Please edit documentation in R/dplyr-collect.R \name{collect.data_request} \alias{collect.data_request} \alias{collect.metadata_request} \alias{collect.files_request} +\alias{collect.prequery} \alias{collect.query} +\alias{collect.query_set} \alias{collect.computed_query} \title{Retrieve a database query} \usage{ @@ -14,18 +16,24 @@ \method{collect}{files_request}(x, ...) -\method{collect}{query}(x, ..., wait = TRUE, file = NULL) +\method{collect}{prequery}(x, ...) + +\method{collect}{query}(x, ...) + +\method{collect}{query_set}(x, ..., wait = TRUE, file = NULL) \method{collect}{computed_query}(x, ..., wait = TRUE, file = NULL) } \arguments{ \item{x}{An object of class \code{data_request}, \code{metadata_request} or -\code{files_request} (from \code{galah_call()}); or an object of class \code{query_set} or -\code{query} (from \code{collapse()} or \code{compute()})} +\code{files_request} (from \code{galah_call()}); or an object of class \code{prequery}, +\code{query_set} or \code{query} (from \code{\link[=capture]{capture()}}, +\code{\link[=collapse.data_request]{collapse()}} +or \code{\link[=compute.data_request]{compute()}})} \item{...}{Arguments passed on to other methods} -\item{wait}{logical; should \code{galah} wait for a response? Defaults to FALSE. +\item{wait}{logical; should \code{galah} wait for a response? Defaults to \code{FALSE}. Only applies for \code{type = "occurrences"} or \code{"species"}.} \item{file}{(Optional) file name. If not given, will be set to \code{data} with @@ -39,6 +47,29 @@ data. Where the requested data are not yet ready (i.e. for occurrences when that can be used to recheck the download at a later time. } \description{ -\code{collect()} attempts to retrieve the result of a query from the -selected API. +Retrieve the result of a query from the server. It is the +default way to end a piped query that begins with \code{\link[=galah_call]{galah_call()}}. +} +\details{ +\code{galah} uses an object-based pipeline to convert piped requests into +valid queries, and to enact those queries with the specified organisation. +Typically, requests open with \code{\link[=galah_call]{galah_call()}} - though \code{\link[=request_metadata]{request_metadata()}} +and \code{\link[=request_files]{request_files()}} are also valid - and end with +\code{\link[=collect.data_request]{collect()}}. Under the hood, +the sequence of functions is as follows: + +\code{\link[=capture]{capture()}} → \code{\link[=compound]{compound()}} → +\code{\link[=collapse.data_request]{collapse()}} → +\code{\link[=compute.data_request]{compute()}} → +\code{\link[=collect.data_request]{collect()}} + +\code{\link[=collect.data_request]{collect()}} is the final step of the +\code{\link[=galah_call]{galah_call()}} workflow, and it retrieves the result of a +query once it is processed by the server. +} +\seealso{ +To open a piped query, see \code{\link[=galah_call]{galah_call()}}. For alternative +operations on \verb{_request} objects, see \code{\link[=capture]{capture()}}, \code{\link[=compound]{compound()}}, +\code{\link[=collapse.data_request]{collapse()}} or +\code{\link[=compute.data_request]{compute()}}. } diff --git a/man/collect_media.Rd b/man/collect_media.Rd index a2e70cf7..7d67b54a 100644 --- a/man/collect_media.Rd +++ b/man/collect_media.Rd @@ -4,7 +4,7 @@ \alias{collect_media} \title{Collect media files} \usage{ -collect_media(df, thumbnail = FALSE, path) +collect_media(df, thumbnail = FALSE) } \arguments{ \item{df}{A \code{tibble} returned by \code{atlas_media()} or a pipe starting with @@ -12,10 +12,6 @@ collect_media(df, thumbnail = FALSE, path) \item{thumbnail}{Default is \code{FALSE}. If \code{TRUE} will download small thumbnail-sized images, rather than full size images (default).} - -\item{path}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} -Use \verb{galah_config(directory = "path-to-directory)"} instead. Supply a path -to a local folder/directory where downloaded media will be saved to.} } \value{ Invisibly returns a \code{tibble} listing the number of files downloaded, diff --git a/man/compound.Rd b/man/compound.Rd new file mode 100644 index 00000000..3b23dc04 --- /dev/null +++ b/man/compound.Rd @@ -0,0 +1,78 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/compound.R +\name{compound} +\alias{compound} +\alias{compound.data_request} +\alias{compound.metadata_request} +\alias{compound.files_request} +\alias{compound.prequery} +\alias{compound.query} +\alias{compound.query_set} +\title{Force evaluation of a database query} +\usage{ +compound(x, ...) + +\method{compound}{data_request}(x, mint_doi = FALSE, ...) + +\method{compound}{metadata_request}(x, ...) + +\method{compound}{files_request}(x, ...) + +\method{compound}{prequery}(x, mint_doi = FALSE, ...) + +\method{compound}{query}(x, ...) + +\method{compound}{query_set}(x, ...) +} +\arguments{ +\item{x}{An object to be compounded. Works for \code{data_request}, +\code{metadata_request}, \code{file_request}, \code{query} or \code{prequery}.} + +\item{...}{Other arguments passed to \code{\link[=capture]{capture()}}.} + +\item{mint_doi}{Logical: should a DOI be minted for this download? Only +applies to \code{type = "occurrences"}, and only for supported atlases.} +} +\value{ +An object of class \code{query_set}, which is simply a list of all \code{query} +objects required to properly evaluate the specified request. Objects are +listed in the order in which they will be evaluated, meaning the query +that the user has actually requested will be placed last. +} +\description{ +\code{\link[=compound]{compound()}} shows the full set of queries +required to properly evaluate the user's request, run prior to \code{\link[=collapse]{collapse()}}. + +The number of total queries to send for a single data request is often broader +than the single query returned by \code{\link[=collapse]{collapse()}}. If, for example, +the user's query includes a call to +\code{\link[=identify.data_request]{identify()}}, then a taxonomic query +is required to run \emph{before} the 'final' query is attempted. In relation to +other functions that manipulate \verb{_request} objects, \code{\link[=compound]{compound()}} is called +within \code{\link[=collapse.data_request]{collapse()}}, and itself +calls \code{\link[=capture]{capture()}} internally where required. +} +\details{ +\code{galah} uses an object-based pipeline to convert piped requests into +valid queries, and to enact those queries with the specified organisation. +Typically, requests open with \code{\link[=galah_call]{galah_call()}} - though \code{\link[=request_metadata]{request_metadata()}} +and \code{\link[=request_files]{request_files()}} are also valid - and end with +\code{\link[=collect.data_request]{collect()}}. Under the hood, +the sequence of functions is as follows: + +\code{\link[=capture]{capture()}} → \code{\link[=compound]{compound()}} → +\code{\link[=collapse.data_request]{collapse()}} → +\code{\link[=compute.data_request]{compute()}} → +\code{\link[=collect.data_request]{collect()}} + +\code{\link[=compound]{compound()}} is the second of the \code{\link[=galah_call]{galah_call()}} workflow, and it collates +the complete list of queries required to send in order to meet the user's +data request, returned by \code{\link[=collapse.data_request]{collapse()}}. +} +\seealso{ +To open a piped query, see \code{\link[=galah_call]{galah_call()}}. For alternative +operations on \verb{_request} objects, see \code{\link[=capture]{capture()}}, +\code{\link[=collapse.data_request]{collapse()}}, +\code{\link[=compute.data_request]{compute()}} or +\code{\link[=collect.data_request]{collect()}}. +} diff --git a/man/compute.data_request.Rd b/man/compute.data_request.Rd index 324ecba9..196677f2 100644 --- a/man/compute.data_request.Rd +++ b/man/compute.data_request.Rd @@ -1,10 +1,12 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/compute.R +% Please edit documentation in R/dplyr-compute.R \name{compute.data_request} \alias{compute.data_request} \alias{compute.metadata_request} \alias{compute.files_request} +\alias{compute.prequery} \alias{compute.query} +\alias{compute.query_set} \title{Compute a query} \usage{ \method{compute}{data_request}(x, ...) @@ -13,12 +15,16 @@ \method{compute}{files_request}(x, ...) +\method{compute}{prequery}(x, ...) + \method{compute}{query}(x, ...) + +\method{compute}{query_set}(x, ...) } \arguments{ \item{x}{An object of class \code{data_request}, \code{metadata_request} or \code{files_request} (i.e. constructed using a pipe) or \code{query} -(i.e. constructed by \code{collapse()})} +(i.e. constructed by \code{\link[=collapse.data_request]{collapse()}})} \item{...}{Arguments passed on to other methods} } @@ -28,7 +34,40 @@ An object of class \code{computed_query}, which is identical to class status of the request. } \description{ -\code{compute()} is useful for several purposes. It's original -purpose is to send a request for data, which can then be processed by the -server and retrieved at a later time (via \code{collect()}). +Sends a request for information to a server. This is useful +for requests that run a server-side process, as it separates the +submission of the request from its retrieval. + +Within galah, \code{compute()} is generally hidden as it is one part of the overall +process to complete a \code{data_request}, +\code{metadata_request} or \code{file_request}. However, calling +\code{\link[=compute.data_request]{compute()}} at the +end of a \code{\link[=galah_call]{galah_call()}} sends a request to be completed server-side +(i.e., outside of R), and the result can be returned in R by +calling \code{\link[=collect.data_request]{collect()}} +at a later time. This can be preferable to calling \code{\link[=atlas_occurrences]{atlas_occurrences()}}, which +prevents execution of new code until the server-side process is complete. +} +\details{ +\code{galah} uses an object-based pipeline to convert piped requests into +valid queries, and to enact those queries with the specified organisation. +Typically, requests open with \code{\link[=galah_call]{galah_call()}} - though \code{\link[=request_metadata]{request_metadata()}} +and \code{\link[=request_files]{request_files()}} are also valid - and end with +\code{\link[=collect.data_request]{collect()}}. Under the hood, +the sequence of functions is as follows: + +\code{\link[=capture]{capture()}} → \code{\link[=compound]{compound()}} → +\code{\link[=collapse.data_request]{collapse()}} → +\code{\link[=compute.data_request]{compute()}} → +\code{\link[=collect.data_request]{collect()}} + +\code{\link[=compute.data_request]{compute()}} sends a query to a server, +which, once completed, can be retrieved using +\code{\link[=collect.data_request]{collect()}}. +} +\seealso{ +To open a piped query, see \code{\link[=galah_call]{galah_call()}}. For alternative +operations on \verb{_request} objects, see \code{\link[=capture]{capture()}}, \code{\link[=compound]{compound()}}, +\code{\link[=collapse.data_request]{collapse()}}, +\code{\link[=collect.data_request]{collect()}}. } diff --git a/man/count.data_request.Rd b/man/count.data_request.Rd index f6ae9705..d8023163 100644 --- a/man/count.data_request.Rd +++ b/man/count.data_request.Rd @@ -1,10 +1,13 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/count-data_request.R +% Please edit documentation in R/dplyr-count.R \name{count.data_request} \alias{count.data_request} +\alias{add_count.data_request} \title{Count the observations in each group} \usage{ \method{count}{data_request}(x, ..., wt, sort, name) + +\method{add_count}{data_request}(x, ..., wt = NULL, sort = FALSE, name = NULL) } \arguments{ \item{x}{An object of class \code{data_request}, created using \code{\link[=galah_call]{galah_call()}}} @@ -19,5 +22,6 @@ } \description{ \code{count()} lets you quickly count the unique values of one or more variables. -It is evaluated lazily. +It is evaluated lazily. \code{add_count()} is an equivalent that uses \code{mutate()} +to add a new column with group-wise counts. } diff --git a/man/distinct.data_request.Rd b/man/distinct.data_request.Rd new file mode 100644 index 00000000..5d51215c --- /dev/null +++ b/man/distinct.data_request.Rd @@ -0,0 +1,133 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/dplyr-distinct.R +\name{distinct.data_request} +\alias{distinct.data_request} +\title{Keep distinct/unique rows} +\usage{ +\method{distinct}{data_request}(.data, ..., .keep_all = FALSE) +} +\arguments{ +\item{.data}{A data frame, data frame extension (e.g. a tibble), or a +lazy data frame (e.g. from dbplyr or dtplyr). See Methods, below, +for more details.} + +\item{...}{Variables to use when determining uniqueness. Unlike the \code{dplyr} +implementation this must be set for the function to do anything, and only +a single variable is used.} + +\item{.keep_all}{If \code{TRUE}, keep all variables in .data. Defaults to +\code{FALSE}} +} +\description{ +Keep only unique/distinct rows from a data frame. This is similar to +\code{\link[=unique.data.frame]{unique.data.frame()}} but considerably faster. It is evaluated lazily. +} +\details{ +This function has several potential uses. In it's default mode, it simply +shows the unique values for a supplied field: + +\preformatted{galah_call() |> + distinct(basisOfRecord) |> + collect() + +# A tibble: 9 × 1 + basisOfRecord + +1 HUMAN_OBSERVATION +2 PRESERVED_SPECIMEN +3 OCCURRENCE +4 MACHINE_OBSERVATION +5 OBSERVATION +6 MATERIAL_SAMPLE +7 LIVING_SPECIMEN +8 FOSSIL_SPECIMEN +9 MATERIAL_CITATION +} + +This is the same result as you would get using \code{\link[=show_values]{show_values()}}: + +\preformatted{search_all(fields, "basisOfRecord") |> + show_values()} + +Using \code{\link[=distinct]{distinct()}} is somewhat more reliable, however, as it doesn't rely +on searching the tibble returned by \code{show_all(fields)}. It is also more +efficient, particularly when caching is turned off. If the goal is to +retrieve the \emph{number} of levels of a factor, use: + +\preformatted{galah_call() |> + distinct(basisOfRecord) |> + count() |> + collect() + +# A tibble: 1 × 1 + count + +1 9 +} + +When the variable passed to \code{\link[=distinct]{distinct()}} in the above example is +\code{speciesID}, this is identical to calling: + +\preformatted{atlas_counts(type = "species")} + +You can also pass \code{\link[=group_by.data_request]{group_by()}} +to find the number of facets per level of a second variable: + +\preformatted{galah_call() |> + identify("Perameles") |> + distinct(speciesID) |> + group_by(basisOfRecord) |> + count() |> + collect() + +# A tibble: 8 × 2 + basisOfRecord count + +1 Human observation 7 +2 Preserved specimen 9 +3 Machine observation 2 +4 Observation 3 +5 Occurrence 3 +6 Material Sample 4 +7 Fossil specimen 1 +8 Living specimen 1 +} + +By setting \code{.keep_all = TRUE}, we get more information on each record. +Due to limits on the APIs this is not a perfect analogy for running +\code{\link[dplyr:distinct]{dplyr::distinct()}} on raw occurrences; but it does allow us to +generalise \code{\link[=atlas_species]{atlas_species()}} to use any taxonomic identifier. For example, +we might choose to show data by family instead of species: + +\preformatted{galah_call() |> + identify("Coleoptera") |> + distinct(familyID, .keep_all = TRUE) |> + collect()} + +Using \code{\link[=group_by]{group_by()}} is also valid: + +\preformatted{galah_call() |> + filter(year == 2024, + genus == "Crinia") |> + group_by(speciesID) |> + distinct(.keep_all = TRUE) |> + collapse()} + +In this case, \code{\link[=collect.data_request]{collect()}} and +\code{\link[=atlas_species]{atlas_species()}} are synonymous, with the exception that the latter +does not require you to set the \code{.keep_all} argument to \code{TRUE}. So you +could instead use: + +\preformatted{galah_call() |> + identify("Coleoptera") |> + distinct(familyID) |> + atlas_species()} +} +\examples{ +\dontrun{ +galah_call() |> + distinct(basisOfRecord) |> + count() |> + collect() +} +} diff --git a/man/figures/atlases_plot.png b/man/figures/atlases_plot.png index b7560304..d5e88e4f 100644 Binary files a/man/figures/atlases_plot.png and b/man/figures/atlases_plot.png differ diff --git a/man/filter.data_request.Rd b/man/filter.data_request.Rd index f4fb1ddc..dbcde5c2 100644 --- a/man/filter.data_request.Rd +++ b/man/filter.data_request.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/galah_filter.R +% Please edit documentation in R/dplyr-filter.R, R/galah_filter.R \name{filter.data_request} \alias{filter.data_request} \alias{filter.metadata_request} @@ -13,7 +13,7 @@ \method{filter}{files_request}(.data, ...) -galah_filter(..., profile = NULL) +galah_filter(...) } \arguments{ \item{.data}{An object of class \code{data_request}, \code{metadata_request} @@ -23,9 +23,6 @@ or \code{files_request}, created using \code{\link[=galah_call]{galah_call()}} o of the variables in the selected atlas (and checked using \code{show_all(fields)}. If multiple expressions are included, they are combined with the & operator. Only rows for which all conditions evaluate to \code{TRUE} are kept.} - -\item{profile}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} -Use \code{galah_apply_profile} instead.} } \value{ A tibble containing filter values. @@ -41,8 +38,8 @@ by \code{collect()} or one of the \code{atlas_} family of functions (such as \details{ \emph{Syntax} -\code{filter.data_request()} and \code{galah_filter()} uses non-standard evaluation -(NSE), and are designed to be as compatible as possible with +\code{filter()} uses non-standard evaluation +(NSE), and is designed to be as compatible as possible with \code{dplyr::filter()} syntax. Permissible examples include: \itemize{ \item \code{==} (e.g. \code{year = 2020}) but not \code{=} (for consistency with \code{dplyr}) @@ -105,22 +102,31 @@ should begin with an occurrence query: collect()} They can then use the \code{media} field to request media metadata: -\preformatted{media_metadata <- galah_call("metadata") |> +\preformatted{media_metadata <- request_metadata |> filter(media == occurrences) |> collect()} And finally, the metadata tibble can be used to request files: -\preformatted{galah_call("files") |> +\preformatted{request_files() |> filter(media == media_metadata) |> collect()} } \examples{ \dontrun{ +# basic example galah_call() |> filter(year >= 2019, basisOfRecord == "HumanObservation") |> count() |> collect() + +# Field names can be parsed from objects using `{{}}` syntax, e.g. +field <- "year" +value <- "2025" +galah_call() |> + filter({{field}} == value) |> + count() |> + collect() } } \seealso{ diff --git a/man/filter_object_classes.Rd b/man/filter_object_classes.Rd new file mode 100644 index 00000000..548920de --- /dev/null +++ b/man/filter_object_classes.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/filter_object_classes.R +\name{filter_object_classes} +\alias{filter_object_classes} +\alias{as_data_filter} +\alias{as_predicates_filter} +\alias{as_metadata_filter} +\alias{as_files_filter} +\alias{print.data_filter} +\alias{print.predicates_filter} +\alias{print.metadata_filter} +\alias{print.files_filter} +\title{Object classes for \code{filter()} queries} +\usage{ +as_data_filter(x) + +as_predicates_filter(x) + +as_metadata_filter(x) + +as_files_filter(x) + +\method{print}{data_filter}(x, ...) + +\method{print}{predicates_filter}(x, ...) + +\method{print}{metadata_filter}(x, ...) + +\method{print}{files_filter}(x, ...) +} +\arguments{ +\item{x}{a list, or object of supported class} + +\item{...}{Additional arguments, currently ignored} +} +\description{ +In galah, there are several ways to provide filter information. To ensure +these are handled and printed correctly, they are assigned classes +} diff --git a/man/galah.Rd b/man/galah.Rd index 15076889..5ce4c2b0 100644 --- a/man/galah.Rd +++ b/man/galah.Rd @@ -8,9 +8,9 @@ \description{ The Global Biodiversity Information Facility (GBIF; \url{https://www.gbif.org}) provides tools to enable users to find, access, combine and visualise -biodiversity data. \code{galah} enables the R community to directly access data and -resources hosted by GBIF and several of it's subsidiary organisations, known -as 'nodes'. +biodiversity data. \code{galah} is a \code{dplyr} extension package that enables the R +community to directly access data and resources hosted by GBIF and several +of it's subsidiary organisations (known as 'nodes') using \code{dplyr} verbs. The basic unit of data stored by these infrastructures is an \strong{occurrence} record, which is an observation of a biological entity at @@ -28,33 +28,46 @@ For those outside Australia, 'galah' is the common name of \strong{Getting Started} \itemize{ -\item \code{\link[=galah_call]{galah_call()}}/\code{\link[=request_data]{request_()}} Start to build a query \item \code{\link[=galah_config]{galah_config()}} Set package configuration options -\item \code{\link[=show_all]{show_all()}} & \code{\link[=search_all]{search_all()}} Data for generating filter queries -\item \code{\link[=show_values]{show_values()}} & \code{\link[=search_values]{search_values()}} Show or search for values \emph{within} -\code{fields}, \code{profiles}, \code{lists}, \code{collections}, \code{datasets} or \code{providers} +\item \code{\link[=galah_call]{galah_call()}}/\code{\link[=request_data]{request_()}} Start to build a request } -\strong{Amend a query} +\strong{Update a request object} \itemize{ -\item \code{\link[=apply_profile]{apply_profile()}}/\code{\link[=galah_apply_profile]{galah_apply_profile()}} Restrict to data that pass predefined checks (ALA only) +\item \code{\link[=apply_profile]{apply_profile()}} Restrict to data that pass predefined checks \item \code{\link[=arrange.data_request]{arrange()}} Arrange rows of a query on the server side +\item \code{\link[=authenticate]{authenticate()}} Authenticate your request via OAUTH in the browser \item \code{\link[=count.data_request]{count()}} Request counts of the specified data type -\item \code{\link[=desc]{desc()}} Arrange counts in descending order (when combined with \code{\link[=arrange.data_request]{arrange()}}) -\item \code{\link[=filter.data_request]{filter()}}/\code{\link[=galah_filter]{galah_filter()}} Filter records -\item \code{\link[=geolocate]{geolocate()}}/\code{\link[=galah_geolocate]{galah_geolocate()}} Spatial filtering of a query -\item \code{\link[=group_by.data_request]{group_by()}}/\code{\link[=galah_group_by]{galah_group_by()}} Group counts by one or more fields -\item \code{\link[=identify.data_request]{identify()}}/\code{\link[=galah_identify]{galah_identify()}} Search for taxonomic identifiers (see also \code{\link[=taxonomic_searches]{taxonomic_searches}}) -\item \code{\link[=select.data_request]{select()}}/\code{\link[=galah_select]{galah_select()}} Fields to report information for +\item \code{\link[=distinct.data_request]{distinct()}} Keep distinct/unique rows +\item \code{\link[=filter.data_request]{filter()}} Filter records (see also \code{\link[=filter_object_classes]{filter_object_classes}})) +\item \code{\link[=geolocate]{geolocate()}} Spatial filtering of a query +\item \code{\link[=glimpse]{glimpse()}} Get a glimpse of your data +\item \code{\link[=group_by.data_request]{group_by()}} Group counts by one or more fields +\item \code{\link[=identify.data_request]{identify()}} Search for taxonomic identifiers (see also \code{\link[=taxonomic_searches]{taxonomic_searches}}) +\item \code{\link[=select.data_request]{select()}} Fields to report information for \item \code{\link[=slice_head.data_request]{slice_head()}} Choose the first n rows of a download \item \code{\link[=unnest]{unnest()}} Expand metadata for \code{fields}, \code{lists}, \code{profiles} or \code{taxa} } -\strong{Execute a query via API} +\strong{Create and execute a query} \itemize{ -\item \code{\link[=collapse.data_request]{collapse()}} Convert a \code{data_request} into a \code{query} +\item \code{\link[=capture]{capture()}} Convert a request into a \code{prequery} or \code{query} +\item \code{\link[=compound]{compound()}} Convert an object into a \code{query_set} showing all calls needed for evaluation +\item \code{\link[=collapse.data_request]{collapse()}} Convert an object to a valid \code{query} \item \code{\link[=compute.data_request]{compute()}} Compute a query -\item \code{\link[=collect.data_request]{collect()}}/\code{\link[=atlas_]{atlas_()}}/\code{\link[=collect_media]{collect_media()}} Retrieve a database query +\item \code{\link[=collect.data_request]{collect()}} Retrieve a database query +} + +\strong{Wrappers for accessing data} +\itemize{ +\item \code{\link[=show_all]{show_all()}} & \code{\link[=search_all]{search_all()}} Data for generating filter queries +\item \code{\link[=show_values]{show_values()}} & \code{\link[=search_values]{search_values()}} Show or search for values \emph{within} \code{fields}, \code{profiles}, \code{lists}, \code{collections}, \code{datasets} or \code{providers} +\item \code{\link[=atlas_occurrences]{atlas_occurrences()}} Download occurrence data +\item \code{\link[=atlas_counts]{atlas_counts()}} Get a summary of the number of records or species +\item \code{\link[=atlas_species]{atlas_species()}} Download occurrences grouped by \code{speciesID} +\item \code{\link[=atlas_taxonomy]{atlas_taxonomy()}} Download taxonomic trees +\item \code{\link[=atlas_media]{atlas_media()}} Download media metadata linked to occurrences +\item \code{\link[=collect_media]{collect_media()}} Download media (images and sounds) } \strong{Miscellaneous functions} @@ -78,18 +91,20 @@ also run a number of quality checks against each record, resulting in \strong{assertions} attached to the record. Each piece of information associated with a given occurrence record is stored in a \strong{field}, which corresponds to a \strong{column} when imported to an -\verb{R data.frame}. See \code{show_all(fields)} to view valid fields, +\code{tibble}. See \code{show_all(fields)} to view valid fields, layers and assertions, or conduct a search using \code{search_all(fields)}. Data fields are important because they provide a means to \strong{filter} occurrence records; i.e. to return only the information that you need, and no more. Consequently, much of the architecture of \code{galah} has been designed to make filtering as simple as possible. The easiest way to do this -is to start a pipe with \code{galah_call()} and follow it with the relevant -\code{dplyr} function; starting with \code{filter()}, but also including \code{select()}, -\code{group_by()} or others. Functions without a relevant \code{dplyr} synonym include -\code{\link[=galah_identify]{galah_identify()}}/\code{identify()} for choosing a taxon, or \code{\link[=galah_geolocate]{galah_geolocate()}}/ -\code{st_crop()} for choosing a specific location. By combining different filters, +is to start a pipe with \code{\link[=galah_call]{galah_call()}} and follow it with the relevant +\code{dplyr} function; starting with \code{\link[=filter.data_request]{filter()}}, +but also including \code{\link[=select.data_request]{select()}}, +\code{\link[=group_by.data_request]{group_by()}} or others. Functions without +a relevant \code{dplyr} synonym include +\code{\link[=identify.data_request]{identify()}} for choosing a taxon, or +\code{\link[=geolocate]{geolocate()}} for choosing a specific location. By combining different filters, it is possible to build complex queries to return only the most valuable information for a given problem. @@ -100,9 +115,8 @@ be used to filter out records that are unsuitable for particular applications. However, there are many possible data quality checks, and it is not always clear which are most appropriate in a given instance. Therefore, \code{galah} supports data quality \strong{profiles}, which can be passed to -\code{\link[=galah_apply_profile]{galah_apply_profile()}} to quickly remove undesirable records. A full list of -data quality profiles is returned by \code{show_all(profiles)}. Note this service -is currently only available for the Australian atlas (ALA). +\code{\link[=apply_profile]{apply_profile()}} to quickly remove undesirable records. A full list of +data quality profiles is returned by \code{show_all(profiles)}. } \seealso{ @@ -119,8 +133,12 @@ Useful links: Authors: \itemize{ \item Dax Kellie \email{dax.kellie@csiro.au} - \item Matilda Stevenson - \item Peggy Newman \email{peggy.newman@csiro.au} +} + +Other contributors: +\itemize{ + \item Shandiya Balasubramaniam \email{shandiya.balasubramaniam@csiro.au} [contributor] + \item Matilda Stevenson [contributor] } } diff --git a/man/galah_call.Rd b/man/galah_call.Rd index 19d2ee24..8bece2c7 100644 --- a/man/galah_call.Rd +++ b/man/galah_call.Rd @@ -5,78 +5,60 @@ \alias{request_data} \alias{request_metadata} \alias{request_files} -\title{Start building a query} +\title{Start building a request} \usage{ -galah_call(method = c("data", "metadata", "files"), type, ...) +galah_call( + type = c("occurrences", "occurrences-count", "occurrences-doi", "species", + "species-count") +) request_data( type = c("occurrences", "occurrences-count", "occurrences-doi", "species", - "species-count"), - ... + "species-count") ) request_metadata( - type = c("fields", "apis", "assertions", "atlases", "collections", "datasets", - "licences", "lists", "media", "profiles", "providers", "ranks", "reasons", "taxa", - "identifiers") + type = c("fields", "apis", "assertions", "atlases", "collections", "config", + "datasets", "licences", "lists", "media", "profiles", "providers", "ranks", + "reasons", "taxa", "identifiers") ) request_files(type = "media") } \arguments{ -\item{method}{string: what \code{request} function should be called. Should be one -of \code{"data"} (default), \code{"metadata"} or \code{"files"}} - \item{type}{string: what form of data should be returned? Acceptable values are specified by the corresponding \code{request} function} - -\item{...}{Zero or more arguments passed to -\code{\link[=collapse.data_request]{collapse()}} to alter a query. Currently -only \code{mint.doi} (for occurrences) and \code{thumbnail} (for media downloads) are -supported. Both are logical.} } \value{ -Each sub-function returns a different object class: \code{request_data()} -returns \code{data_request}. \code{request_metadata} returns \code{metadata_request}, -\code{request_files()} returns \code{files_request}. These objects are list-like and -contain the following slots: +Each sub-function returns a different object class: \itemize{ -\item \code{filter}: edit by piping \code{\link[=filter.data_request]{filter()}} or \code{\link[=galah_filter]{galah_filter()}}. -\item \code{select}: edit by piping \code{\link[=filter.data_request]{select}} or \code{\link[=galah_select]{galah_select()}}. -\item \code{group_by}: edit by piping \code{\link[=group_by.data_request]{group_by()}} or \code{\link[=galah_group_by]{galah_group_by()}}. -\item \code{identify}: edit by piping \code{\link[=identify.data_request]{identify()}} or \code{\link[=galah_identify]{galah_identify()}}. -\item \code{geolocate}: edit by piping \code{\link[=st_crop.data_request]{st_crop()}}, -\code{\link[=galah_geolocate]{galah_geolocate()}}, \code{\link[=galah_polygon]{galah_polygon()}} or \code{\link[=galah_bbox]{galah_bbox()}}. -\item \code{limit}: edit by piping \code{\link[=slice_head.data_request]{slice_head()}}. -\item \code{doi}: edit by piping \code{\link[=filter.data_request]{filter(doi == "my-doi-here")}}. +\item \code{\link[=request_data]{request_data()}} and \code{\link[=galah_call]{galah_call()}} return class \code{"data_request"} +\item \code{\link[=request_metadata]{request_metadata()}} returns class \code{"metadata_request"} +\item \code{\link[=request_files]{request_files()}} returns class \code{"files_request"} } + +These objects are list-like and store later dplyr verbs in the order +they are provided. } \description{ To download data from the selected atlas, one must construct a query. This query tells the atlas API what data to download and return, as well as how it -should be filtered. Using \code{galah_call()} allows you to build a piped query to +should be filtered. Using \code{\link[=galah_call]{galah_call()}} allows you to build a piped query to download data, in the same way that you would wrangle data with \code{dplyr} and -the \code{tidyverse}. +the \code{tidyverse}. It is synonymous with \code{\link[=request_data]{request_data()}}; to query other +data types call \code{\link[=request_metadata]{request_metadata()}} or \code{\link[=request_files]{request_files()}}. } \details{ -In practice, \code{galah_call()} is a wrapper to a group of underlying -\code{request_} functions, selected using the \code{method} argument. -Each of these functions can begin a piped query and end with \code{collapse()}, -\code{compute()} or \code{collect()}, or optionally one of the \code{atlas_} family of -functions. For more details see the object-oriented programming vignette: -\code{vignette("object_oriented_programming", package = "galah")} - -Accepted values of the \code{type} argument are set by the underlying \code{request_} -functions. While all accepted types can be set directly, some are affected -by later functions. The most common example is that adding -\code{\link[=count.data_request]{count()}} to a pipe updates \code{type}, -converting \code{type = "occurrences"} to \code{type = "occurrences-count"} (and ditto -for \code{type = "species"}). +\code{\link[=galah_call]{galah_call()}} and any of the \code{request_} functions are used to begin a +piped query, which is then actioned using +\code{\link[=collect.data_request]{collect()}}, or optionally one of the +\code{\link[=atlas_occurrences]{atlas_}} family of functions. -The underlying \code{request_} functions are useful because they allow \code{galah} -to separate different types of requests to perform better. For example, -\code{filter.data_request} translates filters in R to \code{solr}, whereas -\code{filter.metadata_request} searches using a search term. +Having distinct functions for different types of request is useful because +it allows \code{galah} to separate different types of requests to perform better. +For example, \code{\link[=filter.data_request]{filter.data_request()}}translates filters +to \code{solr} syntax for the living atlases, or to predicates for GBIF, whereas +\code{\link[=filter.metadata_request]{filter.metadata_request()}} adds a search term to your metadata query. } \examples{ \dontrun{ @@ -87,12 +69,14 @@ galah_call() |> identify("Aves") |> filter(year > 2000 & year < 2005) |> group_by(year) |> - atlas_counts() + count() |> + collect() # Get information for all species in *Cacatuidae* family galah_call() |> identify("Cacatuidae") |> - atlas_species() + distinct("speciesID", .keep_all = TRUE) |> + collect() # Download records of genus *Eolophus* from 2001 to 2004 galah_config(email = "your-email@email.com") @@ -100,31 +84,24 @@ galah_config(email = "your-email@email.com") galah_call() |> identify("Eolophus") |> filter(year > 2000 & year < 2005) |> - atlas_occurrences() # synonymous with `collect()` - - -# galah_call() is a wrapper to various `request_` functions. -# These can be called directly for greater specificity. - -# Get number of records of *Aves* from 2001 to 2004 by year -request_data() |> - identify("Aves") |> - filter(year > 2000 & year < 2005) |> - group_by(year) |> - count() |> - collect() - -# Get information for all species in *Cacatuidae* family -request_data(type = "species") |> - identify("Cacatuidae") |> collect() - -# Get metadata information about supported atlases in galah -request_metadata(type = "atlases") |> - collect() - } } \seealso{ -\code{\link[=collapse.data_request]{collapse.data_request()}}, \code{\link[=compute.data_request]{compute.data_request()}}, \code{\link[=collect.data_request]{collect.data_request()}} +To amend a request object, use \code{\link[=apply_profile]{apply_profile()}}, +\code{\link[=arrange.data_request]{arrange()}}, +\code{\link[=count.data_request]{count()}}, +\code{\link[=distinct.data_request]{distinct()}}, +\code{\link[=filter.data_request]{filter()}}, +\code{\link[=glimpse.data_request]{glimpse()}}, +\code{\link[=group_by.data_request]{group_by()}}, +\code{\link[=identify.data_request]{identify()}}, +\code{\link[=select.data_request]{select}}, +\code{\link[=slice_head.data_request]{slice_head()}} or \code{\link[=unnest]{unnest()}}. +For operations on \verb{_request} objects, see +\code{\link[=capture]{capture()}}, +\code{\link[=compound]{compound()}}, +\code{\link[=collapse.data_request]{collapse()}}, +\code{\link[=compute.data_request]{compute()}} or +\code{\link[=collect.data_request]{collect()}}. } diff --git a/man/galah_config.Rd b/man/galah_config.Rd index 9faf623d..c90272ef 100644 --- a/man/galah_config.Rd +++ b/man/galah_config.Rd @@ -2,23 +2,51 @@ % Please edit documentation in R/galah_config.R \name{galah_config} \alias{galah_config} -\title{Get or set configuration options that control galah behaviour} +\title{View or set package behaviour} \usage{ galah_config(...) } \arguments{ -\item{\dots}{Options can be defined using the form \code{name = "value"}. -Valid arguments are: +\item{\dots}{Options can be defined using the form \code{name = "value"}, or +as a (single) named list. See details for accepted fields.} +} +\value{ +Returns an object with classes \code{galah_config} and \code{list}, invisibly +if arguments are supplied. +} +\description{ +The \code{galah} package supports queries to a number of different data providers, +and once selected, it is desirable that all later queries are sent to that +organisation. Rather than supply this information separately in each +query, it is more parsimonious to cache it centrally +and call it as needed, which is what this function supports. + +Beyond choosing +an organisation, there are several other use cases for caching. Many +GBIF nodes require the user to supply a registered email address, +password, and (in some cases) a reason for downloading data, all stored via +\code{galah_config()}. This function also provides a convenient place to control +optional package behaviours, such as checking queries to ensure they are +valid (\code{run_checks}), informing you via email when your downloads are ready +(\code{send_email}), or controlling whether galah will provide updates on your +query as they are processed (\code{verbose}). +} +\details{ +Valid arguments to this function are: \itemize{ -\item \code{api-key} string: A registered API key (currently unused). \item \code{atlas} string: Living Atlas to point to, Australia by default. Can be an organisation name, acronym, or region (see \code{\link[=show_all_atlases]{show_all_atlases()}} for admissible values) -\item \code{directory} string: the directory to use for the cache. +\item \code{authenticate} logical: Should \code{galah} use authenticate your queries using +JWT tokens? Defaults to \code{FALSE}. If \code{TRUE}, user credentials are +verified prior to sending a query. This can allow users with special +access to download additional information in \code{galah}. +\item \code{caching} logical: should metadata query results be cached in \code{options()}? +Defaults to \code{TRUE} for improved stability and speed. +\item \code{directory} string: The directory to use for the disk cache. By default this is a temporary directory, which means that results will -only be cached -within an R session and cleared automatically when the user exits R. -The user may wish to set this to a non-temporary directory for +only be cached within an R session and cleared automatically when the user +exits R. The user may wish to set this to a non-temporary directory for caching across sessions. The directory must exist on the file system. \item \code{download_reason_id} numeric or string: the "download reason" required. by some ALA services, either as a numeric ID (currently 0--13) @@ -40,20 +68,8 @@ useful in some instances, for example for tracking DOIs assigned to specific downloads for later citation. \item \code{username} string: A registered username (GBIF only) \item \code{verbose} logical: should \code{galah} give verbose such as progress bars? -Defaults to FALSE. -}} +Defaults to \code{FALSE}. } -\value{ -For \code{galah_config()}, a \code{list} of all options. -When \code{galah_config(...)} is called with arguments, nothing is returned -but the configuration is set. -} -\description{ -The \code{galah} package supports large data downloads, and also -interfaces with the ALA which requires that users of some services -provide a registered email address and reason for downloading data. The -\code{galah_config} function provides a way to manage these issues as simply -as possible. } \examples{ \dontrun{ @@ -73,5 +89,9 @@ show_all(reasons) # Make debugging in your session easier by setting `verbose = TRUE` galah_config(verbose = TRUE) + +# Optionally supply arguments via a named list +list(email = "your-email@email.com") |> + galah_config() } } diff --git a/man/geolocate.Rd b/man/geolocate.Rd index f38e186b..d497b709 100644 --- a/man/geolocate.Rd +++ b/man/geolocate.Rd @@ -64,7 +64,6 @@ box. Bounding boxes can be extracted from a supplied \code{sf} object or a shapefile. A bounding box can also be supplied as a \code{bbox} object (via \code{sf::st_bbox()}) or a \code{tibble}/\code{data.frame}. -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} \strong{Use a point radius} Alternatively, set \code{type = "radius"} to narrow queries to within a circular area around a specific point location. Point coordinates can be supplied as diff --git a/man/glimpse.data_request.Rd b/man/glimpse.data_request.Rd new file mode 100644 index 00000000..8590077b --- /dev/null +++ b/man/glimpse.data_request.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/dplyr-glimpse.R +\name{glimpse.data_request} +\alias{glimpse.data_request} +\alias{print.occurrences_glimpse} +\title{Get a glimpse of your data} +\usage{ +\method{glimpse}{data_request}(x, ...) + +\method{print}{occurrences_glimpse}(x, ...) +} +\arguments{ +\item{x}{An object of class \code{data_request}} + +\item{...}{Other arguments, currently ignored} +} +\description{ +\code{\link[=glimpse]{glimpse()}} is like a transposed version of \code{\link[=print]{print()}}: columns run down the page, +and data runs across. This makes it possible to see every column in a data +frame. It's a little like \code{\link[=str]{str()}} applied to a data frame but it tries to +show you as much data as possible. This implementation is specific +to \code{galah} and is evaluated lazily. \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +} +\details{ +This implementation of \code{\link[=glimpse]{glimpse()}} actually involves changing the API call +sent to the server, then returning a novel object class with it's own +\code{\link[=print]{print()}} method. +} +\examples{ +\dontrun{ +galah_call() |> + filter(year >= 2019, + basisOfRecord == "HumanObservation") |> + select(year, basisOfRecord, species) |> + glimpse() |> + collect() +} +} diff --git a/man/group_by.data_request.Rd b/man/group_by.data_request.Rd index 84e44446..3b9aa8e9 100644 --- a/man/group_by.data_request.Rd +++ b/man/group_by.data_request.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/galah_group_by.R +% Please edit documentation in R/dplyr-group_by.R, R/galah_group_by.R \name{group_by.data_request} \alias{group_by.data_request} \alias{galah_group_by} diff --git a/man/identify.data_request.Rd b/man/identify.data_request.Rd index 854d9069..9bb5cfbd 100644 --- a/man/identify.data_request.Rd +++ b/man/identify.data_request.Rd @@ -10,19 +10,15 @@ \method{identify}{metadata_request}(x, ...) -galah_identify(..., search = NULL) +galah_identify(...) } \arguments{ -\item{x}{An object of class \code{metadata_request}, created using \code{\link[=request_metadata]{request_metadata()}}} +\item{x}{An object of class \code{data_request} or \code{metadata_request}.} \item{...}{One or more scientific names.} - -\item{search}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} -\code{galah_identify()} now always does a search to verify search terms; ergo -this argument is ignored.} } \value{ -A tibble containing identified taxa. +A \code{tibble} containing identified taxa. } \description{ When conducting a search or creating a data query, it is common to identify diff --git a/man/print_galah_objects.Rd b/man/print_galah_objects.Rd index d7b8b7d0..bc497739 100644 --- a/man/print_galah_objects.Rd +++ b/man/print_galah_objects.Rd @@ -6,6 +6,7 @@ \alias{print.files_request} \alias{print.metadata_request} \alias{print.query} +\alias{print.prequery} \alias{print.computed_query} \alias{print.query_set} \alias{print.galah_config} @@ -19,6 +20,8 @@ \method{print}{query}(x, ...) +\method{print}{prequery}(x, ...) + \method{print}{computed_query}(x, ...) \method{print}{query_set}(x, ...) diff --git a/man/read_zip.Rd b/man/read_zip.Rd index 3d0a206a..d5428cba 100644 --- a/man/read_zip.Rd +++ b/man/read_zip.Rd @@ -11,8 +11,6 @@ read_zip(file) \code{.zip}.} } \description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} - Living atlases supply data downloads as zip files. This function reads these data efficiently, i.e. without unzipping them first, using the \code{readr} package. Although this function has been part of galah for some time, it was diff --git a/man/reexports.Rd b/man/reexports.Rd index 778aeede..bd83237d 100644 --- a/man/reexports.Rd +++ b/man/reexports.Rd @@ -3,16 +3,19 @@ \docType{import} \name{reexports} \alias{reexports} +\alias{add_count} \alias{arrange} \alias{collect} \alias{compute} \alias{collapse} -\alias{identify} +\alias{count} +\alias{distinct} \alias{filter} -\alias{select} +\alias{glimpse} \alias{group_by} +\alias{select} \alias{slice_head} -\alias{count} +\alias{identify} \alias{st_crop} \title{Objects exported from other packages} \keyword{internal} @@ -21,7 +24,7 @@ These objects are imported from other packages. Follow the links below to see their documentation. \describe{ - \item{dplyr}{\code{\link[dplyr]{arrange}}, \code{\link[dplyr:compute]{collapse}}, \code{\link[dplyr:compute]{collect}}, \code{\link[dplyr]{compute}}, \code{\link[dplyr]{count}}, \code{\link[dplyr]{filter}}, \code{\link[dplyr]{group_by}}, \code{\link[dplyr]{select}}, \code{\link[dplyr:slice]{slice_head}}} + \item{dplyr}{\code{\link[dplyr:count]{add_count}}, \code{\link[dplyr]{arrange}}, \code{\link[dplyr:compute]{collapse}}, \code{\link[dplyr:compute]{collect}}, \code{\link[dplyr]{compute}}, \code{\link[dplyr]{count}}, \code{\link[dplyr]{distinct}}, \code{\link[dplyr]{filter}}, \code{\link[dplyr]{glimpse}}, \code{\link[dplyr]{group_by}}, \code{\link[dplyr]{select}}, \code{\link[dplyr:slice]{slice_head}}} \item{graphics}{\code{\link[graphics]{identify}}} diff --git a/man/search_all.Rd b/man/search_all.Rd index f468a2a3..4e96d6c8 100644 --- a/man/search_all.Rd +++ b/man/search_all.Rd @@ -15,38 +15,41 @@ \alias{search_apis} \alias{search_identifiers} \alias{search_lists} +\alias{search_media} \alias{search_taxa} \title{Search for record information} \usage{ -search_all(type, query) +search_all(type, query, all_fields = FALSE) -search_assertions(query) +search_assertions(query, all_fields = FALSE) -search_apis(query) +search_apis(query, all_fields = FALSE) -search_atlases(query) +search_atlases(query, all_fields = FALSE) -search_collections(query) +search_collections(query, all_fields = FALSE) -search_datasets(query) +search_datasets(query, all_fields = FALSE) -search_fields(query) +search_fields(query, all_fields = FALSE) -search_identifiers(...) +search_identifiers(..., all_fields = FALSE) -search_licences(query) +search_licences(query, all_fields = FALSE) -search_lists(query) +search_lists(query, all_fields = FALSE) -search_profiles(query) +search_media(query, all_fields = FALSE) -search_providers(query) +search_profiles(query, all_fields = FALSE) -search_ranks(query) +search_providers(query, all_fields = FALSE) -search_reasons(query) +search_ranks(query, all_fields = FALSE) -search_taxa(...) +search_reasons(query, all_fields = FALSE) + +search_taxa(..., all_fields = FALSE) } \arguments{ \item{type}{A string to specify what type of parameters should be searched.} @@ -54,8 +57,12 @@ search_taxa(...) \item{query}{A string specifying a search term. Searches are not case-sensitive.} -\item{...}{A set of strings or a tibble to be queried; see -Details.} +\item{all_fields}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} If \code{TRUE}, +\code{show_values()} also returns all columns available from the API, rather +than the 'default' columns traditionally provided via galah.} + +\item{...}{One or more objects accepted by the taxonomic lookup services. See +\link{taxonomic_searches} for details} } \value{ An object of class \code{tbl_df} and \code{data.frame} (aka a tibble) @@ -70,15 +77,15 @@ Functions prefixed with \code{search_} do this, displaying any matches to a search term within the valid options for the information specified by the suffix. -\strong{For more information about taxonomic searches using \code{search_taxa()}, see \code{?taxonomic_searches}}. +\strong{For more information about taxonomic searches using \code{search_taxa()}, see} +\code{\link[=taxonomic_searches]{?taxonomic_searches}}. -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} \code{search_all()} is a helper function that can do searches for multiple types of information, acting as a wrapper around many \code{search_} sub-functions. See \code{Details} (below) for accepted values. } \details{ -There are five categories of information, each with their own +There are six categories of information, each with their own specific sub-functions to look-up each type of information. The available types of information for \code{search_all()} are:\tabular{llll}{ \strong{Category} \tab \strong{Type} \tab \strong{Description} \tab \strong{Sub-functions} \cr @@ -96,6 +103,7 @@ The available types of information for \code{search_all()} are:\tabular{llll}{ data providers \tab \code{providers} \tab Search for which institutions have provided data \tab \code{search_providers()} \cr \tab \code{collections} \tab Search for the specific collections within those institutions \tab \code{search_collections()} \cr \tab \code{datasets} \tab Search for the data groupings within those collections \tab \code{search_datasets()} \cr + media \tab \code{media} \tab Search for images or sounds using a vector of IDs \tab \code{search_media()} \cr } } \examples{ diff --git a/man/select.data_request.Rd b/man/select.data_request.Rd index 83b67926..1fb94815 100644 --- a/man/select.data_request.Rd +++ b/man/select.data_request.Rd @@ -1,13 +1,16 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/galah_select.R +% Please edit documentation in R/dplyr-select.R, R/galah_select.R \name{select.data_request} \alias{select.data_request} +\alias{select.metadata_request} \alias{galah_select} \title{Keep or drop columns using their names} \usage{ -\method{select}{data_request}(.data, ..., group) +\method{select}{data_request}(.data, ..., group = NULL) -galah_select(..., group) +\method{select}{metadata_request}(.data, ...) + +galah_select(..., group = NULL) } \arguments{ \item{.data}{An object of class \code{data_request}, created using \code{\link[=galah_call]{galah_call()}}.} @@ -33,7 +36,8 @@ or messages will be triggered at the end of the pipe. \code{select()} supports \code{dplyr} \strong{selection helpers}, including: \itemize{ -\item \code{\link[dplyr]{everything}}: Matches all variables. +\item \code{\link[dplyr]{everything}}: Matches all variables. This is treated +unusually in \code{galah}; see \code{details}. \item \code{\link[dplyr]{last_col}}: Select last variable, possibly with an offset. } @@ -73,14 +77,15 @@ the exception of GBIF, for which all columns are returned. Calling the argument \code{group = "basic"} returns the following columns: \itemize{ +\item \code{recordID} +\item \code{scientificName} +\item \code{taxonConceptID} \item \code{decimalLatitude} \item \code{decimalLongitude} \item \code{eventDate} -\item \code{scientificName} -\item \code{taxonConceptID} -\item \code{recordID} -\item \code{dataResourceName} +\item \code{basisOfRecord} \item \code{occurrenceStatus} +\item \code{dataResourceName} } Using \code{group = "event"} returns the following columns: @@ -117,6 +122,11 @@ it should be one or more of: \item \code{synonyms} to include any synonymous names. \item \code{lists} to include authoritative lists that each species is included on. } + +For metadata queries - as generated using \code{\link[=request_metadata]{request_metadata()}} or +\code{\link[=galah_call]{galah_call()}} - \code{select()} can now be used to return only the requested +columns. Unlike data queries, this works by capturing the user's query +and applying it user-side, rather than amending the query. } \examples{ \dontrun{ diff --git a/man/show_all.Rd b/man/show_all.Rd index 876cdfce..4fd8ba41 100644 --- a/man/show_all.Rd +++ b/man/show_all.Rd @@ -6,6 +6,7 @@ \alias{show_all_assertions} \alias{show_all_atlases} \alias{show_all_collections} +\alias{show_all_config} \alias{show_all_datasets} \alias{show_all_fields} \alias{show_all_licences} @@ -16,37 +17,43 @@ \alias{show_all_reasons} \title{Show valid record information} \usage{ -show_all(..., limit = NULL) +show_all(..., limit = NULL, all_fields = FALSE) -show_all_apis(limit = NULL) +show_all_apis(limit = NULL, all_fields = FALSE) -show_all_assertions(limit = NULL) +show_all_assertions(limit = NULL, all_fields = FALSE) -show_all_atlases(limit = NULL) +show_all_atlases(limit = NULL, all_fields = FALSE) -show_all_collections(limit = NULL) +show_all_collections(limit = NULL, all_fields = FALSE) -show_all_datasets(limit = NULL) +show_all_config() -show_all_fields(limit = NULL) +show_all_datasets(limit = NULL, all_fields = FALSE) -show_all_licences(limit = NULL) +show_all_fields(limit = NULL, all_fields = FALSE) -show_all_lists(limit = NULL) +show_all_licences(limit = NULL, all_fields = FALSE) -show_all_profiles(limit = NULL) +show_all_lists(limit = NULL, all_fields = FALSE) -show_all_providers(limit = NULL) +show_all_profiles(limit = NULL, all_fields = FALSE) -show_all_ranks(limit = NULL) +show_all_providers(limit = NULL, all_fields = FALSE) -show_all_reasons(limit = NULL) +show_all_ranks(limit = NULL, all_fields = FALSE) + +show_all_reasons(limit = NULL, all_fields = FALSE) } \arguments{ \item{...}{String showing what type of information is to be requested. See \code{Details} (below) for accepted values.} \item{limit}{Optional number of values to return. Defaults to NULL, i.e. all records} + +\item{all_fields}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} If \code{TRUE}, +\code{show_values()} also returns all columns available from the API, rather +than the 'default' columns traditionally provided via galah.} } \value{ An object of class \code{tbl_df} and \code{data.frame} (aka a tibble) @@ -60,7 +67,6 @@ options or categories for the type of information they are interested in. Functions prefixed with \code{show_all_} do this, displaying all valid options for the information specified by the suffix. -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} \code{show_all()} is a helper function that can display multiple types of information from \code{show_all_} sub-functions. } @@ -71,6 +77,7 @@ The available types of information for \code{show_all_} are:\tabular{llll}{ \strong{Category} \tab \strong{Type} \tab \strong{Description} \tab \strong{Sub-functions} \cr Configuration \tab \code{atlases} \tab Show what atlases are available \tab \code{show_all_atlases()} \cr \tab \code{apis} \tab Show what APIs & functions are available for each atlas \tab \code{show_all_apis()} \cr + \tab \code{config} \tab Show information necessary for authentication \tab \code{show_all_config()} \cr \tab \code{reasons} \tab Show what values are acceptable as 'download reasons' for a specified atlas \tab \code{show_all_reasons()} \cr Data providers \tab \code{providers} \tab Show which institutions have provided data \tab \code{show_all_providers()} \cr \tab \code{collections} \tab Show the specific collections within those institutions \tab \code{show_all_collections()} \cr @@ -100,6 +107,11 @@ show_all(ranks) # `show_all()` is synonymous with `request_metadata() |> collect()` request_metadata(type = "fields") |> collect() + +# using `all_fields = TRUE` is synonymous with `select(everything())` +request_metadata(type = "fields") |> + select(everything()) |> + collect() } } \references{ diff --git a/man/show_values.Rd b/man/show_values.Rd index 162f8925..77a98534 100644 --- a/man/show_values.Rd +++ b/man/show_values.Rd @@ -14,14 +14,17 @@ search_values(df, query) \code{\link[=search_lists]{search_lists()}}.} \item{all_fields}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} If \code{TRUE}, -\code{show_values()} also returns all raw data columns -(columns included prior to the dataset's ingestion into the ALA). -For many lists, this will include raw scientific names and vernacular -names. -For conservation lists like the EPBC list, this also includes columns -containing each species' conservation status information. -Default is set to \code{FALSE}. -Currently only implemented for metadata type \code{lists}.} +\code{show_values()} also returns all columns available from the API, rather +than the 'default' columns traditionally provided via galah. + +For lists, this will include 'raw' columns; columns included prior to the +dataset's ingestion into the ALA, and will often include raw scientific +names and vernacular names. For conservation lists like the EPBC list, this +also includes columns containing each species' conservation status +information. + +For other forms of metadata, setting this to \code{TRUE} may return more +information than you want or need. Default is set to \code{FALSE}.} \item{query}{A string specifying a search term. Not case sensitive.} } @@ -41,7 +44,7 @@ For example: \item The \code{field} "year" contains values 2021, 2020, 2019, etc. \item The \code{field} "stateProvince" contains values New South Wales, Victoria, Queensland, etc. These are used to narrow queries with -\code{\link[=filter.data_request]{filter()}} or \code{\link[=galah_filter]{galah_filter()}}. +\code{\link[=filter.data_request]{filter()}}. } Each \strong{Profile} consists of many individual quality filters. diff --git a/man/slice_head.data_request.Rd b/man/slice_head.data_request.Rd index 440e4150..0b712be9 100644 --- a/man/slice_head.data_request.Rd +++ b/man/slice_head.data_request.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/slice_head.R +% Please edit documentation in R/dplyr-slice_head.R \name{slice_head.data_request} \alias{slice_head.data_request} \alias{slice_head.metadata_request} @@ -26,8 +26,6 @@ performed on each group.} An amended \code{data_request} with a completed \code{slice} slot. } \description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} - \code{slice()} lets you index rows by their (integer) locations. For objects of classes \code{data_request} or \code{metadata_request}, only \code{slice_head()} is currently implemented, and selects the first \code{n} rows. diff --git a/man/taxonomic_searches.Rd b/man/taxonomic_searches.Rd index 000975d5..7767ec67 100644 --- a/man/taxonomic_searches.Rd +++ b/man/taxonomic_searches.Rd @@ -4,7 +4,7 @@ \alias{taxonomic_searches} \title{Look up taxon information} \description{ -\code{search_taxa()} allows users to look up taxonomic names, and ensure they are +\code{\link[=search_taxa]{search_taxa()}} allows users to look up taxonomic names, and ensure they are being matched correctly, before downloading data from the specified organisation. @@ -17,7 +17,7 @@ to list these separately under \code{genus} and \code{specificEpithet} (respecti A more common use-case is to distinguish between homonyms by listing higher taxonomic units, by supplying columns like \code{kingdom}, \code{phylum} or \code{class}. -\code{search_identifiers()} allows users to look up matching taxonomic names using +\code{\link[=search_identifiers]{search_identifiers()}} allows users to look up matching taxonomic names using their unique \code{taxonConceptID}. In the ALA, all records are associated with an identifier that uniquely identifies the taxon to which that record belongs. Once those identifiers are known, this function allows you to use them to @@ -26,8 +26,8 @@ inverse function to \code{\link[=search_taxa]{search_taxa()}}, which takes names identifiers. Note that when taxonomic look-up is required within a pipe, the equivalent -to \code{search_taxa()} is \code{\link[=identify.data_request]{identify()}} (or -\code{\link[=galah_identify]{galah_identify()}}). The equivalent to \code{search_identifiers()} is to use +to \code{\link[=search_taxa]{search_taxa()}} is \code{\link[=identify.data_request]{identify()}} (or +\code{\link[=galah_identify]{galah_identify()}}). The equivalent to \code{\link[=search_identifiers]{search_identifiers()}} is to use \code{\link[=filter.data_request]{filter()}} to filter by \code{taxonConceptId}. } \details{ @@ -50,6 +50,19 @@ on the \href{https://github.com/AtlasOfLivingAustralia/ala-name-matching?tab=rea \item \verb{taxonomic names} (e.g. \code{kingdom}, \code{phylum}, \code{class}, \code{order}, \code{family}, \code{genus}) } + +When querying using \code{\link[=request_metadata]{request_metadata()}}, you have the option to pass +\code{\link[=select.metadata_request]{select()}} within the query. The +easiest way to do this is \code{select(everything())}, but for completeness, the +following additional fields are available: +\itemize{ +\item \code{success}: Logical indicating success or failure of the search +\item \code{scientific_name_authorship}: Author and year for the name in question +\item \code{name_type}: Usually \code{"SCIENTIFIC"} +\item \code{lft} and \code{rgt}: Numeric indices for taxonomic lookups +\item \code{species_group} and \code{species_subgroup}: List-columns giving group names +\item \verb{_id} fields for \code{rank} and any taxonomic rank fields (\code{kingdom_id}, \code{phylum_id} etc.) +} } \examples{ \dontrun{ @@ -76,8 +89,27 @@ search_taxa(tibble::tibble( family = c("pardalotidae", "maluridae"), scientificName = c("Pardalotus striatus striatus", "malurus cyaneus"))) +# Use OOP for the same effect +# `identify()` tells the code that we want to search for _taxonomic_ metadata. +request_metadata() |> + identify("crinia") |> + collect() + +# This approach has the advantage that we can call `select()` +request_metadata() |> + identify("crinia") |> + select(everything()) |> + collect() + # Look up a unique taxon identifier search_identifiers(query = "https://id.biodiversity.org.au/node/apni/2914510") + +# OOP process for identifiers uses `filter()`, not `identify()` +# In these cases the `field` argument is used to specify `type` +request_metadata() |> + filter(identifier = "https://id.biodiversity.org.au/node/apni/2914510") |> + select(everything()) |> + collect() } } \seealso{ diff --git a/man/tidyverse_functions.Rd b/man/tidyverse_functions.Rd deleted file mode 100644 index 4aba5f2a..00000000 --- a/man/tidyverse_functions.Rd +++ /dev/null @@ -1,66 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tidyverse.R -\name{tidyverse_functions} -\alias{tidyverse_functions} -\alias{desc} -\alias{unnest} -\title{Non-generic tidyverse functions} -\usage{ -desc(...) - -unnest(.query) -} -\arguments{ -\item{...}{column to order by} - -\item{.query}{An object of class \code{metadata_request}} -} -\value{ -\itemize{ -\item \code{galah::desc()} returns a \code{tibble} used by \code{arrange.data_request()} to arrange rows of a query. -\item \code{galah::unnest()} returns an object of class \code{metadata_request}. -} -} -\description{ -Several useful functions from tidyverse packages are \code{generic}, meaning -that we can define class-specific versions of those functions and implement -them in galah; examples include \code{filter()}, \code{select()} and \code{group_by()}. -However, there are also functions that are only defined within tidyverse -packages and are not generic. In a few cases we have re-implemented these -functions in galah. This has the consequence of supporting consistent -syntax with tidyverse, at the cost of potentially introducing conflicts. -This can be avoided by using the \code{::} operator where required (see examples). -} -\details{ -The following functions are included: -\itemize{ -\item \code{desc()} (\code{dplyr}): Use within \code{arrange()} to specify arrangement should be descending -\item \code{unnest()} (\code{tidyr}): Use to 'drill down' into nested information on \code{fields}, \code{lists}, \code{profiles}, or \code{taxa} -} - -These galah versions all use lazy evaluation. -} -\examples{ -\dontrun{ -# Arrange grouped record counts by descending year -galah_call() |> - identify("perameles") |> - filter(year > 2019) |> - count() |> - arrange(galah::desc(year)) |> - collect() - -# Return values of field `basisOfRecord` -request_metadata() |> - galah::unnest() |> - filter(field == basisOfRecord) |> - collect() - -# Using `galah::unnest()` in this way is equivalent to: -show_all(fields, "basisOfRecord") |> - show_values() -} -} -\seealso{ -\code{\link[=arrange.data_request]{arrange()}}, \code{\link[=galah_call]{galah_call()}} -} diff --git a/man/unnest.Rd b/man/unnest.Rd new file mode 100644 index 00000000..a19dfa94 --- /dev/null +++ b/man/unnest.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tidyr-unnest.R +\name{unnest} +\alias{unnest} +\title{Unnest a query} +\usage{ +unnest(.query) +} +\arguments{ +\item{.query}{An object of class \code{metadata_request}} +} +\value{ +An object of class \code{metadata_request} +} +\description{ +This syntax is borrowed from \code{tidyr}, and is conceptually used in the same +way here, but in galah unnest amends the query to unnest information +server-side, rather than on your machine. It powers all of the +\code{\link[=show_values]{show_values()}} functions in galah. +} +\details{ +Re-implementing existing functions has the consequence of supporting +consistent syntax with tidyverse, at the cost of potentially introducing +conflicts. This can be avoided by using the \code{::} operator where required. +} +\examples{ +\dontrun{ +# Return values of field `basisOfRecord` +request_metadata() |> + unnest() |> + filter(field == basisOfRecord) |> + collect() + +# Using `galah::unnest()` in this way is equivalent to: +show_all(fields, "basisOfRecord") |> + show_values() + +# to add information to a species list: +request_metadata() |> + filter(list == "dr650") |> + select(everything()) |> + unnest() |> + collect() +} +} diff --git a/tests/testthat/_snaps/print.md b/tests/testthat/_snaps/print.md new file mode 100644 index 00000000..43284d92 --- /dev/null +++ b/tests/testthat/_snaps/print.md @@ -0,0 +1,105 @@ +# object of class `data-request` formats correctly + + Code + request_data() + Message + Object of type data_request containing: + * type occurrences + +# populated `data_request()` prints correctly + + Code + filter(identify(galah_call(), "crinia"), year == 2025) + Message + Object of type data_request containing: + * type occurrences + * identify search_term: crinia + * filter Object of class `data_filter`: year == 2025 + +# object of class `metadata-request` formats correctly + + Code + request_data() + Message + Object of type data_request containing: + * type occurrences + +# object of class `metadata-request` formats correctly with `filter() + + Code + filter(request_metadata(), list == "dr650") + Message + Object of type metadata_request containing: + * type lists + * filter Object of class `metadata_filter` with type `list` (n = 0 entries) + +# object of class `metadata-request` formats correctly with `identify() + + Code + identify(request_metadata(), "Crinia") + Message + Object of type metadata_request containing: + * type taxa + * identify search_term: Crinia + +# object of class `metadata-request` formats correctly with `identify() |> unnest() + + Code + unnest(identify(request_metadata(), "Crinia")) + Message + Object of type metadata_request containing: + * type taxa-unnest + * identify search_term: Crinia + +# object of class `query` formats correctly + + Code + capture(identify(request_metadata(), "Crinia")) + Message + Object of class query with type metadata/taxa-single + * url: https://api.ala.org.au/namematching/api/search?q=Crinia + +# object of class `computed_query` formats correctly + + Code + x + Message + Object of class computed query with type metadata/taxa-single + * url: https://api.ala.org.au/namematching/api/search?q=Crinia + +# object of class `query_set` formats correctly + + Code + compound(filter(galah_call(), basisOfRecord == "HUMAN_OBSERVATION")) + Message + Object of class query_set containing 3 queries: + * metadata/fields url: https://api.ala.org.au/occurrences/index/fields + * metadata/assertions url: https://api.ala.org.au/occurrences/assertions/codes + * data/occurrences url: + https://api.ala.org.au/occurrences/occurrences/offline/... + +# `galah_config()` formats correctly + + Code + galah_config() + Message + `galah` package configuration + + Package + x verbose + v run_checks + x send_email + v caching + i directory: something + + User + x authentication + username [Provided] + email ala4r@ala.org.au + password [Provided] + download_reason_id 10 + + Atlas + Atlas of Living Australia (ALA), Australia + + diff --git a/tests/testthat/test-atlas_citation.R b/tests/testthat/test-atlas_citation.R index c0811451..bd296599 100644 --- a/tests/testthat/test-atlas_citation.R +++ b/tests/testthat/test-atlas_citation.R @@ -37,17 +37,25 @@ test_that("atlas_citation attributes GBIF DOIs correctly", { expect_true(grepl("GBIF Occurrence Download", citation)) }) +quiet_collect <- function(x){ + quiet_fun <- purrr::quietly(collect.data_request) + quiet_fun(x) |> + purrr::pluck("result") +} + test_that("atlas_citation works on a real download", { skip_if_offline(); skip_on_ci() galah_config(email = "ala4r@ala.org.au") x <- galah_call() |> identify("Heleioporus") |> filter(year == 2022) |> - collect() + quiet_collect() text_out <- atlas_citation(x) |> suppressMessages() grepl("^The citation for this dataset is:", text_out) |> expect_true() grepl("Please consider citing R & galah", text_out) |> expect_true() -}) \ No newline at end of file +}) + +rm(quiet_collect) \ No newline at end of file diff --git a/tests/testthat/test-atlas_counts.R b/tests/testthat/test-atlas_counts.R index 1540f98c..6498d6a6 100644 --- a/tests/testthat/test-atlas_counts.R +++ b/tests/testthat/test-atlas_counts.R @@ -1,288 +1,12 @@ galah_config(verbose = FALSE) -test_that("`collapse()` doesn't ping an API for type = `'occurrences-count'`", { - skip_if_offline(); skip_on_ci() - result <- request_data() |> - filter(year == 2010) |> - count() |> - collapse() - expect_true(inherits(result, "query")) - expect_equal(result$type, "data/occurrences-count") -}) - -test_that("atlas_counts works with no arguments", { +test_that("`atlas_counts()` works with no arguments", { skip_if_offline(); skip_on_ci() count <- atlas_counts() expect_s3_class(count, c("tbl_df", "tbl", "data.frame")) expect_gt(count$count, 0) }) -test_that("count() |> collect() works with no arguments", { - skip_if_offline(); skip_on_ci() - count <- galah_call() |> - count() |> - collect() - expect_s3_class(count, c("tbl_df", "tbl", "data.frame")) - expect_gt(count$count, 0) -}) - -test_that("`identify()` reduces the number of records returned by `count()`", { - skip_if_offline(); skip_on_ci() - counts_all <- galah_call() |> - count() |> - collect() - counts_mammals <- galah_call() |> - identify("Perameles") |> - count() |> - collect() - expect_type(counts_mammals$count, "integer") - expect_true(counts_mammals$count < counts_all$count) -}) - -test_that("`filter()` works with dates", { - skip_if_offline(); skip_on_ci() - counts <- galah_call() |> - filter(species == "Cacatua galerita", - eventDate >= "2023-01-07T00:00:00Z", - eventDate < "2023-01-08T00:00:00Z") |> - count() |> - collect() - expect_type(counts$count, "integer") -}) - -test_that("`galah_identify()` works with `atlas_counts()`", { - skip_if_offline(); skip_on_ci() - counts_all <- galah_call() |> - count() |> - collect() - counts_mammals <- galah_call() |> - galah_identify("Perameles") |> - atlas_counts() - expect_type(counts_mammals$count, "integer") - expect_true(counts_mammals$count < counts_all$count) -}) - -test_that("`count()` handles multiple 'group by' variables", { - skip_if_offline(); skip_on_ci() - counts <- galah_call() |> - filter(year >= 2021) |> - group_by(year, month, basisOfRecord) |> - count() |> - collect() - expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) - expect_equal(names(counts), - c("year", "month", "basisOfRecord", "count")) - expect_true(all(counts$year >= 2021)) -}) - -test_that("`count()` handles 'species' as a 'group by' variable", { - skip_if_offline(); skip_on_ci() - counts <- galah_call() |> - filter(year > 2020) |> - identify("Perameles") |> - group_by(species, year) |> - count() |> - collect() - expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) - expect_true(all(names(counts) %in% c("species", "year", "count"))) - expect_true(all(counts$year > 2020)) - expect_true(all(grepl("^Perameles", counts$species))) -}) - -test_that("atlas_counts handles 'taxonConceptID' as a 'group by' variable", { - skip_if_offline(); skip_on_ci() - counts <- galah_call() |> - identify("Perameles") |> - filter(year >= 2015) |> - group_by(taxonConceptID, year) |> - count() |> - collect() - expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) - expect_equal(names(counts), - c("taxonConceptID", "year", "count")) - expect_true(all(counts$year >= 2015)) -}) - -# test added to address Issue #265 -test_that("atlas_counts handles `identify()` in combination with `OR` statements in `filter()`", { - skip_if_offline(); skip_on_ci() - regions <- c("Dampierland","Wet Tropics") - counts <- galah_call() |> - identify("Squamata") |> - filter(cl1048 %in% regions) |> - group_by(cl1048) |> - count() |> - collect() - expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) - expect_equal(nrow(counts), 2) - expect_true(all(regions %in% counts$cl1048)) - expect_true(all(counts$count > 0)) -}) - -test_that("atlas_counts returns same result with filter using `,` and `&`", { - skip_if_offline(); skip_on_ci() - count_comma <- galah_call() |> - filter(year >= 2010, year < 2020) |> - count() |> - collect() - count_and <- galah_call() |> - filter(year >= 2010 & year < 2020) |> - count() |> - collect() - expect_equal(count_comma, count_and) -}) - -# Spatial not checked -test_that("atlas_counts filters correctly with galah_geolocate/galah_polygon", { - skip_if_offline(); skip_on_ci() - wkt <- "POLYGON ((146.5425 -42.63203, 146.8312 -43.13203, 147.4085 -43.13203, 147.6972 -42.63203, 147.4085 -42.13203, 146.8312 -42.13203, 146.5425 -42.63203))" |> - sf::st_as_sfc() - base_query <- galah_call() |> - identify("Perameles") |> - filter(year >= 2020) |> - count() - counts <- base_query |> collect() - counts_filtered <- base_query |> - galah_geolocate(wkt) |> - collect() - expect_s3_class(counts_filtered, c("tbl_df", "tbl", "data.frame")) - count_1 <- counts_filtered$count[1] - count_2 <- counts$count[1] - expect_lt(count_1, count_2) -}) - -test_that("atlas_counts filters correctly with galah_geolocate/galah_bbox/galah_radius", { - skip_if_offline(); skip_on_ci() - wkt <- "POLYGON ((146.5425 -42.63203, 146.8312 -43.13203, 147.4085 -43.13203, 147.6972 -42.63203, 147.4085 -42.13203, 146.8312 -42.13203, 146.5425 -42.63203))" |> - sf::st_as_sfc() - base_query <- galah_call() |> - identify("Perameles") |> - filter(year >= 2020) |> - count() - counts <- base_query |> collect() - counts_filtered <- base_query |> - galah_geolocate(wkt, type = "bbox") |> - collect() - counts_filtered_radius <- base_query |> - galah_geolocate(lon = 147, - lat = -42.9, - radius = 20, - type = "radius") |> - collect() - expect_s3_class(counts_filtered, c("tbl_df", "tbl", "data.frame")) - expect_s3_class(counts_filtered_radius, c("tbl_df", "tbl", "data.frame")) - count_1 <- counts_filtered$count[1] - count_2 <- counts$count[1] - count_3 <- counts_filtered_radius$count[1] - expect_lt(count_1, count_2, count_3) -}) - -test_that("atlas_counts returns species counts", { - skip_if_offline(); skip_on_ci() - count_species <- galah_call(type = "species") |> - count() |> - collect() - count_records <- galah_call() |> - count() |> - collect() - expect_s3_class(count_species, c("tbl_df", "tbl", "data.frame")) - expect_type(count_species$count, "integer") - expect_gt(count_species$count, 0) - expect_lt(count_species$count, count_records$count) -}) - -test_that("species counts work with group_by()", { - skip_if_offline(); skip_on_ci() - count_species <- galah_call(type = "species") |> - identify("Crinia") |> - filter(year >= 2020) |> - group_by(year) |> - arrange(year) |> - count() |> - collect() - count_records <- galah_call() |> - identify("Crinia") |> - filter(year >= 2020) |> - group_by(year) |> - arrange(year) |> - count() |> - collect() - expect_s3_class(count_species, c("tbl_df", "tbl", "data.frame")) - expect_type(count_species$count, "integer") - expect_gte(nrow(count_species), 4) - expect_true(all(count_species$count > 0)) - expect_true(all(count_species$count < 100)) - expect_true(all(count_records$year == count_species$year)) - expect_true(all(count_records$count >= count_species$count)) -}) - -test_that("order of `group_by()` doesn't affect result in `atlas_counts()", { - # This is a test for Issue #198 raised by @shandiya - # https://github.com/AtlasOfLivingAustralia/galah-R/issues/198 - skip_if_offline(); skip_on_ci() - reg <- c("Gibson Desert", - "Little Sandy Desert", - "Southern Volcanic Plain", - "Flinders Lofty Block") - # IBRA then year (with no limit) - ibra_year <- galah_call() |> - filter(cl1048 == reg, - year >= 1971, - year <= 2020) |> - group_by(cl1048, year) |> - arrange(desc(count)) |> - count() |> - collect() - year_ibra <- galah_call() |> - filter(cl1048 == reg, - year >= 1971, - year <= 2020) |> - group_by(year, cl1048) |> - arrange(desc(count)) |> - count() |> - collect() - # we expect these two tibbles to have the same colnames, - # but in a different order (respecting user-supplied info) - expect_true(all(colnames(ibra_year) %in% c("year", "cl1048", "count"))) - expect_true(all(colnames(year_ibra) %in% c("year", "cl1048", "count"))) - expect_false(all(colnames(year_ibra) == colnames(ibra_year))) - # we also expect them to have the same number of rows, and the same total - expect_equal(nrow(ibra_year), nrow(year_ibra)) - expect_equal(sum(ibra_year$count), sum(year_ibra$count)) - ## FIXME: - # expect_equal(ibra_year, year_ibra) # this fails, - ## because `arrange` is not (re-)applied after download, - ## so rows are not in the same order -}) - -## BELOW HERE TESTS WILL FAIL - -# capture_requests("count_piped_2", { -# test_that("atlas_counts ignores superfluous piped arguments", { -# counts <- galah_call() |> -# filter(year >= 2018) |> -# group_by(year) |> -# galah_down_to(species) |> -# select(taxonConceptID) |> -# count() -# expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) -# expect_equal(names(counts), c("year", "count")) -# expect_gt(nrow(counts), 0) -# }) -# }) - -# test_that("atlas_counts handles pagination", { -# vcr::use_cassette("count_with_pagination", { -# counts <- galah_call() |> -# group_by(year) |> -# slice_head(n = 101) |> -# count() -# }) -# expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) -# expect_equal(nrow(counts), 101) -# expect_equal(names(counts), c("year", "count")) -# }) - # FIXME: check non-piped args work # FIXME: check `galah_` functions work -# FIXME: check `atlas_counts` +# FIXME: check `atlas_counts` \ No newline at end of file diff --git a/tests/testthat/test-atlas_media.R b/tests/testthat/test-atlas_media.R index a09dedde..4b2a8540 100644 --- a/tests/testthat/test-atlas_media.R +++ b/tests/testthat/test-atlas_media.R @@ -1,32 +1,68 @@ +quiet_collapse <- function(x, ...){ + collapse_fun <- purrr::quietly(dplyr::collapse) + collapse_fun(x, ...) |> + purrr::pluck("result") +} +quiet_compute <- function(x){ + compute_fun <- purrr::quietly(dplyr::compute) + compute_fun(x) |> + purrr::pluck("result") +} +quiet_collect <- function(x, ...){ + purrr_collect <- purrr::quietly(dplyr::collect) + purrr_collect(x, ...) |> + purrr::pluck("result") +} +purrr_media <- purrr::quietly(atlas_media) +quiet_media <- function(...){ + purrr_media(...) |> + purrr::pluck("result") +} +purrr_collect_media <- purrr::quietly(collect_media) +purrr_config <- purrr::quietly(galah_config) + test_that("atlas_media fails when no filters are provided", { expect_error(atlas_media()) }) test_that("`atlas_media()` works", { skip_if_offline(); skip_on_ci() - galah_config(email = "ala4r@ala.org.au") + capture_config <- purrr_config(email = "ala4r@ala.org.au") media_data <- galah_call() |> identify("Microseris lanceolata") |> filter(year == 2019) |> - atlas_media() + quiet_media() expect_s3_class(media_data, c("tbl_df", "tbl", "data.frame")) expect_gte(nrow(media_data), 3) expect_gte(ncol(media_data), 3) + # set `all_fields` = TRUE + all_media_data <- galah_call() |> + identify("Microseris lanceolata") |> + filter(year == 2019) |> + quiet_media(all_fields = TRUE) + # test for `original_file_name` field (as per issue #266) + expect_gt(ncol(all_media_data), + ncol(media_data)) + any(colnames(all_media_data) == "original_file_name") |> + expect_true() }) -test_that("collect_media suggests `galah_config(directory =)` when a temp folder is set as the directory", { +test_that("`collect_media()` works", { skip_if_offline(); skip_on_ci() - atlas_query <- atlas_media( - identify = galah_identify("Regent Honeyeater"), - filter = galah_filter(year == 2012)) + capture_config <- purrr_config(email = "ala4r@ala.org.au") + atlas_query <- galah_call() |> + identify("Anthochaera (Xanthomyza) phrygia") |> # Regent Honeyeater + filter(year == 2012) |> + quiet_media() media_dir <- "Temp" unlink(media_dir, recursive = TRUE) dir.create(media_dir) - galah_config(directory = media_dir) - expect_message( - collect_media(atlas_query), - cli::cli_text("{cli::col_magenta('To change which file directory media files are saved to, use `galah_config(directory = )`.')}") - ) + x <- purrr_config(directory = media_dir) # assigned to prevent message + # we don't run tests on this object + result <- purrr_collect_media(atlas_query) + media_files <- list.files(media_dir, + pattern = ".jpg$|.mpg$") + expect_true(length(media_files) == result$result$n) unlink(media_dir, recursive = TRUE) }) @@ -38,44 +74,42 @@ test_that("`collapse()` and `collect()` work for `type = 'media'`", { "/", list.files(dir, pattern = ".jpg$|.jpeg$")) |> file.info() |> - pull(size) |> + dplyr::pull(size) |> sum() } ## PART 1: request occurrence data - galah_config(email = "ala4r@ala.org.au") + capture_config <- purrr_config(email = "ala4r@ala.org.au") occ_collect <- request_data() |> identify("Litoria peronii") |> filter(year == 2010, !is.na(images)) |> select(group = "media") |> - collect(wait = TRUE) + quiet_collect(wait = TRUE) ## PART 2: request media metadata # collapse media_collapse <- request_metadata() |> - filter(media == occ_collect) |> - collapse() + filter(media == unlist(dplyr::pull(occ_collect, "images"))) |> + quiet_collapse() expect_true(inherits(media_collapse, "query")) - expect_equal(length(media_collapse), 5) + expect_equal(length(media_collapse), 4) expect_equal(names(media_collapse), c("type", "url", "headers", - "body", - "filter")) + "request")) expect_true(media_collapse$type == "metadata/media") # compute - media_compute <- compute(media_collapse) + media_compute <- quiet_compute(media_collapse) expect_true(inherits(media_compute, "computed_query")) - expect_equal(length(media_compute), 5) + expect_equal(length(media_compute), 4) expect_equal(names(media_compute), c("type", "url", "headers", - "body", - "filter")) + "request")) # collect - media_collect <- collect(media_compute) + media_collect <- quiet_collect(media_compute) expect_s3_class(media_collect, c("tbl_df", "tbl", "data.frame")) expect_gte(nrow(media_collect), 1) expect_gte(ncol(media_collect), 6) @@ -85,23 +119,25 @@ test_that("`collapse()` and `collect()` work for `type = 'media'`", { media_dir <- "test_media" unlink(media_dir, recursive = TRUE) dir.create(media_dir) - galah_config(directory = media_dir) + capture_config <- purrr_config(directory = media_dir) # collapse df <- slice_head(media_collect, n = 3) files_collapse <- request_files() |> filter(media == df) |> - collapse(thumbnail = TRUE) + quiet_collapse(thumbnail = TRUE) expect_true(inherits(files_collapse, "query")) - expect_equal(length(files_collapse), 3) - expect_equal(names(files_collapse), c("type", "url", "headers")) + expect_equal(length(files_collapse), 4) + expect_equal(names(files_collapse), + c("type", "url", "headers", "request")) expect_equal(files_collapse$type, "files/media") # compute - files_compute <- compute(files_collapse) + files_compute <- quiet_compute(files_collapse) expect_true(inherits(files_compute, "computed_query")) - expect_equal(length(files_compute), 3) - expect_equal(names(files_compute), c("type", "url", "headers")) + expect_equal(length(files_compute), 4) + expect_equal(names(files_compute), + c("type", "url", "headers", "request")) # collect - files_collect <- collect(files_compute) + files_collect <- quiet_collect(files_compute) expect_s3_class(files_collect, c("tbl_df", "tbl", "data.frame")) expect_gte(nrow(files_collect), 1) expect_gte(ncol(files_collect), 2) @@ -110,16 +146,20 @@ test_that("`collapse()` and `collect()` work for `type = 'media'`", { # check passing `thumbnail` via `collect()`, filesize files_collapse <- request_files() |> filter(media == df) |> - collect(thumbnail = FALSE) + quiet_collect(thumbnail = FALSE) fullsize <- get_image_sizes(media_dir) expect_lt(thumbsize, fullsize) # PART 4: check collect_media() expect_error(collect_media(df, path = NULL)) # check gives error when `path` is set - expect_message(collect_media(df), - "Downloaded 3 files successfully") + result <- purrr_collect_media(df) + result |> + purrr::pluck("messages") |> + stringr::str_detect("Downloaded 3 files successfully") |> + any() |> + expect_true() fullsize <- get_image_sizes(media_dir) - collect_media(df, thumbnail = TRUE) + collect_media_catcher <- purrr_collect_media(df, thumbnail = TRUE) thumbsize <- get_image_sizes(media_dir) expect_lt(thumbsize, fullsize) unlink(media_dir, recursive = TRUE) @@ -127,7 +167,8 @@ test_that("`collapse()` and `collect()` work for `type = 'media'`", { test_that("atlas_media gives a warning when old arguments are used", { skip_if_offline(); skip_on_ci() - galah_config(email = "ala4r@ala.org.au", atlas = "Australia") + x <- purrr_config(email = "ala4r@ala.org.au", + atlas = "Australia") expect_error({ media_data <- atlas_media( identify = galah_identify("Microseris lanceolata"), @@ -143,36 +184,44 @@ test_that("collect_media handles different file formats", { galah_config(email = "ala4r@ala.org.au", directory = media_dir) media_data <- galah_call() |> - galah_identify("Regent Honeyeater") |> - galah_filter(year == 2024) |> - atlas_media() + identify("Regent Honeyeater") |> + filter(multimedia %in% c("Sound", "Image"), year == 2024) |> + quiet_media() # sample one of each multimedia type to shorten testing time - media_data <- media_data |> - dplyr::group_by(multimedia) |> - dplyr::sample_n(size = 1) + media_summary <- media_data |> + dplyr::group_by(media_type) |> + dplyr::sample_n(size = 2) expect_equal(sort(unique(media_data$multimedia)), - c("Image", "Image | Sound", "Sound")) - collect_media(media_data, thumbnail = TRUE) + c("Image", "Image | Sound")) + result <- purrr_collect_media(media_summary, thumbnail = TRUE) downloads <- list.files(path = media_dir) expect_true(any(grepl(".mpg$", downloads))) # sounds expect_true(any(grepl(".jpg$", downloads))) # images - file_count <- length(list.files(media_dir)) - # expect_equal(file_count, nrow(media_data)) # FIXME correct n + file_count <- length(list.files(media_dir)) unlink(media_dir, recursive = TRUE) + # FIXME: we don't test that files are 'valid'; i.e. that images load + # properly. This is important for sound files which may not load properly if + # thumbnail settings are ignored. + + # FIXME: worth testing that `thumbnail` is ignored for sounds }) test_that("collect_media handles thumbnails", { skip_if_offline(); skip_on_ci() media_dir <- "test_media" - galah_config(email = "ala4r@ala.org.au", + purrr_config(email = "ala4r@ala.org.au", directory = media_dir) z <- galah_call() |> - galah_identify("Candovia aberrata") |> - galah_filter(year == 2023) |> - atlas_media() + identify("Candovia aberrata") |> + filter(year == 2023) |> + quiet_media() # successfully downloads, messages number of failed downloads - expect_message(collect_media(z, thumbnail = TRUE), - "Failed 3 downloads") + result <- purrr_collect_media(z) + result |> + purrr::pluck("messages") |> + stringr::str_detect("Downloaded [[:digit:]]+ files successfully") |> + any() |> + expect_true() downloads <- list.files(path = media_dir) expect_true(any(grepl(".jpg$", downloads))) # images unlink(media_dir, recursive = TRUE) @@ -185,3 +234,4 @@ cache_dir <- tempfile() dir.create(cache_dir) galah_config(directory = cache_dir) rm(cache_dir) +rm(quiet_media, purrr_collect_media, purrr_config) \ No newline at end of file diff --git a/tests/testthat/test-atlas_occurrences.R b/tests/testthat/test-atlas_occurrences.R index 4f38d70a..9639653b 100644 --- a/tests/testthat/test-atlas_occurrences.R +++ b/tests/testthat/test-atlas_occurrences.R @@ -1,4 +1,26 @@ -test_that("atlas_occurrences fails nicely if no email is provided", { +# set up quiet functions for testing reasons +quiet_collapse <- function(x){ + collapse_fun <- purrr::quietly(dplyr::collapse) + collapse_fun(x) |> + purrr::pluck("result") +} +quiet_compute <- function(x){ + compute_fun <- purrr::quietly(dplyr::compute) + compute_fun(x) |> + purrr::pluck("result") +} +quiet_collect <- function(x, ...){ + purrr_collect <- purrr::quietly(dplyr::collect) + purrr_collect(x, ...) |> + purrr::pluck("result") +} +quiet_occurrences <- function(...){ + occ_fun <- purrr::quietly(atlas_occurrences) + occ_fun(...) |> + purrr::pluck("result") +} + +test_that("`atlas_occurrences()` fails nicely if no email is provided", { galah_config(email = "", run_checks = FALSE) expect_error({ galah_call() |> @@ -8,12 +30,12 @@ test_that("atlas_occurrences fails nicely if no email is provided", { galah_config(email = "ala4r@ala.org.au", run_checks = TRUE) }) -test_that("atlas_occurrences doesn't allow large downloads", { +test_that("`atlas_occurrences()` doesn't allow large downloads", { galah_config(atlas = "Australia") expect_error(atlas_occurrences()) }) -test_that("atlas_occurrences gives a nice error for invalid emails", { +test_that("`atlas_occurrences()` gives a nice error for invalid emails", { galah_config(email = "test@test.org.au") expect_error({ galah_call() |> @@ -25,6 +47,7 @@ test_that("atlas_occurrences gives a nice error for invalid emails", { test_that("collapse(type = 'occurrences') creates an object", { skip_if_offline(); skip_on_ci() + galah_config(email = "ala4r@ala.org.au") result <- galah_call() |> identify("Perameles") |> collapse() @@ -35,6 +58,7 @@ test_that("collapse(type = 'occurrences') creates an object", { test_that("`compute(type = 'occurrences')` works", { skip_if_offline(); skip_on_ci() + galah_config(email = "ala4r@ala.org.au") base_query <- galah_call() |> identify("Vulpes vulpes") |> filter(year <= 1900, @@ -45,7 +69,7 @@ test_that("`compute(type = 'occurrences')` works", { expect_equal(length(query_collapse), 4) expect_equal(query_collapse$type, "data/occurrences") # compute - response <- compute(base_query) + response <- quiet_compute(base_query) expect_true(inherits(response, "computed_query")) expect_true(response$type == "data/occurrences") expect_equal(names(response), @@ -56,25 +80,27 @@ test_that("`compute(type = 'occurrences')` works", { "status_url", "cancel_url", "search_url", - "fields")) + "fields", + "request")) }) # test all filters and type of columns in one call -test_that("atlas_occurrences accepts all narrowing functions inline", { +test_that("`atlas_occurrences()` accepts all narrowing functions inline", { skip_if_offline(); skip_on_ci() + galah_config(email = "ala4r@ala.org.au") expected_cols <- c("decimalLatitude", "decimalLongitude", "eventDate", - "scientificName", "taxonConceptID", "recordID", - "dataResourceName", "occurrenceStatus", "stateProvince", - "ZERO_COORDINATE") + "basisOfRecord", "scientificName", "taxonConceptID", + "recordID", "dataResourceName", "occurrenceStatus", + "stateProvince", "ZERO_COORDINATE") poly <- "POLYGON((146.7 -34.6,147.9 -34.6,147.9 -35.7,146.7 -35.7,146.7 -34.6))" - base_query <- galah_call(type = "occurrences") |> + base_query <- galah_call() |> identify("Polytelis swainsonii") |> filter(year == 2018) |> select(group = "basic", stateProvince, ZERO_COORDINATE) |> st_crop(poly) # w <- collapse(base_query) # collect with wait = FALSE - ensure `type` is specified - x <- compute(base_query) + x <- quiet_compute(base_query) expect_equal(names(x), c("type", "status", @@ -83,22 +109,23 @@ test_that("atlas_occurrences accepts all narrowing functions inline", { "status_url", "cancel_url", "search_url", - "fields")) + "fields", + "request")) expect_s3_class(x, "computed_query") # collect with wait = TRUE - y <- collect(x, wait = TRUE) + y <- quiet_collect(x, wait = TRUE) expect_s3_class(y, c("tbl_df", "tbl", "data.frame")) expect_setequal(names(y), expected_cols) expect_equal(unique(y$stateProvince), "New South Wales") }) # repeat above using `galah_` functions -test_that("atlas_occurrences accepts all narrowing functions in pipe", { +test_that("`atlas_occurrences()` accepts all narrowing functions in pipe", { skip_if_offline(); skip_on_ci() expected_cols <- c("decimalLatitude", "decimalLongitude", "eventDate", - "scientificName", "taxonConceptID", "recordID", - "dataResourceName", "occurrenceStatus", "stateProvince", - "ZERO_COORDINATE", "COORDINATE_INVALID") + "basisOfRecord", "scientificName", "taxonConceptID", + "recordID", "dataResourceName", "occurrenceStatus", + "stateProvince", "ZERO_COORDINATE", "COORDINATE_INVALID") poly <- "POLYGON((146.7 -34.6,147.9 -34.6,147.9 -35.7,146.7 -35.7,146.7 -34.6))" occ <- galah_call() |> galah_filter(year >= 2018) |> @@ -108,45 +135,47 @@ test_that("atlas_occurrences accepts all narrowing functions in pipe", { COORDINATE_INVALID) |> galah_identify("Polytelis swainsonii") |> galah_geolocate(poly) |> - atlas_occurrences() + quiet_occurrences() expect_setequal(names(occ), expected_cols) expect_equal(unique(occ$stateProvince), "New South Wales") }) -test_that("atlas_occurrences() and friends accept a file name", { +test_that("`atlas_occurrences()`() and friends accept a file name", { skip_if_offline(); skip_on_ci() # set up directory for testing purposes directory <- "TEMP" unlink(directory, recursive = TRUE) dir.create(directory) - galah_config(directory = directory) + galah_config(directory = directory, + email = "ala4r@ala.org.au") # set up query base_query <- galah_call() |> - galah_filter(year <= 1970) |> - galah_select(group = "basic") |> - galah_identify("Crinia tinnula") + filter(year <= 1970) |> + select(group = "basic") |> + identify("Crinia tinnula") # base_query |> count() |> collect() # n = 49 on 2023-11-15 # test `atlas_occurrences` occ1 <- base_query |> - atlas_occurrences(file = "crinia_file") + quiet_occurrences(file = "crinia_file") expect_s3_class(occ1, c("tbl_df", "tbl", "data.frame")) expect_true(any(list.files(directory) == "crinia_file.zip")) # test `collect` - occ2 <- base_query |> collect(file = "crinia_collect") + occ2 <- base_query |> quiet_collect(file = "crinia_collect") expect_equal(occ1, occ2) expect_true(any(list.files(directory) == "crinia_collect.zip")) # test DOIs doi <- "10.26197/ala.0c1e8744-a639-47f1-9a5f-5610017ba060" - occ3 <- atlas_occurrences(doi = doi, file = "test_doi") + occ3 <- quiet_occurrences(doi = doi, file = "test_doi") expect_true(any(list.files(directory) == "test_doi.zip")) # doi with collect - occ3 <- atlas_occurrences(doi = doi, file = "test_doi") + occ3 <- quiet_occurrences(doi = doi, file = "test_doi") expect_true(any(list.files(directory) == "test_doi.zip")) occ4 <- request_data() |> filter(doi == doi) |> - collect(file = "test_doi2") + quiet_collect(file = "test_doi2") expect_equal(occ3, occ4) expect_true(any(list.files(directory) == "test_doi2.zip")) + expect_false(is.null(attributes(occ3)$doi)) # clean up unlink("TEMP", recursive = TRUE) cache_dir <- tempfile() @@ -155,29 +184,34 @@ test_that("atlas_occurrences() and friends accept a file name", { rm(cache_dir) }) -test_that("atlas_occurrences() errors with an invalid DOI", { +test_that("`atlas_occurrences()`() errors with an invalid DOI", { expect_error(atlas_occurrences(doi = "random_doi")) }) -test_that("atlas_occurrences downloads data from a DOI", { +test_that("`atlas_occurrences()` downloads data from a DOI", { skip_if_offline(); skip_on_ci() doi <- "10.26197/ala.0c1e8744-a639-47f1-9a5f-5610017ba060" - result1 <- atlas_occurrences(doi = doi) + result1 <- quiet_occurrences(doi = doi) expect_s3_class(result1, c("tbl_df", "tbl", "data.frame" )) expect_equal(nrow(result1), 9) expect_equal(ncol(result1), 68) # and with other syntax result2 <- request_data() |> filter(doi == doi) |> - collapse() - expect_equal(length(result2), 4) + quiet_collapse() + expect_equal(length(result2), 5) + expect_equal(names(result2), + c("type", "url", "headers", "download", "request")) expect_s3_class(result2, "query") expect_equal(result2$type, "data/occurrences-doi") - result3 <- collect(result2) + result3 <- quiet_collect(result2) expect_equal(result1, result3) # TODO add file name tests }) +# TODO check DOIs still placed correctly in capture(), collapse() etc + +# NOTE: This test is *very* slow - worth investigating why test_that("`atlas_occurrences()` places DOI in `attr()` correctly", { skip_if_offline(); skip_on_ci() directory <- "TEMP" @@ -188,7 +222,7 @@ test_that("`atlas_occurrences()` places DOI in `attr()` correctly", { identify("Vulpes vulpes") |> filter(year <= 1900, basisOfRecord == "PRESERVED_SPECIMEN") |> - collect(mint_doi = TRUE) + quiet_collect(mint_doi = TRUE) y <- attr(x, "doi") expect_false(is.null(y)) expect_true(grepl("^https://doi.org/", y)) @@ -198,7 +232,7 @@ test_that("`atlas_occurrences()` places DOI in `attr()` correctly", { identify("Vulpes vulpes") |> filter(year <= 1900, basisOfRecord == "PRESERVED_SPECIMEN") |> - atlas_occurrences(mint_doi = TRUE) + quiet_occurrences(mint_doi = TRUE) y <- attr(x, "doi") expect_false(is.null(y)) expect_true(grepl("^https://doi.org/", y)) @@ -209,30 +243,7 @@ test_that("`atlas_occurrences()` places DOI in `attr()` correctly", { rm(cache_dir) }) -test_that("group_by works on occurrences", { - skip_if_offline(); skip_on_ci() - # compare group_by with atlas_species - x <- galah_call() |> - filter(year == 2024, - genus == "Crinia") |> - group_by(speciesID) |> - collect() - y <- galah_call() |> - filter(year == 2024, - genus == "Crinia") |> - atlas_species() - expect_equal(x, y) - # try with a different variable - z <- galah_call() |> - filter(year == 2024, - genus == "Crinia") |> - group_by(genusID) |> - collect() - expect_true(inherits(z, c("tbl_df", "tbl", "data.frame"))) - expect_equal(colnames(z)[1], "taxon_concept_id") -}) - -test_that("atlas_occurrences() doesn't return secret information", { +test_that("`atlas_occurrences()`() doesn't return secret information", { skip_if_offline(); skip_on_ci() RUN <- FALSE skip_if((!file.exists("testdata/SECRETS.txt") | !RUN), @@ -252,13 +263,13 @@ test_that("atlas_occurrences() doesn't return secret information", { group = "basic") x_start <- collapse(data_request) # option to add tests here to ensure url is correctly constructed - x <- collect(x_start) + x <- quiet_collect(x_start) # import email address from SECRETS and check again # NOTE: SECRETS.txt has been added to .gitignore - # It should never be placed on GitHub + # **It should never be placed on GitHub** email <- readLines("testdata/SECRETS.txt", warn = FALSE) galah_config(email = email) - y <- collect(data_request) + y <- quiet_collect(data_request) expect_equal(nrow(x), nrow(y)) expect_equal(ncol(x), ncol(y)) expect_equal(colnames(x), colnames(y)) @@ -266,3 +277,5 @@ test_that("atlas_occurrences() doesn't return secret information", { # reset galah_config(email = "ala4r@ala.org.au") }) + +rm(quiet_collapse, quiet_compute, quiet_collect, quiet_occurrences) \ No newline at end of file diff --git a/tests/testthat/test-atlas_species.R b/tests/testthat/test-atlas_species.R index d964630a..d06167ba 100644 --- a/tests/testthat/test-atlas_species.R +++ b/tests/testthat/test-atlas_species.R @@ -1,48 +1,90 @@ +quiet_collect <- function(x){ + quiet_fun <- purrr::quietly(dplyr::collect) + quiet_fun(x) |> + purrr::pluck("result") +} + +quiet_species <- function(...){ + quiet_fun <- purrr::quietly(atlas_species) + quiet_fun(...) |> + purrr::pluck("result") +} + test_that("atlas_species fails nicely if no email is provided", { skip_if_offline(); skip_on_ci() galah_config(email = "", run_checks = TRUE) # run_checks = FALSE doesn't provide error message - expect_error(atlas_species(identify = galah_identify("Osphranter"))) + galah_call() |> + identify("Osphranter") |> + atlas_species() |> + expect_error() galah_config(email = "ala4r@ala.org.au") }) -test_that("atlas_species returns a tibble", { +test_that("`atlas_species()` returns a tibble", { skip_if_offline(); skip_on_ci() - species <- atlas_species(identify = galah_identify("Osphranter")) + species <- galah_call() |> + identify("Osphranter") |> + quiet_species() expect_s3_class(species, c("tbl_df", "tbl", "data.frame")) expect_gt(nrow(species), 1) }) -test_that("atlas_species returns correct results when piped", { +test_that("`select()` works for type = 'species' with `counts`", { + skip_if_offline(); skip_on_ci() + x <- galah_call(type = "species") |> + identify("Crinia") |> + select(counts) |> + quiet_collect() + expect_equal(colnames(x), c("species_id", "count")) + expect_gt(nrow(x), 10) +}) + +test_that("`select()` works for type = 'species' with group = 'taxonomy'", { + skip_if_offline(); skip_on_ci() + x <- galah_call(type = "species") |> + identify("Crinia") |> + select(counts, lists, group = "taxonomy") |> + quiet_collect() + expect_true(all(c("species", "count", "kingdom", "phylum") %in% colnames(x))) + expect_gt(nrow(x), 10) +}) + +test_that("`atlas_species()` returns correct results when piped", { skip_if_offline(); skip_on_ci() galah_config(run_checks = TRUE) species <- galah_call() |> - galah_identify("perameles") |> - galah_filter(year > 2000) |> - atlas_species() - expected_species <- c("Perameles nasuta", "Perameles gunnii", - "Perameles pallescens", "Perameles bougainville") - expected_cols <- c("taxon_concept_id", "species_name", + identify("perameles") |> + filter(year > 2000) |> + quiet_species() + expected_species <- c("Perameles nasuta", + "Perameles gunnii", + "Perameles fasciata", + "Perameles pallescens", + "Perameles bougainville") + expected_cols <- c("species", "species_name", "scientific_name_authorship", "taxon_rank", "kingdom", "phylum", "class", "order", "family", "genus", "vernacular_name") expect_setequal(names(species), expected_cols) - expect_equal(species$species_name[1:4], expected_species) + (expected_species %in% species$species_name) |> + all() |> + expect_true() expect_gt(nrow(species), 1) expect_s3_class(species, c("tbl_df", "tbl", "data.frame")) }) -test_that("atlas_species returns correct results filtered by galah_geolocate", { +test_that("`atlas_species()` returns correct results filtered by galah_geolocate", { skip_if_offline(); skip_on_ci() galah_config(run_checks = TRUE) wkt <- "POLYGON ((146.5425 -42.63203, 146.8312 -43.13203, 147.4085 -43.13203, 147.6972 -42.63203, 147.4085 -42.13203, 146.8312 -42.13203, 146.5425 -42.63203))" species <- galah_call() |> - galah_identify("perameles") |> - galah_filter(year > 2000) |> - galah_geolocate(wkt) |> - atlas_species() + identify("perameles") |> + filter(year > 2000) |> + geolocate(wkt) |> + quiet_species() expected_species <- c("Perameles gunnii") - expected_cols <- c("taxon_concept_id", "species_name", + expected_cols <- c("species", "species_name", "scientific_name_authorship", "taxon_rank", "kingdom", "phylum", "class", "order", "family", "genus", "vernacular_name") @@ -52,28 +94,29 @@ test_that("atlas_species returns correct results filtered by galah_geolocate", { expect_s3_class(species, c("tbl_df", "tbl", "data.frame")) }) -test_that("atlas_species works when no species are present", { +test_that("`atlas_species()` works when no species are present", { skip_if_offline(); skip_on_ci() galah_config(email = "ala4r@ala.org.au") galah_config(run_checks = TRUE) result <- galah_call() |> - galah_identify("eolophus") |> - galah_filter(cl1048 == "Kimberley") |> - atlas_species() + identify("eolophus") |> + filter(cl1048 == "Kimberley") |> + quiet_species() expect_s3_class(result, c("tbl_df", "tbl", "data.frame")) + expect_equal(ncol(result), 11) + expect_equal(nrow(result), 0) }) test_that("collapse -> compute -> collect workflow is functional", { skip_if_offline(); skip_on_ci() galah_config(email = "ala4r@ala.org.au") - query <- galah_call(method = "data", - type = "species") |> - galah_identify("perameles") |> - galah_filter(year > 2000) + query <- galah_call(type = "species") |> + identify("perameles") |> + filter(year > 2000) species_collapse <- query |> collapse() species_compute <- species_collapse |> compute() - species_collect <- species_compute |> collect() - atlas_species <- query |> atlas_species() + species_collect <- species_compute |> quiet_collect() + atlas_species <- query |> quiet_species() expect_s3_class(query, "data_request") expect_s3_class(species_collapse, "query") @@ -102,8 +145,8 @@ test_that("atlas_species reformats column names when empty tibble is returned", species <- galah_call() |> identify("sarcopterygii") |> filter(cl1048 == "Wet Tropics") |> - atlas_species() - expected_cols <- c("taxon_concept_id", "species_name", + quiet_species() + expected_cols <- c("species", "species_name", "scientific_name_authorship", "taxon_rank", "kingdom", "phylum", "class", "order", "family", "genus", "vernacular_name") @@ -112,3 +155,20 @@ test_that("atlas_species reformats column names when empty tibble is returned", expect_equal(nrow(species), 0) expect_s3_class(species, c("tbl_df", "tbl", "data.frame")) }) + +test_that("`atlas_species()` accepts `distinct()` to set the grouping variable", { + skip_if_offline(); skip_on_ci() + + genera <- galah_call() |> + identify("Limnodynastidae") |> + distinct(genusID) |> + quiet_species() + expect_s3_class(genera, c("tbl_df", "tbl", "data.frame")) + expect_true(nrow(genera) > 4 & nrow(genera) < 10) + expect_gte(ncol(genera), 10) # test that `.keep_all = TRUE` is not required + # as this is implied (and asserted) by calling `atlas_species()` + all(genera$taxon_rank == "genus") |> + expect_true() +}) + +rm(quiet_collect, quiet_species) \ No newline at end of file diff --git a/tests/testthat/test-atlas_taxonomy.R b/tests/testthat/test-atlas_taxonomy.R index e73c5e60..6da51990 100644 --- a/tests/testthat/test-atlas_taxonomy.R +++ b/tests/testthat/test-atlas_taxonomy.R @@ -1,4 +1,4 @@ -test_that("atlas_taxonomy 'identify' must be specified", { +test_that("`atlas_taxonomy()` 'identify' must be specified", { expect_error({ galah_call() |> filter(rank == "kingdom") |> @@ -6,7 +6,7 @@ test_that("atlas_taxonomy 'identify' must be specified", { }) }) -test_that("atlas_taxonomy 'filter' must be specified", { +test_that("`atlas_taxonomy()` 'filter' must be specified", { expect_error({ galah_call() |> identify("Animalia") |> @@ -14,7 +14,7 @@ test_that("atlas_taxonomy 'filter' must be specified", { }) }) -test_that("atlas_taxonomy requires a single taxon", { +test_that("`atlas_taxonomy()` requires a single taxon", { expect_error({ galah_call() |> identify("Animalia", "Plantae") |> @@ -23,22 +23,22 @@ test_that("atlas_taxonomy requires a single taxon", { }) }) -test_that("atlas_taxonomy makes a tree when piped", { +test_that("`atlas_taxonomy()` makes a `tibble` when piped", { skip_if_offline(); skip_on_ci() tree <- galah_call() |> identify("fungi") |> filter(rank >= phylum) |> - atlas_taxonomy() + atlas_taxonomy() expect_s3_class(tree, c("tbl_df", "tbl", "data.frame")) expect_equal(ncol(tree), 4) expect_gte(nrow(tree), 1) }) -test_that("atlas_taxonomy example runs", { +test_that("`atlas_taxonomy()` example runs", { skip_if_offline(); skip_on_ci() df <- galah_call() |> - galah_identify("chordata") |> - galah_filter(rank == class) |> + identify("chordata") |> + filter(rank == class) |> atlas_taxonomy() expect_s3_class(df, c("tbl_df", "tbl", "data.frame")) expect_equal(ncol(df), 4) diff --git a/tests/testthat/test-authentication.R b/tests/testthat/test-authentication.R new file mode 100644 index 00000000..6e48298c --- /dev/null +++ b/tests/testthat/test-authentication.R @@ -0,0 +1,146 @@ +quiet_config <- purrr::quietly(galah_config) + +test_that("`request_metadata()` works for type = `config`", { + skip_if_offline(); skip_on_ci() + result <- request_metadata(type = "config") |> + collect() + expect_equal(nrow(result), 1) + expect_equal(ncol(result), 4) + expect_true(all( + c("client_id", "authorize_url", "token_url", "scopes") %in% + colnames(result))) +}) + +test_that("`request_metadata()` caches type `config` correctly", { + skip_if_offline(); skip_on_ci() + reset_cache() + x <- request_metadata(type = "config") |> + collect() + result <- request_metadata(type = "config") |> + capture() + expect_true(!is.null(result$data)) +}) + +test_that("`authenticate()` works in-pipe for metadata", { + skip("authentication requires interactivity") + galah_config(caching = FALSE) # turn off caching to force galah to call an API + query <- request_metadata(type = "reasons") |> + authenticate() + + result <- capture(query) + is.null(result$request$authenticate) |> + expect_false() + + result2 <- compound(result) + expect_equal(length(result2), 2) + purrr::map(result2, \(a){a$type}) |> + unlist() |> + expect_equal(c("metadata/config", "metadata/reasons")) + + galah_config(caching = TRUE) +}) + +test_that("`authenticate()` works in-pipe for occurrences", { + skip("authentication requires interactivity") + + query <- galah_call() |> + authenticate() |> + identify("Litoria dentata") |> + filter(year == 2025) |> + compound() + expect_equal(length(query), 6) + is.null(query[[6]]$request$authenticate) |> + expect_false() + + x <- collapse(query) + x |> + purrr::pluck("request", "authenticate") |> + is.null() |> + expect_false() + + y <- compute(x) + inherits(y, "computed_query") |> + expect_true() + any(names(y) == "authenticate") |> + expect_true() + + z <- collect(y) + stringr::str_detect(names(z), "^sensitive_") |> + any() |> + expect_true() +}) + +test_that("setting `authentication` to `TRUE` changes data returned", { + skip("authentication requires interactivity") + + # NOTE: credentials *should* give access to sensitive data for Tasmania *only* + # subset to species on Tasmania's sensitive species list + galah_config(authenticate = TRUE) + + # convert to query set first + x_queryset <- galah_call() |> + filter(species_list_uid == "dr491") |> + compound() + expect_equal(length(x_queryset), 5) + expect_equal(x_queryset[[1]]$type, + "metadata/config") + is.null(x_queryset[[5]]$authenticate) |> + expect_false() + # unclear whether it is _critical_ for compound() to source `show_all_config()` here + # but some use cases it probably is necessary, and for the others it is + # 'free' because of caching, so probably best to leave it for now + + # then collapse + x_query <- collapse(x_queryset) + stringr::str_detect(x_query$url, "&email=") |> + expect_false() + # TODO add `authenticate` to `print.query()` + + # compute + y <- compute(x_query) # note: triggers authentication a second time?! + # check for messages + + result <- collect(y) |> + expect_no_error() # check for exception to `check_field_identities()` + + # check sensitive columns exist + colnames(result) |> + stringr::str_detect("^sensitive_") |> + any() |> + expect_true() + + # expect some sensitive spatial data to not be NA + na_values <- result |> + dplyr::pull(sensitive_decimalLatitude) |> + is.na() + any(!na_values) |> + expect_true() + + # expect higher precision in sensitive columns, where any data given + precise_latitude <- result$sensitive_decimalLatitude[!na_values] |> + as.character() |> + nchar() + imprecise_latitude <- result$decimalLatitude[!na_values] |> + as.character() |> + nchar() + imprecise_latitude[is.na(imprecise_latitude)] <- 0 + # test + all(precise_latitude >= imprecise_latitude) |> + expect_true() + + unlink("TEST-SENSITIVE-DATA", recursive = TRUE) + config <- quiet_config(authenticate = FALSE, + directory = "TESTING") +}) + +# Downloading from a DOI fails +# galah_call() |> +# filter(doi == "ala.3d0e08ac-d0ec-420d-a1f7-8cde778e82f6") |> +# authenticate() |> +# collect() +# May be same problem as previously documented + +rm(quiet_config) +galah_config(caching = TRUE, + authenticate = FALSE, + email = "ala4r@ala.org.au") diff --git a/tests/testthat/test-caching.R b/tests/testthat/test-caching.R new file mode 100644 index 00000000..ed58433b --- /dev/null +++ b/tests/testthat/test-caching.R @@ -0,0 +1,40 @@ +reset_cache() + +test_that("`retrieve_cache()` works without any arugments", { + x <- retrieve_cache() + expect_equal( + names(x), + c("assertions", "fields", "profiles", "reasons")) +}) + +test_that("`retrieve_cache()` works with a valid arugment", { + x <- retrieve_cache("fields") + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) + expect_equal(nrow(x), 0) +}) + +test_that("`retrieve_cache()` returns `NULL` with an invalid arugment", { + x <- retrieve_cache("something") + expect_true(is.null(x)) +}) + +test_that("`update_cache()` adds arbitrary slots to the cache", { + update_cache(something = list(1, 2, 3)) + # check 'full' cache contains the requisite information + expect_equal( + names(retrieve_cache()), + c("assertions", "fields", "profiles", "reasons", "something")) + # check we can return a single slot + expect_equal( + retrieve_cache("something"), + list(1, 2, 3)) + reset_cache() +}) + +test_that("`overwrite_cache()` overwrites whole cache", { + overwrite_cache(list(x = 1, y = 2)) + x <- retrieve_cache() + expect_equal(names(x), c("x", "y")) + expect_equal(x, list(x = 1, y = 2)) + reset_cache() +}) \ No newline at end of file diff --git a/tests/testthat/test-count_arrange_slice.R b/tests/testthat/test-dplyr-arrange_slice.R similarity index 92% rename from tests/testthat/test-count_arrange_slice.R rename to tests/testthat/test-dplyr-arrange_slice.R index 5238b98e..cc0a69fa 100644 --- a/tests/testthat/test-count_arrange_slice.R +++ b/tests/testthat/test-dplyr-arrange_slice.R @@ -1,10 +1,16 @@ +quiet_collect <- function(x){ + quiet_fun <- purrr::quietly(dplyr::collect) + quiet_fun(x) |> + purrr::pluck("result") +} + test_that("default is to arrange by decending order of count", { skip_if_offline(); skip_on_ci() result <- galah_call() |> filter(year >= 2015) |> group_by(year) |> count() |> - collect() + quiet_collect() expect_true(all(diff(result$count) < 0)) expect_true(nrow(result) > 7) expect_equal(ncol(result), 2) @@ -18,7 +24,7 @@ test_that("arrange in increasing order of count", { group_by(year) |> count() |> arrange(count) |> - collect() + quiet_collect() expect_true(all(diff(result$count) > 0)) expect_true(nrow(result) > 7) expect_equal(ncol(result), 2) @@ -32,7 +38,7 @@ test_that("arrange in decreasing order of count using `desc()`", { group_by(year) |> count() |> arrange(desc(count)) |> - collect() + quiet_collect() expect_true(all(diff(result$count) < 0)) expect_true(nrow(result) > 7) expect_equal(ncol(result), 2) @@ -46,7 +52,7 @@ test_that("arrange in increasing order of year", { group_by(year) |> count() |> arrange(year) |> - collect() + quiet_collect() expect_true(all(diff(as.integer(result$year)) == 1)) expect_true(nrow(result) > 7) expect_equal(ncol(result), 2) @@ -60,7 +66,7 @@ test_that("arrange in decreasing order of year using `desc()`", { group_by(year) |> count() |> arrange(desc(year)) |> - collect() + quiet_collect() expect_true(all(diff(as.integer(result$year)) == -1)) expect_true(nrow(result) > 7) expect_equal(ncol(result), 2) @@ -76,7 +82,7 @@ test_that("`arrange()` by `count` and `slice_head()` work together", { count() |> arrange(count) |> slice_head(n = 5) |> - collect() + quiet_collect() expect_true(all(diff(result$count) > 0)) expect_equal(nrow(result), 5) expect_equal(ncol(result), 2) @@ -88,7 +94,7 @@ test_that("`arrange()` by `count` and `slice_head()` work together", { count() |> arrange(desc(count)) |> slice_head(n = 5) |> - collect() + quiet_collect() expect_true(all(diff(result2$count) < 0)) expect_equal(nrow(result), 5) expect_equal(ncol(result), 2) @@ -106,7 +112,7 @@ test_that("`arrange()` by `year` and `slice_head()` work together", { count() |> arrange(year) |> slice_head(n = 5) |> - collect() + quiet_collect() expect_true(all(diff(as.integer(result$year)) == 1)) expect_equal(result$year[[1]], "2015") expect_equal(nrow(result), 5) @@ -119,7 +125,7 @@ test_that("`arrange()` by `year` and `slice_head()` work together", { count() |> arrange(desc(year)) |> slice_head(n = 5) |> - collect() + quiet_collect() expect_true(all(diff(as.integer(result2$year)) == -1)) expect_false(result2$year[[1]] == "2015") expect_equal(nrow(result), 5) @@ -137,9 +143,10 @@ test_that("`group_by()` with multiple fields works with `slice_head()`", { count() |> arrange(desc(count)) |> # NOTE: desc(count) applied within groups only; is this correct? slice_head(n = 5) |> # same issue as above - collect() + quiet_collect() expect_equal(ncol(result), 3) expect_equal(colnames(result), c("year", "basisOfRecord", "count")) expect_true(all(xtabs(~result$year) <= 5)) # current year may not have all values yet }) +rm(quiet_collect) \ No newline at end of file diff --git a/tests/testthat/test-dplyr-count.R b/tests/testthat/test-dplyr-count.R new file mode 100644 index 00000000..56e1fb7f --- /dev/null +++ b/tests/testthat/test-dplyr-count.R @@ -0,0 +1,335 @@ +quiet_collect <- function(x){ + quiet_fun <- purrr::quietly(dplyr::collect) + quiet_fun(x) |> + purrr::pluck("result") +} + +test_that("`collapse()` creates a query object for type = `'occurrences-count'`", { + skip_if_offline(); skip_on_ci() + result <- request_data() |> + filter(year == 2010) |> + count() |> + collapse() + expect_true(inherits(result, "query")) + expect_equal(result$type, "data/occurrences-count") +}) + +test_that("count() |> collect() works with no arguments", { + skip_if_offline(); skip_on_ci() + count <- galah_call() |> + count() |> + collect() + expect_s3_class(count, c("tbl_df", "tbl", "data.frame")) + expect_gt(count$count, 0) +}) + +test_that("`identify()` reduces the number of records returned by `count()`", { + skip_if_offline(); skip_on_ci() + counts_all <- galah_call() |> + count() |> + collect() + counts_mammals <- galah_call() |> + identify("Perameles") |> + count() |> + collect() + expect_type(counts_mammals$count, "integer") + expect_true(counts_mammals$count < counts_all$count) +}) + +test_that("`filter()` works with dates", { + skip_if_offline(); skip_on_ci() + counts <- galah_call() |> + filter(species == "Cacatua galerita", + eventDate >= "2023-01-07T00:00:00Z", + eventDate < "2023-01-08T00:00:00Z") |> + count() |> + collect() + expect_type(counts$count, "integer") +}) + +test_that("`identify()` works for counts", { + skip_if_offline(); skip_on_ci() + counts_all <- galah_call() |> + count() |> + collect() + counts_mammals <- galah_call() |> + galah_identify("Perameles") |> + atlas_counts() + expect_type(counts_mammals$count, "integer") + expect_true(counts_mammals$count < counts_all$count) +}) + +test_that("`count(year)` groups by `year`", { + skip_if_offline(); skip_on_ci() + result <- galah_call() |> + filter(year >= 2015) |> + count(year) |> + quiet_collect() + expect_true(all(diff(result$count) < 0)) + expect_true(nrow(result) > 7) + expect_true(all(result$year >= 2015)) + expect_equal(ncol(result), 2) + expect_equal(colnames(result), c("year", "count")) +}) + +test_that("`count()` handles multiple variables", { + skip_if_offline(); skip_on_ci() + counts <- galah_call() |> + filter(year >= 2021, + month >= 10) |> + count(year, month, basisOfRecord) |> + collect() + expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) + expect_equal(names(counts), + c("year", "month", "basisOfRecord", "count")) + expect_true(all(counts$year >= 2021)) +}) + +test_that("`count()` handles 'species' as a 'group by' variable", { + skip_if_offline(); skip_on_ci() + counts <- galah_call() |> + filter(year > 2020) |> + identify("Perameles") |> + group_by(species, year) |> + count() |> + collect() + expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) + expect_true(all(names(counts) %in% c("species", "year", "count"))) + expect_true(all(counts$year > 2020)) + expect_true(all(grepl("^Perameles", counts$species))) +}) + +test_that("`count()` handles 'taxonConceptID' as a 'group by' variable", { + skip_if_offline(); skip_on_ci() + counts <- galah_call() |> + identify("Perameles") |> + filter(year >= 2015) |> + group_by(taxonConceptID, year) |> + count() |> + collect() + expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) + expect_equal(names(counts), + c("taxonConceptID", "year", "count")) + expect_true(all(counts$year >= 2015)) +}) + +test_that("`count()` handles 'speciesID' as a 'group by' variable", { + skip_if_offline(); skip_on_ci() + # FIXME: Currently returns colname `speciesID.https://biodiversity.org` + counts <- galah_call() |> + filter(year == 1900, + genus == "Crinia") |> + count(speciesID) |> + collect() + expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) + expect_equal(names(counts), + c("speciesID", "count")) +}) + +# test added to address Issue #265 +test_that("`count()` handles `identify()` in combination with `OR` statements in `filter()`", { + skip_if_offline(); skip_on_ci() + regions <- c("Dampierland","Wet Tropics") + counts <- galah_call() |> + identify("Squamata") |> + filter(cl1048 %in% regions) |> + group_by(cl1048) |> + count() |> + collect() + expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(counts), 2) + expect_true(all(regions %in% counts$cl1048)) + expect_true(all(counts$count > 0)) +}) + +test_that("`count()` returns same result with filter using `,` and `&`", { + skip_if_offline(); skip_on_ci() + count_comma <- galah_call() |> + filter(year >= 2010, year < 2020) |> + count() |> + collect() + count_and <- galah_call() |> + filter(year >= 2010 & year < 2020) |> + count() |> + collect() + expect_equal(count_comma, count_and) +}) + +test_that("`count()` filters correctly with galah_geolocate/galah_polygon", { + skip_if_offline(); skip_on_ci() + wkt <- "POLYGON ((146.5425 -42.63203, 146.8312 -43.13203, 147.4085 -43.13203, 147.6972 -42.63203, 147.4085 -42.13203, 146.8312 -42.13203, 146.5425 -42.63203))" |> + sf::st_as_sfc() + base_query <- galah_call() |> + identify("Perameles") |> + filter(year >= 2020) |> + count() + counts <- base_query |> collect() + counts_filtered <- base_query |> + geolocate(wkt) |> + quiet_collect() + expect_s3_class(counts_filtered, c("tbl_df", "tbl", "data.frame")) + count_1 <- counts_filtered$count[1] + count_2 <- counts$count[1] + expect_lt(count_1, count_2) +}) + +test_that("`count()` filters correctly with galah_geolocate/galah_bbox/galah_radius", { + skip_if_offline(); skip_on_ci() + wkt <- "POLYGON ((146.5425 -42.63203, 146.8312 -43.13203, 147.4085 -43.13203, 147.6972 -42.63203, 147.4085 -42.13203, 146.8312 -42.13203, 146.5425 -42.63203))" |> + sf::st_as_sfc() + base_query <- galah_call() |> + identify("Perameles") |> + filter(year >= 2020) |> + count() + counts <- base_query |> collect() + counts_filtered <- base_query |> + geolocate(wkt, type = "bbox") |> + quiet_collect() + counts_filtered_radius <- base_query |> + geolocate(lon = 147, + lat = -42.9, + radius = 20, + type = "radius") |> + quiet_collect() + expect_s3_class(counts_filtered, c("tbl_df", "tbl", "data.frame")) + expect_s3_class(counts_filtered_radius, c("tbl_df", "tbl", "data.frame")) + count_1 <- counts_filtered$count[1] + count_2 <- counts$count[1] + count_3 <- counts_filtered_radius$count[1] + expect_lt(count_1, count_2, count_3) +}) + +test_that("`count()` returns species counts", { + skip_if_offline(); skip_on_ci() + count_species <- galah_call(type = "species") |> + count() |> + collect() + count_records <- galah_call() |> + count() |> + collect() + expect_s3_class(count_species, c("tbl_df", "tbl", "data.frame")) + expect_type(count_species$count, "integer") + expect_gt(count_species$count, 0) + expect_lt(count_species$count, count_records$count) +}) + +test_that("species counts work with group_by()", { + skip_if_offline(); skip_on_ci() + count_species <- galah_call(type = "species") |> + identify("Crinia") |> + filter(year >= 2020) |> + group_by(year) |> + arrange(year) |> + count() |> + collect() + count_records <- galah_call() |> + identify("Crinia") |> + filter(year >= 2020) |> + group_by(year) |> + arrange(year) |> + count() |> + collect() + expect_s3_class(count_species, c("tbl_df", "tbl", "data.frame")) + expect_type(count_species$count, "integer") + expect_gte(nrow(count_species), 4) + expect_true(all(count_species$count > 0)) + expect_true(all(count_species$count < 50)) + expect_true(all(count_records$year == count_species$year)) + expect_true(all(count_records$count >= count_species$count)) +}) + +test_that("order of `group_by()` doesn't affect result in `count()", { + # This is a test for Issue #198 raised by @shandiya + # https://github.com/AtlasOfLivingAustralia/galah-R/issues/198 + skip_if_offline(); skip_on_ci() + reg <- c("Gibson Desert", + "Little Sandy Desert", + "Southern Volcanic Plain", + "Flinders Lofty Block") + # IBRA then year (with no limit) + ibra_year <- galah_call() |> + filter(cl1048 == reg, + year >= 1971, + year <= 2020) |> + group_by(cl1048, year) |> + arrange(desc(count)) |> + count() |> + collect() + year_ibra <- galah_call() |> + filter(cl1048 == reg, + year >= 1971, + year <= 2020) |> + group_by(year, cl1048) |> + arrange(desc(count)) |> + count() |> + collect() + # we expect these two tibbles to have the same colnames, + # but in a different order (respecting user-supplied info) + expect_true(all(colnames(ibra_year) %in% c("year", "cl1048", "count"))) + expect_true(all(colnames(year_ibra) %in% c("year", "cl1048", "count"))) + expect_false(all(colnames(year_ibra) == colnames(ibra_year))) + # we also expect them to have the same number of rows, and the same total + expect_equal(nrow(ibra_year), nrow(year_ibra)) + expect_equal(sum(ibra_year$count), sum(year_ibra$count)) +}) + +test_that("`group_by()` works when > 1 `filter()`", { + skip_if_offline(); skip_on_ci() + chosen_species <- c("Eolophus roseicapilla", "Platycercus elegans") + x <- request_data() |> + filter(species == chosen_species) |> + group_by(species) |> + count() |> + collect() + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_equal(x$species, chosen_species) + expect_equal(colnames(x), c("species", "count")) + expect_equal(nrow(x), 2) + # previously, adding an additional field (`year` below) removed one species from resulting tibble + y <- request_data() |> + filter(species == chosen_species, + year == 2023) |> + group_by(species) |> + count() |> + collect() + expect_s3_class(y, c("tbl_df", "tbl", "data.frame")) + expect_equal(y$species, chosen_species) + expect_equal(colnames(y), c("species", "count")) + expect_equal(nrow(y), 2) + expect_true(all(x$count > y$count)) # extra filter + # compare to different syntax + z <- galah_call() |> + galah_filter(species == c("Eolophus roseicapilla", "Platycercus elegans"), + year == 2023) |> + galah_group_by(species) |> + atlas_counts() + expect_equal(y, z) +}) + +test_that("`select()` works for count queries", { + skip_if_offline(); skip_on_ci() + x <- galah_call() |> + filter(year == 2024, + genus == "Crinia") |> + count(speciesID) |> + select(dplyr::everything()) |> + collect() + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_gte(ncol(x), 4) # traditionally this was only two cols +}) + +## BELOW HERE TESTS WILL FAIL + +# capture_requests("count_piped_2", { +# test_that("`atlas_counts()` ignores superfluous piped arguments", { +# counts <- galah_call() |> +# filter(year >= 2018) |> +# group_by(year) |> +# galah_down_to(species) |> +# select(taxonConceptID) |> +# count() +# expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) +# expect_equal(names(counts), c("year", "count")) +# expect_gt(nrow(counts), 0) +# }) +# }) \ No newline at end of file diff --git a/tests/testthat/test-dplyr-distinct.R b/tests/testthat/test-dplyr-distinct.R new file mode 100644 index 00000000..fd8edb05 --- /dev/null +++ b/tests/testthat/test-dplyr-distinct.R @@ -0,0 +1,167 @@ +# set up quiet functions for testing reasons +quiet_collect <- function(x){ + purrr_collect <- purrr::quietly(collect.data_request) + purrr_collect(x) |> + purrr::pluck("result") +} +galah_config(email = "ala4r@ala.org.au") + +test_that("`group_by()` without `distinct()` returns occurrences, not species", { + skip_if_offline(); skip_on_ci() + query <- galah_call() |> + filter(year == 2024, + genus == "Crinia") + expected_n <- query |> + count() |> + quiet_collect() + query_final <- query |> + group_by(speciesID) + expect_equal(query_final$type, "occurrences") + x <- quiet_collect(query_final) + expect_s3_class(x, + c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x), expected_n$count) + expect_true(length(unique(x$taxonConceptID)) < nrow(x)) +}) + +test_that("distinct() with no arguments and no `group_by()` returns occurrences (i.e. does nothing)", { + skip_if_offline(); skip_on_ci() + query <- galah_call() |> + filter(year == 2024, + genus == "Crinia") + expected_n <- query |> + count() |> + quiet_collect() + query_final <- query |> + distinct() + expect_equal(query_final$type, "occurrences") + x <- quiet_collect(query_final) + expect_s3_class(x, + c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x), expected_n$count) + expect_true(length(unique(x$taxonConceptID)) < nrow(x)) +}) + +test_that("`group_by() |> distinct(.keep_all = FALSE)` uses occurrences-count, but *doesn't* return counts", { + skip_if_offline(); skip_on_ci() + x <- galah_call() |> + filter(year == 2024, + genus == "Crinia") |> + group_by(speciesID) |> + distinct() |> + quiet_collect() + expect_s3_class(x, + c("tbl_df", "tbl", "data.frame")) + expect_equal(ncol(x), 1) + expect_equal(colnames(x), "speciesID") + expect_equal(length(unique(x$speciesID)), + nrow(x)) +}) + +test_that("`group_by() |> distinct(.keep_all = TRUE)` converts type from occurrences to species", { + skip_if_offline(); skip_on_ci() + query <- galah_call() |> + filter(year == 2024, + genus == "Crinia") |> + group_by(speciesID) |> + distinct(.keep_all = TRUE) |> + collapse() + expect_equal(query$type, "data/species") + x <- quiet_collect(query) + expect_s3_class(x, + c("tbl_df", "tbl", "data.frame")) + expect_equal(length(unique(x$species)), + nrow(x)) +}) + +test_that("distinct(variable, .keep_all = FALSE) returns field values", { + skip_if_offline(); skip_on_ci() + result <- galah_call() |> + distinct(cl11226) |> + quiet_collect() + # should return values for that field + expect_s3_class(result, + c("tbl_df", "tbl", "data.frame")) + expect_equal(colnames(result), "cl11226") + expect_gte(nrow(result), 10) +}) + +test_that("`distinct(.keep_all = TRUE)` sets species queries", { + skip_if_offline(); skip_on_ci() + result <- galah_call() |> + identify("Osphranter") |> + distinct(speciesID, .keep_all = TRUE) |> + quiet_collect() + expect_gte(nrow(result), 4) + expect_s3_class(result, + c("tbl_df", "tbl", "data.frame")) + expect_contains(colnames(result), + c("species", "species_name", "kingdom")) +}) + +test_that("`distinct(.keep_all = TRUE)` accepts non-species-level groupings", { + skip_if_offline(); skip_on_ci() + genera <- galah_call() |> + identify("Limnodynastidae") |> + distinct(genusID, .keep_all = TRUE) |> + quiet_collect() + expect_s3_class(genera, c("tbl_df", "tbl", "data.frame")) + expect_true(nrow(genera) > 4 & nrow(genera) < 10) + all(genera$taxon_rank == "genus") |> + expect_true() +}) + +test_that("`distinct(variable) |> count()` can be used to count the number of levels", { + # NOTE: This is set to `basisOfRecord` because the number of values is easy to verify + # taxonomic identifiers are more slippery and therefore less reliable to test + skip_if_offline(); skip_on_ci() + levels_all <- galah_call() |> + distinct(basisOfRecord) |> + quiet_collect() + levels_count <- galah_call() |> + distinct(basisOfRecord) |> + count() |> + quiet_collect() + expect_s3_class(levels_count, + c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(levels_count), 1) + expect_equal(nrow(levels_all), levels_count$count) +}) + +test_that("`group_by(something) |> distinct(speciesID) |> count()` gives grouped number of categories", { + skip_if_offline(); skip_on_ci() + result <- galah_call() |> + identify("perameles") |> + group_by(basisOfRecord) |> + distinct(speciesID) |> + count() |> + collect() + expect_equal(colnames(result), + c("basisOfRecord", "count")) + all(result$count < 10) |> + expect_true() +}) + +# FIXME: not implemented +# test_that("`add_count() |> distinct()` adds record counts to each species", { +# skip_if_offline(); skip_on_ci() +# query <- galah_call() |> +# filter(year == 2024, +# genus == "Crinia") |> +# group_by(speciesID) |> +# add_count() |> +# distinct(.keep_all = TRUE) |> +# collapse() +# expect_equal(query$type, "data/species") +# x <- quiet_collect(query) +# expect_s3_class(x, +# c("tbl_df", "tbl", "data.frame")) +# expect_equal(length(unique(x$speciesID)), +# nrow(x)) +# }) + +# test_that("add_count() without `distinct()` just adds a column of 1s", { +# skip("not built") +# }) + +rm(quiet_collect) \ No newline at end of file diff --git a/tests/testthat/test-galah_filter.R b/tests/testthat/test-dplyr-filter.R similarity index 63% rename from tests/testthat/test-galah_filter.R rename to tests/testthat/test-dplyr-filter.R index e00a9d45..6eb5b568 100644 --- a/tests/testthat/test-galah_filter.R +++ b/tests/testthat/test-dplyr-filter.R @@ -1,27 +1,30 @@ -test_that("galah_filter works for a single 'equals' argument", { +# set up quiet functions for testing reasons +purrr_collect <- purrr::quietly(collect.data_request) + +test_that("`filter()` works for a single 'equals' argument", { filters <- galah_filter(year == 2010) expect_s3_class(filters, c("tbl_df", "tbl", "data.frame")) expect_equal(nrow(filters), 1) }) -test_that("galah_filter gives an error for single equals sign", { +test_that("`filter()` gives an error for single equals sign", { expect_error(galah_filter(year = 2010)) }) -test_that("galah_filter works with assertions", { +test_that("`filter()` works with assertions", { skip_if_offline(); skip_on_ci() count_all <- atlas_counts() |> - pull(count) + dplyr::pull(count) count_invalid_spp <- galah_call() |> filter(assertions == "INVALID_SCIENTIFIC_NAME") |> count() |> collect() |> - pull(count) + dplyr::pull(count) count_valid_spp <- galah_call() |> filter(assertions != "INVALID_SCIENTIFIC_NAME") |> count() |> collect() |> - pull(count) + dplyr::pull(count) expect_lt(count_invalid_spp, count_all) expect_lt(count_valid_spp, count_all) expect_lt(count_invalid_spp, count_valid_spp) @@ -29,21 +32,21 @@ test_that("galah_filter works with assertions", { count_all) }) -test_that("galah_filter handles multiple assertions", { +test_that("`filter()` handles multiple assertions", { skip_if_offline(); skip_on_ci() # OR statements all_records <- atlas_counts() |> - pull(count) + dplyr::pull(count) either_valid <- galah_call() |> - galah_filter(assertions != c("INVALID_SCIENTIFIC_NAME", "COORDINATE_INVALID")) |> + filter(assertions != c("INVALID_SCIENTIFIC_NAME", "COORDINATE_INVALID")) |> count() |> collect() |> - pull(count) + dplyr::pull(count) either_invalid <- galah_call() |> filter(assertions == c("INVALID_SCIENTIFIC_NAME", "COORDINATE_INVALID")) |> count() |> collect() |> - pull(count) + dplyr::pull(count) expect_lt(either_valid, all_records) expect_lt(either_invalid, all_records) expect_lt(either_invalid, either_valid) @@ -55,13 +58,13 @@ test_that("galah_filter handles multiple assertions", { assertions == "COORDINATE_INVALID") |> count() |> collect() |> - pull(count) + dplyr::pull(count) both_valid <- galah_call() |> filter(assertions != "INVALID_SCIENTIFIC_NAME", assertions != "COORDINATE_INVALID") |> count() |> collect() |> - pull(count) + dplyr::pull(count) expect_lt(both_valid, all_records) expect_lt(both_invalid, all_records) expect_lt(both_invalid, both_valid) @@ -75,69 +78,73 @@ test_that("galah_filter handles multiple assertions", { }) -test_that("galah_filter handles assertions and taxa", { +test_that("`filter()` handles assertions and taxa", { skip_if_offline(); skip_on_ci() problem_families <- galah_call() |> filter(assertions == "INVALID_SCIENTIFIC_NAME") |> group_by(family) |> slice_head(n = 5) |> count() |> - collect() + purrr_collect() + problem_families |> + purrr::pluck("messages") |> + stringr::str_detect("Limiting to first 5 of ") |> + expect_true() top_family <- galah_call() |> - identify(problem_families$family[1]) |> + identify(problem_families$result$family[1]) |> filter(assertions == "INVALID_SCIENTIFIC_NAME") |> group_by(family) |> count() |> - collect() - expect_equal(problem_families$count[1], top_family$count) + collect() # quiet by default + expect_equal(problem_families$result$count[1], top_family$count) }) -test_that("galah_filter returns empty tibble when no arguments specified", { +test_that("`filter()` returns empty tibble when no arguments specified", { filters <- galah_filter() expect_s3_class(filters, c("tbl_df", "tbl", "data.frame")) expect_equal(nrow(filters), 0) }) -test_that("galah_filter works for two 'equals' arguments", { +test_that("`filter()` works for two 'equals' arguments", { filters <- galah_filter(year == 2010, basisOfRecord == "HUMAN_OBSERVATION") expect_s3_class(filters, c("tbl_df", "tbl", "data.frame")) expect_equal(nrow(filters), 2) expect_equal(filters$variable, c("year", "basisOfRecord")) }) -test_that("galah_filter works for two arguments of the same variable", { +test_that("`filter()` works for two arguments of the same variable", { filters <- galah_filter(year >= 2010, year <= 2015) expect_s3_class(filters, c("tbl_df", "tbl", "data.frame")) expect_equal(nrow(filters), 2) expect_equal(">=", filters$logical[1]) }) -test_that("galah_filter works with urls", { +test_that("`filter()` works with urls", { filters <- galah_filter( taxonConceptID == "https://biodiversity.org.au/afd/taxa/065f1da4-53cd-40b8-a396-80fa5c74dedd") expect_true(nchar(filters$query) > 70) }) -test_that("galah_filter parses '&' correctly", { +test_that("`filter()` parses '&' correctly", { filters <- galah_filter(year >= 2010 & year < 2020) expect_equal(nrow(filters), 1) expect_equal(filters$value, "2010&2020") expect_equal(filters$query, "year:[2010 TO *] AND year:[* TO 2020] AND -(year:\"2020\")") }) -test_that("galah_filter handles numeric queries for text fields", { +test_that("`filter()` handles numeric queries for text fields", { filters <- galah_filter(cl22 >= "Tasmania") expect_equal(filters$query, "cl22:[Tasmania TO *]") }) -test_that("galah_filter handles OR statements", { +test_that("`filter()` handles OR statements", { filters <- galah_filter(year == 2010 | year == 2020) expect_equal(nrow(filters), 1) expect_equal(filters$value, "2010|2020") expect_equal(filters$query, "((year:\"2010\") OR (year:\"2020\"))") }) -test_that("galah_filter handles OR statements", { +test_that("`filter()` handles OR statements", { filters <- galah_filter(raw_scientificName == "Litoria jervisiensis" | raw_scientificName == "Litoria peronii") expect_equal(nrow(filters), 1) @@ -145,7 +152,7 @@ test_that("galah_filter handles OR statements", { "((raw_scientificName:\"Litoria jervisiensis\") OR (raw_scientificName:\"Litoria peronii\"))") }) -test_that("galah_filter works with 3 OR statements", { +test_that("`filter()` works with 3 OR statements", { filters <- galah_filter(basisOfRecord == "HumanObservation" | basisOfRecord == "MachineObservation" | basisOfRecord == "PreservedSpecimen") @@ -155,19 +162,19 @@ test_that("galah_filter works with 3 OR statements", { "((basisOfRecord:\"HumanObservation\") OR (basisOfRecord:\"MachineObservation\") OR (basisOfRecord:\"PreservedSpecimen\"))") }) -test_that("galah_filter handles exclusion", { +test_that("`filter()` handles exclusion", { filters <- galah_filter(year >= 2010, year != 2021) expect_equal(nrow(filters), 2) expect_equal(filters$query, c("year:[2010 TO *]", "-(year:\"2021\")")) }) -test_that("galah_filter handles multiple exclusions", { +test_that("`filter()` handles multiple exclusions", { filters <- galah_filter(!(stateProvince == "Victoria" & year == 2021)) expect_equal(nrow(filters), 1) expect_equal(filters$query, "-(stateProvince:\"Victoria\") AND -(year:\"2021\")") }) -test_that("galah_filter handles three terms at once", { +test_that("`filter()` handles three terms at once", { filters <- galah_filter( basisOfRecord == "HumanObservation", year >= 2010, @@ -176,65 +183,43 @@ test_that("galah_filter handles three terms at once", { expect_equal(filters$query, c("(basisOfRecord:\"HumanObservation\")","year:[2010 TO *]","(stateProvince:\"New South Wales\")")) }) -test_that("galah_filter treats `c()` as an OR for numerics", { +test_that("`filter()` treats `c()` as an OR for numerics", { filters <- galah_filter(year == c(2010, 2021)) expect_equal(nrow(filters), 1) }) -test_that("galah_filter treats `c()` as an OR for strings", { +test_that("`filter()` treats `c()` as an OR for strings", { filters <- galah_filter(multimedia == c("Image", "Sound", "Video")) expect_equal(nrow(filters), 1) expect_true(grepl("multimedia:\"Image\"", filters$query)) }) -# ## NOT SUPPORTED: requires := -## - note this is difficult to support as it parses as a named object -## i.e. gets caught by check_named_input() -# test_that("galah_filter can take an object as a field", { -# field <- "year" -# filters <- galah_filter(field := 2010) -# expect_equal(nrow(filters), 1) -# expect_true(grepl("year", filters$query)) -# }) - -test_that("galah_filter can take an object as a value", { +test_that("`filter()` can take an object as a value", { value <- "2010" filters <- galah_filter(year == value) expect_equal(nrow(filters), 1) expect_match(filters$query, "(year:\"2010\")") }) -test_that("galah_filter returns error when equations are passed as a string", { +test_that("`filter()` returns error when equations are passed as a string", { expect_error(galah_filter("year == 2010")) }) -# # quoting an equation that contains objects - NOT SUPPORTED -# # consider writing a test to specifically exclude this -## or use := as per {dplyr} - note this is difficult to support as it parses as a named object -## i.e. gets caught by check_named_input() -# field <- "year" -# value <- "2010" -# filters <- galah_filter("field == value") -# expect_equal(attr(filters, "call"), "galah_filter") -# expect_equal(nrow(filters), 1) -# expect_true(grepl("2010", filters$query)) - -test_that("galah_filter handles taxonomic queries", { +test_that("`filter()` handles taxonomic queries", { skip_if_offline(); skip_on_ci() filters <- galah_filter(taxonConceptID == search_taxa("Animalia")$taxon_concept_id) expect_equal(nrow(filters), 1) expect_false(grepl("search_taxa", filters$query)) }) -test_that("galah_filter handles taxonomic queries when passed as a string", { - # ensure a taxonomic query to galah_filter works +test_that("`filter()` handles taxonomic queries when passed as a string", { filters <- galah_filter(taxonConceptID == "https://biodiversity.org.au/afd/taxa/012a1234") expect_equal(nrow(filters), 1) expect_false(grepl("search_taxa", filters$query)) expect_true(grepl("taxonConceptID", filters$query)) }) -test_that("galah_filter handles taxonomic exclusions", { +test_that("`filter()` handles taxonomic exclusions", { skip_if_offline(); skip_on_ci() filters <- galah_filter( taxonConceptID == search_taxa("Animalia")$taxon_concept_id, @@ -243,50 +228,47 @@ test_that("galah_filter handles taxonomic exclusions", { expect_false(any(grepl("search_taxa", filters$query))) }) -test_that("galah_filter handles lsid as an input", { +test_that("`filter()` handles lsid as an input", { skip_if_offline(); skip_on_ci() ids <- c("https://biodiversity.org.au/afd/taxa/0df99ece-1982-4605-a2b3-4fcb7660ee2b", "https://id.biodiversity.org.au/node/apni/2910467", "https://id.biodiversity.org.au/node/apni/291047") # wrong id query <- galah_call() |> - galah_filter(year == 2020, - lsid == ids) |> + filter(year == 2020, + lsid == ids) |> count() |> collapse() - # number of taxa searches is 3, not 4 expect_s3_class(query, "query") - expect_equal(length(query), 6) + expect_equal(length(query), 4) expect_equal(names(query), c("type", "url", "headers", - "filter", - "slot_name", - "expand")) + "request")) }) -test_that("galah_filter handles different fields separated by OR", { +test_that("`filter()` handles different fields separated by OR", { filters <- galah_filter(phylum == "Chordata" | kingdom == "Plantae") expect_equal(filters$query, "((phylum:\"Chordata\") OR (kingdom:\"Plantae\"))") }) -test_that("galah_filter fails when given invalid AND syntax", { +test_that("`filter()` fails when given invalid AND syntax", { expect_error(galah_filter(year >= 2020 & 2021)) }) -test_that("galah_filter fails when given invalid OR syntax", { +test_that("`filter()` fails when given invalid OR syntax", { expect_error(galah_filter(year == 2020 | 2021)) }) -# test that galah_filter handles between() even with multiple filters +# TODOL test that `filter()` handles between() even with multiple filters # NOTE: not implemented yet -test_that("OR works for different fields", { +test_that("`filter()` accepts an OR statement for different fields", { filters <- galah_filter(year == 2010 | basisOfRecord == "PRESERVED_SPECIMEN") expect_true(grepl("year", filters$query) & grepl("basisOfRecord", filters$query)) }) -test_that("galah_filter handles is.na() even with multiple filters", { +test_that("`filter()` handles is.na() even with multiple filters", { filter_single <- galah_filter(is.na(eventDate)) filter_multiple <- galah_filter(is.na(eventDate), year > 2010) expect_equal(nrow(filter_single), 1) @@ -295,7 +277,7 @@ test_that("galah_filter handles is.na() even with multiple filters", { expect_true(grepl("(*:* AND -eventDate:*)", filter_multiple$query[[1]])) }) -test_that("galah_filter handles %in% even with multiple filters", { +test_that("`filter()` handles %in% even with multiple filters", { list_of_years <- 2020:2022 filter_single <- galah_filter(year %in% list_of_years) filter_multiple <- galah_filter(year %in% list_of_years, cl22 == "Tasmania") @@ -305,36 +287,42 @@ test_that("galah_filter handles %in% even with multiple filters", { expect_equal("((year:\"2020\") OR (year:\"2021\") OR (year:\"2022\"))", filter_multiple$query[[1]]) }) -test_that("galah_filter parses fields correctly with is.na()", { +test_that("`filter()` parses fields correctly with is.na()", { skip_if_offline(); skip_on_ci() expect_no_error(galah_call() |> - galah_filter(is.na(decimalLongitude)) |> - atlas_counts() + filter(is.na(decimalLongitude)) |> + count() |> + collect() ) expect_no_error(galah_call() |> - galah_filter(year == 2001, is.na(decimalLongitude)) |> - atlas_counts() + filter(year == 2001, is.na(decimalLongitude)) |> + count() |> + collect() ) expect_no_error(galah_call() |> galah_filter(is.na(coordinateUncertaintyInMeters) | coordinateUncertaintyInMeters <= 1000) |> - atlas_counts() + count() |> + collect() ) # misspelled or wrong fields expect_error(galah_call() |> - galah_filter(is.na(decimalLongitde)) |> - atlas_counts() + filter(is.na(decimalLongitde)) |> + count() |> + collect() ) expect_error(galah_call() |> - galah_filter(year == 2001, is.na(decimalLongitde)) |> - atlas_counts() + filter(year == 2001, is.na(decimalLongitde)) |> + count() |> + collect() ) expect_error(galah_call() |> - galah_filter(is.na(bork) | coordinatencertaintyInMeters <= 1000) |> - atlas_counts() + filter(is.na(bork) | coordinatencertaintyInMeters <= 1000) |> + count() |> + collect() ) }) -test_that("`galah_filter()` handles apostrophes (') correctly", { +test_that("`filter()` handles apostrophes (') correctly", { skip_if_offline(); skip_on_ci() names <- c("Australia's Virtual Herbarium", "iNaturalist observations", @@ -348,7 +336,7 @@ test_that("`galah_filter()` handles apostrophes (') correctly", { expect_match(filter, "\\(datasetName:\\\"Australia's Virtual Herbarium\\\"") }) -test_that("`galah_filter()` handles multiple values with brackets correctly", { +test_that("`filter()` handles multiple values with brackets correctly", { skip_if_offline(); skip_on_ci() filter <- galah_filter( scientificName == c("Aviceda (Aviceda) subcristata", @@ -362,7 +350,7 @@ test_that("`galah_filter()` handles multiple values with brackets correctly", { expect_match(filter, "\\(scientificName:\\\"Aviceda \\(Aviceda\\) subcristata\\\"\\)") }) -test_that("galah_filter builds correct query with `!`, `%in%`, `c()` and `identify()`", { +test_that("`filter()` builds correct query with `!`, `%in%`, `c()` and `identify()`", { ibra_subset <- c("Brigalow Belt North", "Brigalow Belt South", "Central Mackay Coast") query <- request_data(type = "occurrences-count") |> identify("Crinia signifera") |> @@ -370,7 +358,7 @@ test_that("galah_filter builds correct query with `!`, `%in%`, `c()` and `identi expect_equal(query$filter$query, c("-(cl1048:\"Brigalow Belt North\") OR -(cl1048:\"Brigalow Belt South\") OR -(cl1048:\"Central Mackay Coast\")")) }) -test_that("`galah_filter()` accepts {{}} on lhs of formula", { +test_that("`filter()` accepts {{}} on lhs of formula", { skip_if_offline(); skip_on_ci() field <- "species" result <- galah_call() |> @@ -386,44 +374,9 @@ test_that("`galah_filter()` accepts {{}} on lhs of formula", { expect_equal(result, result2) }) -test_that("`group_by()` works when > 1 `filter()`", { - skip_if_offline(); skip_on_ci() - chosen_species <- c("Eolophus roseicapilla", "Platycercus elegans") +test_that("`filter()` handles `method = 'data'` correctly", { x <- request_data() |> - filter(species == chosen_species) |> - group_by(species) |> - count() |> - collect() - expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) - expect_equal(x$species, chosen_species) - expect_equal(colnames(x), c("species", "count")) - expect_equal(nrow(x), 2) - # previously, adding an additional field (`year` below) removed one species from resulting tibble - y <- request_data() |> - filter(species == chosen_species, - year == 2023) |> - group_by(species) |> - count() |> - collect() - expect_s3_class(y, c("tbl_df", "tbl", "data.frame")) - expect_equal(y$species, chosen_species) - expect_equal(colnames(y), c("species", "count")) - expect_equal(nrow(y), 2) - expect_true(all(x$count > y$count)) # extra filter - # compare to different syntax - z <- galah_call() |> - galah_filter(species == c("Eolophus roseicapilla", "Platycercus elegans"), - year == 2023) |> - galah_group_by(species) |> - atlas_counts() - expect_equal(y, z) -}) - -test_that("galah_filter handles `type = 'data'` correctly", { - x <- galah_call(method = "data") |> - galah_filter(year == 2010) - # NOTE: this errors because `galah_filter()` doesn't handle `type = "files"` like `filter()` does - # needs fixing + filter(year == 2010) expect_s3_class(x, "data_request") expect_false(is.null(x$filter)) expect_equal(colnames(x$filter), c("variable", "logical", "value", "query")) @@ -431,27 +384,25 @@ test_that("galah_filter handles `type = 'data'` correctly", { expect_equal(x, y) }) -test_that("galah_filter handles `type = 'metadata'` correctly", { - x <- galah_call(method = "metadata") |> - galah_filter(field == cl22) +test_that("`filter() handles `method = 'metadata'` correctly", { + x <- request_metadata() |> + filter(field == cl22) expect_s3_class(x, "metadata_request") expect_equal(length(x), 2) expect_equal(names(x), c("type", "filter")) - expect_equal(colnames(x$filter), c("variable", "logical", "value")) - y <- request_metadata() |> filter(field == cl22) - expect_equal(x, y) + expect_equal(names(x$filter), c("variable", "value")) }) -test_that("galah_filter handles `type = 'files'` correctly", { - x <- tibble( +test_that("`filter() handles `method = 'files'` correctly", { + x <- tibble::tibble( id = c(1, 2), images = c("1234", "5678")) - y <- galah_call(method = "files") |> - galah_filter(media == x) + y <- request_files() |> + filter(media == x) expect_s3_class(y, "files_request") expect_equal(length(y), 2) expect_equal(names(y), c("type", "filter")) - expect_equal(y$filter, x) - z <- request_files() |> filter(media == x) - expect_equal(y, z) + expect_equal(y$filter$data, x) }) + +rm(purrr_collect) \ No newline at end of file diff --git a/tests/testthat/test-dplyr-glimpse.R b/tests/testthat/test-dplyr-glimpse.R new file mode 100644 index 00000000..225f1475 --- /dev/null +++ b/tests/testthat/test-dplyr-glimpse.R @@ -0,0 +1,35 @@ +quiet_print <- purrr::quietly(print.occurrences_glimpse) + +test_that("`glimpse()` returns the correct object class", { + skip_if_offline(); skip_on_ci() + x <- galah_call() |> + filter(year == 2025) |> + glimpse() |> + collect() + expect_s3_class(x, c("occurrences_glimpse", "tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x), 3) # number of rows in the tibble + x_print <- strsplit(quiet_print(x)$output, "\n")[[1]] # print statement + expect_equal(length(x_print), 10) + # expect_equal(ncol(x), length(default_columns())) # FIXME: issue with ID/recordID +}) + +test_that("`glimpse()` works with `select()`", { + skip_if_offline(); skip_on_ci() + x <- galah_call() |> + filter(year == 2025) |> + select(eventDate, decimalLatitude, year) |> + glimpse() |> + collect() + expect_s3_class(x, c("occurrences_glimpse", "tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x), 3) + x_print <- strsplit(quiet_print(x)$output, "\n")[[1]] + expect_equal(length(x_print), 5) + # ensure all three fields are present + stringr::str_detect(x_print, + "^\\$ (eventDate|decimalLatitude|year)") |> + which() |> + length() |> + expect_equal(3) +}) + +rm(quiet_print) \ No newline at end of file diff --git a/tests/testthat/test-galah_select.R b/tests/testthat/test-dplyr-select.R similarity index 51% rename from tests/testthat/test-galah_select.R rename to tests/testthat/test-dplyr-select.R index 7f97d45e..762e3169 100644 --- a/tests/testthat/test-galah_select.R +++ b/tests/testthat/test-dplyr-select.R @@ -1,102 +1,96 @@ +# set up quiet functions for testing reasons +quiet_collect <- function(x){ + purrr_collect <- purrr::quietly(collect.data_request) + purrr_collect(x) |> + purrr::pluck("result") +} +quiet_occurrences <- purrr::quietly(atlas_occurrences) + +config_capture <- galah_config(email = "ala4r@ala.org.au", + run_checks = TRUE) + +test_that("`select.data_request()` adds content to a `data_request` object", { + x <- galah_call() |> + select(group = "basic") + expect_equal(names(x$select), + c("quosure", "summary", "group")) +}) + test_that("`galah_select()` doesn't return error when columns don't exist", { - expect_no_error(galah_select(basisOfRecord)) - expect_no_error(galah_select(year, basisOfRecord, eventdate)) + galah_select(basisOfRecord) |> + expect_no_error() + galah_select(year, basisOfRecord, eventdate) |> + expect_no_error() }) -test_that("`galah_select()` triggers error during `compute()` when columns don't exist", { +test_that("`select()` triggers error during `collapse()` when columns don't exist", { skip_if_offline(); skip_on_ci() expect_error( galah_call() |> identify("perameles") |> filter(year == 2003) |> - galah_select(basisOfRecors) |> - compute()) + select(basisOfRecors) |> + collapse()) expect_error( galah_call() |> identify("perameles") |> filter(year == 2003) |> select(year, basisOfRecors, eventdate) |> - compute()) -}) - -test_that("`galah_select()` returns requested columns", { - skip_if_offline(); skip_on_ci() - galah_config(atlas = "Australia", - email = "ala4r@ala.org.au", - run_checks = FALSE) - query <- galah_call() |> - identify("oxyopes dingo") |> - select(year, basisOfRecord) |> - atlas_occurrences() - expect_s3_class(query, c("tbl_df", "tbl", "data.frame" )) - expect_equal(names(query), c("year", "basisOfRecord")) - expect_gte(nrow(query), 10) -}) - -test_that("`galah_select()` returns requested columns when piped", { - skip_if_offline(); skip_on_ci() - galah_config(email = "ala4r@ala.org.au", run_checks = FALSE) - query <- galah_call() |> - identify("oxyopes dingo") |> - select(year, basisOfRecord) |> - collect() - expect_s3_class(query, c("tbl_df", "tbl", "data.frame" )) - expect_equal(names(query), c("year", "basisOfRecord")) - expect_gte(nrow(query), 10) + collapse()) }) -test_that("`galah_select()` builds expected columns when group = basic", { +test_that("`select()` builds expected columns when group = basic", { skip_if_offline(); skip_on_ci() x <- galah_call() |> identify("oxyopes dingo") |> select(group = "basic") |> collapse() - y <- url_parse(x$url)$query + y <- httr2::url_parse(x$url)$query expect_equal(strsplit(y$fields, ",")[[1]], preset_groups("basic")) expect_equal(y$qa, "none") }) -test_that("`galah_select()` builds expected columns when group = event", { +test_that("`select()` builds expected columns when group = event", { skip_if_offline(); skip_on_ci() x <- galah_call() |> identify("oxyopes dingo") |> select(group = "event") |> collapse() - y <- url_parse(x$url)$query + y <- httr2::url_parse(x$url)$query expect_equal(strsplit(y$fields, ",")[[1]], c("recordID", preset_groups("event"))) expect_equal(y$qa, "none") }) -test_that("`galah_select()` accepts multiple groups", { +test_that("`select()` accepts multiple groups", { skip_if_offline(); skip_on_ci() x <- galah_call() |> identify("oxyopes dingo") |> select(group = c("basic", "assertions")) |> collapse() - y <- url_parse(x$url)$query + y <- httr2::url_parse(x$url)$query expect_equal(strsplit(y$fields, ",")[[1]], preset_groups("basic")) expect_equal(y$qa, "includeall") }) -test_that("galah_select defaults to group = 'basic' when there are no args", { +test_that("`select()` defaults to group = 'basic' when there are no args", { skip_if_offline(); skip_on_ci() x <- galah_call() |> identify("oxyopes dingo") |> collapse() - y <- url_parse(x$url)$query + y <- httr2::url_parse(x$url)$query expect_equal(strsplit(y$fields, ",")[[1]], preset_groups("basic")) expect_equal(y$qa, "none") }) -test_that("galah_select works with group = 'taxonomy'", { +test_that("`select()` works with group = 'taxonomy'", { skip_if_offline(); skip_on_ci() x <- galah_call() |> identify("oxyopes dingo") |> select(group = "taxonomy") |> collapse() - y <- url_parse(x$url)$query + y <- httr2::url_parse(x$url)$query fields <- strsplit(tolower(y$fields), ",")[[1]] expect_equal(fields, c("recordid", @@ -110,122 +104,97 @@ test_that("galah_select works with group = 'taxonomy'", { "subspecies")) }) -test_that("galah_select returns assertions + recordID when group = assertions", { +test_that("`select()` returns assertions + recordID when group = assertions", { skip_if_offline(); skip_on_ci() x <- galah_call() |> identify("oxyopes dingo") |> select(group = "assertions") |> collapse() - y <- url_parse(x$url)$query + y <- httr2::url_parse(x$url)$query expect_equal(y$fields, "recordID") expect_equal(y$qa, "includeall") }) -test_that("galah_select combines requested columns and group columns", { +test_that("`select()` combines requested columns and group columns", { skip_if_offline(); skip_on_ci() x <- galah_call() |> identify("oxyopes dingo") |> - select(year, basisOfRecord, group = "basic") |> + select(year, group = "basic") |> collapse() - y <- url_parse(x$url)$query + y <- httr2::url_parse(x$url)$query expect_equal(strsplit(y$fields, ",")[[1]], - c(preset_groups("basic"), "year", "basisOfRecord")) + c(preset_groups("basic"), "year")) }) -test_that("galah_select can use tidyselect::contains", { +test_that("`select()` can use `tidyselect::contains()`", { skip_if_offline(); skip_on_ci() x <- galah_call() |> identify("oxyopes dingo") |> select(tidyselect::contains("el")) |> collapse() - y <- url_parse(x$url)$query + y <- httr2::url_parse(x$url)$query fields <- strsplit(tolower(y$fields), ",")[[1]] assertions <- strsplit(tolower(y$qa), ",")[[1]] expect_true(all(grepl("el", fields))) expect_true(all(grepl("el", assertions))) }) -test_that("galah_select can use tidyselect::starts_with", { +# TODO: `galah_select()` fails when `everything()` is called for `type = "occurrences"` + +test_that("`select()` can use `tidyselect::starts_with()`", { skip_if_offline(); skip_on_ci() x <- galah_call() |> identify("oxyopes dingo") |> select(tidyselect::starts_with("el")) |> collapse() - y <- url_parse(x$url)$query + y <- httr2::url_parse(x$url)$query fields <- strsplit(tolower(y$fields), ",")[[1]] assertions <- strsplit(tolower(y$qa), ",")[[1]] expect_true(all(grepl("^el", fields))) expect_true(all(grepl("^el", assertions))) }) -test_that("galah_select can use tidyselect::last_col", { +test_that("`select()` can use `tidyselect::last_col()`", { skip_if_offline(); skip_on_ci() x <- galah_call() |> identify("oxyopes dingo") |> select(tidyselect::last_col()) |> collapse() - y <- url_parse(x$url)$query + y <- httr2::url_parse(x$url)$query expect_equal(y$fields, "recordID") expect_equal(y$qa, "ZERO_COORDINATE") }) -test_that("galah_select can use tidyselect::last_col & user-defined queries", { +test_that("`select()` can use `tidyselect::last_col()` & user-defined queries", { skip_if_offline(); skip_on_ci() x <- galah_call() |> identify("oxyopes dingo") |> select(year, basisOfRecord, tidyselect::last_col()) |> collapse() - y <- url_parse(x$url)$query + y <- httr2::url_parse(x$url)$query expect_equal(y$fields, "year,basisOfRecord") expect_equal(y$qa, "ZERO_COORDINATE") }) -test_that("galah_select can use tidyselect::last_col & group", { +test_that("`select()` can use `tidyselect::last_col()` & group", { skip_if_offline(); skip_on_ci() x <- galah_call() |> identify("oxyopes dingo") |> select(tidyselect::last_col(), group = "basic") |> collapse() - y <- url_parse(x$url)$query + y <- httr2::url_parse(x$url)$query expect_equal(strsplit(y$fields, ",")[[1]], preset_groups("basic")) expect_equal(y$qa, "ZERO_COORDINATE") }) -test_that("galah_select warns for invalid field names when type = 'species'", { +test_that("`select()` warns for invalid field names when type = 'species'", { skip_if_offline(); skip_on_ci() - expect_warning({galah_call(type = "species") |> + expect_warning({galah_call() |> identify("Crinia") |> + distinct(speciesID, .keep_all = TRUE) |> select(an_unrecognised_field_name) |> - collapse()}) -}) - -test_that("galah_select works for type = 'species' with no arguments", { - skip_if_offline(); skip_on_ci() - x <- galah_call(type = "species") |> - identify("Crinia") |> - select() |> - collect() - expect_equal(colnames(x), "taxon_concept_id") - expect_gt(nrow(x), 10) + capture()}) }) -test_that("galah_select works for type = 'species'", { - skip_if_offline(); skip_on_ci() - x <- galah_call(type = "species") |> - identify("Crinia") |> - select(counts) |> - collect() - expect_equal(colnames(x), c("taxon_concept_id", "count")) - expect_gt(nrow(x), 10) -}) - -test_that("galah_select works for type = 'species' with group = 'taxonomy'", { - skip_if_offline(); skip_on_ci() - x <- galah_call(type = "species") |> - identify("Crinia") |> - select(counts, lists, group = "taxonomy") |> - collect() - expect_true(all(c("taxon_concept_id", "count", "kingdom", "phylum") %in% colnames(x))) - expect_gt(nrow(x), 10) -}) +rm(quiet_collect, quiet_occurrences, config_capture) diff --git a/tests/testthat/test-galah_apply_profile.R b/tests/testthat/test-galah_apply_profile.R index e21a66f4..5413ca96 100644 --- a/tests/testthat/test-galah_apply_profile.R +++ b/tests/testthat/test-galah_apply_profile.R @@ -1,4 +1,36 @@ -test_that("galah_apply_profile filters counts", { +test_that("`apply_profile()` amends a `query", { + x <- galah_call() |> + filter (year == 2025) |> + apply_profile("ALA") + expect_equal(x$apply_profile, "ALA") +}) + +test_that("`galah_apply_profile()` matches profile", { + skip_if_offline(); skip_on_ci() + profile_1 <- galah_apply_profile("ALA") + profile_2 <- galah_apply_profile(AVH) + expect_equal(profile_1[[1]], "ALA") + expect_equal(profile_2[[1]], "AVH") +}) + +test_that("`apply_profile()` errors at `collapse()`", { + skip_if_offline(); skip_on_ci() + galah_config(run_checks = TRUE) + expect_error(request_data() |> + apply_profile(whatever) |> + count() |> + collapse(), + "Unrecognised profile requested.") + galah_config(run_checks = FALSE) +}) + +test_that("`galah_apply_profile()` allows only one profile at a time", { + skip_if_offline(); skip_on_ci() + expect_error(galah_apply_profile(ALA, CSDM), + "Too many data profiles supplied.") +}) + +test_that("`apply_profile()` filters counts", { skip_if_offline(); skip_on_ci() without_profile <- galah_call() |> count() |> @@ -17,7 +49,7 @@ test_that("galah_apply_profile filters counts", { expect_equal(with_profile, with_profile_2) }) -test_that("galah_apply_profile filters species", { +test_that("`apply_profile()` filters species", { skip_if_offline(); skip_on_ci() galah_config(email = "ala4r@ala.org.au", atlas = "Australia", @@ -36,45 +68,28 @@ test_that("galah_apply_profile filters species", { expect_true(all(with_profile$count <= without_profile$count)) }) -test_that("galah_apply_profile filters occurrences", { +test_that("`apply_profile()` filters occurrences", { skip_if_offline(); skip_on_ci() + quiet_collect <- function(x){ + purrr_collect <- purrr::quietly(collect.data_request) + purrr_collect(x) |> + purrr::pluck("result") + } galah_config(email = "ala4r@ala.org.au", atlas = "Australia", run_checks = FALSE) without_profile <- galah_call() |> - galah_identify("Acanthorhynchus tenuirostris") |> - galah_filter(year == 2012) |> - atlas_occurrences() + identify("Crinia signifera") |> + filter(year <= 1980, + cl22 == "Australian Capital Territory") |> + quiet_collect() with_profile <- galah_call() |> - galah_identify("Acanthorhynchus tenuirostris") |> - galah_filter(year == 2012) |> - galah_apply_profile(ALA) |> - atlas_occurrences() + identify("Crinia signifera") |> + filter(year <= 1980, + cl22 == "Australian Capital Territory") |> + apply_profile(ALA) |> + quiet_collect() expect_gt(nrow(with_profile), 0) expect_lt(nrow(with_profile), nrow(without_profile)) -}) - -test_that("galah_apply_profile matches profile", { - skip_if_offline(); skip_on_ci() - profile_1 <- galah_apply_profile("ALA") - profile_2 <- galah_apply_profile(AVH) - expect_equal(profile_1[[1]], "ALA") - expect_equal(profile_2[[1]], "AVH") -}) - -test_that("`galah_apply_profile()` errors at `collapse()`", { - skip_if_offline(); skip_on_ci() - galah_config(run_checks = TRUE) - expect_error(request_data() |> - apply_profile(whatever) |> - count() |> - collapse(), - "Unrecognised profile requested.") - galah_config(run_checks = FALSE) -}) - -test_that("galah_apply_profile allows only one profile at a time", { - skip_if_offline(); skip_on_ci() - expect_error(galah_apply_profile(ALA, CSDM), - "Too many data profiles supplied.") -}) + rm(quiet_collect) +}) \ No newline at end of file diff --git a/tests/testthat/test-galah_bbox.R b/tests/testthat/test-galah_bbox.R index f59f53bb..94e1e0bf 100644 --- a/tests/testthat/test-galah_bbox.R +++ b/tests/testthat/test-galah_bbox.R @@ -1,75 +1,95 @@ -test_that("galah_bbox returns bbox for sf", { +purrr_bbox <- purrr::quietly(galah_bbox) +quiet_bbox <- function(...){ + purrr_bbox(...) |> + purrr::pluck("result")} + +test_that("`galah_bbox()` returns bbox for sf", { polygon_sfc <- "POLYGON((142.36228 -29.00703,142.74131 -29.00703,142.74131 -29.39064,142.36228 -29.39064,142.36228 -29.00703))" |> - st_as_sfc() - polygon_bbox <- galah_bbox(polygon_sfc) - expected_bbox <- polygon_sfc |> st_bbox() - expect_message(galah_bbox(polygon_sfc), "Data returned for bounding box:") - expect_true(grepl("MULTIPOLYGON", galah_bbox(polygon_sfc))) - expect_equal(attributes(polygon_bbox)$bbox, expected_bbox) + sf::st_as_sfc() + polygon_bbox <- quiet_bbox(polygon_sfc) + expected_bbox <- polygon_sfc |> + sf::st_bbox() + galah_bbox(polygon_sfc) |> + expect_message("Data returned for bounding box:") + grepl("MULTIPOLYGON", quiet_bbox(polygon_sfc)) |> + expect_true() + attributes(polygon_bbox)$bbox |> + expect_equal(expected_bbox) }) -test_that("galah_bbox returns bbox for shapefile", { +test_that("`galah_bbox()` returns bbox for shapefile", { poly_path <- test_path("testdata", "act_state_polygon_shp", "ACT_STATE_POLYGON_shp.shp") shapefile <- sf::st_read(poly_path, quiet = TRUE) - shapefile_bbox <- galah_bbox(shapefile) + shapefile_bbox <- quiet_bbox(shapefile) expected_bbox <- attributes(shapefile_bbox)$bbox expect_message(galah_bbox(shapefile), "Data returned for bounding box:") - expect_true(grepl("MULTIPOLYGON", galah_bbox(shapefile))) + expect_true(grepl("MULTIPOLYGON", quiet_bbox(shapefile))) expect_equal(attributes(shapefile_bbox)$bbox, expected_bbox) }) -test_that("galah_bbox returns bbox for bbox", { # FIXME: not backwards compatible with bbox coords? - bbox <- st_bbox(c(xmin = 143, xmax = 148, ymin = -29, ymax = -28), crs = st_crs("WGS84")) - bbox_galah <- galah_bbox(bbox) +test_that("`galah_bbox()` returns bbox for bbox", { # FIXME: not backwards compatible with bbox coords? + bbox <- sf::st_bbox(c(xmin = 143, xmax = 148, ymin = -29, ymax = -28), + crs = sf::st_crs("WGS84")) + bbox_galah <- quiet_bbox(bbox) expected_polygon <- "MULTIPOLYGON (((143 -29, 148 -29, 148 -28, 143 -28, 143 -29)))" expect_message(galah_bbox(bbox), "Data returned for bounding box:") - expect_equal(galah_bbox(bbox)[1], expected_polygon) + expect_equal(quiet_bbox(bbox)[1], expected_polygon) expect_equal(attributes(bbox_galah)$bbox, bbox) }) -test_that("galah_bbox returns bbox for tibble", { - tibble <- tibble(xmin = 143, ymin = -29, xmax = 148, ymax = -21) - tibble_bbox <- galah_bbox(tibble) +test_that("`galah_bbox()` returns bbox for tibble", { + tibble <- tibble::tibble(xmin = 143, ymin = -29, xmax = 148, ymax = -21) + tibble_bbox <- quiet_bbox(tibble) expected_polygon <- "MULTIPOLYGON (((143 -29, 148 -29, 148 -21, 143 -21, 143 -29)))" - expected_bbox <- st_bbox(c(xmin = 143, xmax = 148, ymin = -29, ymax = -21), crs = st_crs("WGS84")) + expected_bbox <- sf::st_bbox(c(xmin = 143, xmax = 148, ymin = -29, ymax = -21), + crs = sf::st_crs("WGS84")) expect_message(galah_bbox(tibble), "Data returned for bounding box:") - expect_equal(galah_bbox(tibble)[1], expected_polygon) + expect_equal(quiet_bbox(tibble)[1], expected_polygon) expect_equal(attributes(tibble_bbox)$bbox, expected_bbox) }) -test_that("galah_bbox does not accept incorrect tibbles", { - tibble_wrong <- tibble(c1 = c("hi", "hello"), c2 = 1:2) - tibble_bad_colnames <- tibble(top = 148, bottom = -29, ymin = -29, ymax = -29) - tibble_invalid_bbox <- tibble(xmin = 148, ymin = -29, xmax = 143, ymax = -29) +test_that("`galah_bbox()` does not accept incorrect tibbles", { + tibble_wrong <- tibble::tibble(c1 = c("hi", "hello"), c2 = 1:2) + tibble_bad_colnames <- tibble::tibble(top = 148, bottom = -29, ymin = -29, ymax = -29) + tibble_invalid_bbox <- tibble::tibble(xmin = 148, ymin = -29, xmax = 143, ymax = -29) expect_error(galah_bbox(tibble_wrong)) expect_error(galah_bbox(tibble_bad_colnames)) expect_error(galah_bbox(tibble_invalid_bbox)) }) -test_that("galah_bbox uses only first coordinates of tibble with many coordinates", { - tibble_many_coords <- tibble(xmin = c(148, 145), - ymin = c(-29, -42), - xmax = c(143, 146), - ymax = c(-30, -41)) - expect_warning(galah_bbox(tibble_many_coords), - "More than 1 set of coordinates supplied to") +test_that("`galah_bbox()` uses only first coordinates of tibble with many coordinates", { + tibble_many_coords <- tibble::tibble(xmin = c(148, 145), + ymin = c(-29, -42), + xmax = c(143, 146), + ymax = c(-30, -41)) + result <- purrr_bbox(tibble_many_coords) + grepl("More than 1 set of coordinates supplied to", result$warnings) |> + expect_true() + grepl("Data returned for bounding box:", result$messages) |> + expect_true() }) -test_that("galah_bbox checks number of inputs, uses first argument", { # FIXME - wkt_1 <- glue("POLYGON((142.36228 -29.00703,142.74131 -29.00703,142.74131 \\ - -29.39064,142.36228 -29.39064,142.36228 -29.00703))") |> st_as_sfc() - wkt_2 <- glue("POLYGON((145.6765 -42.13203, 145.9652 -42.63203, 146.5425 \\ +test_that("`galah_bbox()` checks number of inputs, uses first argument", { # FIXME + wkt_1 <- glue::glue("POLYGON((142.36228 -29.00703,142.74131 -29.00703,142.74131 \\ + -29.39064,142.36228 -29.39064,142.36228 -29.00703))") |> + sf::st_as_sfc() + wkt_2 <- glue::glue("POLYGON((145.6765 -42.13203, 145.9652 -42.63203, 146.5425 \\ -42.63203, 146.8312 -42.13203, 146.5425 -41.63203, 145.9652 \\ - -41.63203, 145.6765 -42.13203))") |> st_as_sfc() - expected_polygon <- glue("MULTIPOLYGON (((142.3623 -29.39064, 142.7413 -29.39064, \\ + -41.63203, 145.6765 -42.13203))") |> + sf::st_as_sfc() + expected_polygon <- glue::glue("MULTIPOLYGON (((142.3623 -29.39064, 142.7413 -29.39064, \\ 142.7413 -29.00703, 142.3623 -29.00703, 142.3623 -29.39064)))") - bbox_1 <- expect_warning(galah_bbox(wkt_1, wkt_2), "More than 1 spatial area provided") - expect_equal(as.character(bbox_1), - as.character(galah_bbox(wkt_1)[1]), - as.character(expected_polygon)) + result <- purrr_bbox(wkt_1, wkt_2) + grepl("More than 1 spatial area provided", result$warnings) |> + expect_true() + grepl("Data returned for bounding box:", result$messages) |> + expect_true() + expect_identical(as.character(result$result), + as.character(quiet_bbox(wkt_1)[1]), + as.character(expected_polygon)) }) -test_that("galah_bbox checks inputs", { +test_that("`galah_bbox()` checks inputs", { wkt <- "POLYGON((142.36228 -29.00703,142.74131 -29.00703,142.74131 -29.39064,142.36228 -29.39064,142.36228 -29.00703))" number <- 45 c_char <- c("a", "b", "c", "d") @@ -80,21 +100,24 @@ test_that("galah_bbox checks inputs", { expect_error(galah_bbox(c_numbers)) }) -test_that("galah_bbox detects invalid spatial objects", { - impossible_bbox <- st_bbox(c(xmin = 148000, - xmax = -29000, - ymin = -29000, - ymax = -29000), - crs = st_crs("WGS84")) +test_that("`galah_bbox()` detects invalid spatial objects", { + impossible_bbox <- sf::st_bbox(c(xmin = 148000, + xmax = -29000, + ymin = -29000, + ymax = -29000), + crs = sf::st_crs("WGS84")) expect_error(galah_bbox(impossible_bbox), "Invalid spatial object") }) -test_that("galah_bbox converts to multipolygon", { +test_that("`galah_bbox()` converts to multipolygon", { wkt <- "POLYGON((143.32 -18.78,145.30 -20.52,141.52 -21.50,143.32 -18.78))" - sf_wkt <- wkt |> st_as_sfc() - expect_match(galah_bbox(sf_wkt), "MULTIPOLYGON") + sf_wkt <- wkt |> + sf::st_as_sfc() + expect_match(quiet_bbox(sf_wkt), "MULTIPOLYGON") }) # TODO: test that galah_bbox unnests sf object & shapefiles correctly -# after converting from dots \ No newline at end of file +# after converting from dots + +rm(purrr_bbox, quiet_bbox) \ No newline at end of file diff --git a/tests/testthat/test-galah_call.R b/tests/testthat/test-galah_call.R index 3221c53a..91aa349b 100644 --- a/tests/testthat/test-galah_call.R +++ b/tests/testthat/test-galah_call.R @@ -1,36 +1,40 @@ -## Note: "order" arg was removed from galah_call, adding it back will require updating of these tests - -test_that("galah_call builds objects of class 'data_request' by default", { - expect_equal(length(galah_call()), 8) +test_that("`galah_call()` builds objects of class 'data_request' by default", { + expect_equal(length(galah_call()), 1) expect_s3_class(galah_call(), "data_request") }) -test_that("galah_call accepts method arg", { - x <- galah_call(method = "metadata") +test_that("`request_` functions build correct object classes", { + x <- request_metadata() expect_s3_class(x, "metadata_request") expect_true(x$type == "fields") - y <- galah_call(method = "files") + y <- request_files() expect_s3_class(y, "files_request") expect_true(y$type == "media") - expect_error(galah_call(method = "nothing")) }) -# prints properly? - -test_that("galah_call works with all `galah_` functions", { +test_that("`galah_call()` works with all `galah_` functions", { skip_if_offline(); skip_on_ci() result <- galah_call() |> - galah_identify("Litoria") |> - galah_filter(year == 2021, cl22 == "Tasmania") |> - galah_select(year) |> - galah_apply_profile(ALA) |> - galah_geolocate("POLYGON((143.32 -18.78,145.30 -20.52,141.52 -21.50,143.32 -18.78))") |> - galah_group_by(year, basisOfRecord) |> + identify("Litoria") |> + filter(year == 2021, cl22 == "Tasmania") |> + select(year) |> + apply_profile(ALA) |> + geolocate("POLYGON((143.32 -18.78,145.30 -20.52,141.52 -21.50,143.32 -18.78))") |> + group_by(year, basisOfRecord) |> arrange(basisOfRecord) - expect_false(any(unlist(lapply(result, is.null)))) + # ensure no null values + purrr::map(result, is.null) |> + unlist() |> + any() |> + expect_false() + # ensure content is added in same order as supplied + expect_equal( + names(result), + c("type", "identify", "filter", "select", "apply_profile", + "geolocate", "group_by", "arrange")) }) -test_that("galah_call works irrespective of `galah_` function order", { +test_that("`galah_call()` works irrespective of `galah_` function order", { skip_if_offline(); skip_on_ci() result <- galah_call() |> galah_apply_profile(ALA) |> @@ -43,17 +47,17 @@ test_that("galah_call works irrespective of `galah_` function order", { expect_false(any(unlist(lapply(result, is.null)))) }) -test_that("repeated calls to `galah_identify` are added correctly", { +test_that("repeated calls to `identify()` are added correctly", { skip_if_offline(); skip_on_ci() result <- galah_call() |> - galah_identify("Litoria") |> - galah_identify("Aves") + identify("Litoria") |> + identify("Aves") expect_equal(nrow(result$identify), 2) }) -test_that("repeated calls to `galah_filter` are added correctly", { +test_that("repeated calls to `filter()` are added correctly", { result <- galah_call() |> - galah_filter(year >= 2010) |> - galah_filter(basisOfRecord == "human_observation", cl22 == "Tasmania") + filter(year >= 2010) |> + filter(basisOfRecord == "human_observation", cl22 == "Tasmania") expect_equal(nrow(result$filter), 3) }) diff --git a/tests/testthat/test-galah_config.R b/tests/testthat/test-galah_config.R index 25510d27..6fb8829f 100644 --- a/tests/testthat/test-galah_config.R +++ b/tests/testthat/test-galah_config.R @@ -1,10 +1,7 @@ -test_that("galah_config warns that `cache_directory` is deprecated", { - unlink("temp", recursive = TRUE) - dir.create("temp") - expect_warning(galah_config(cache_directory = "temp")) - expect_true(galah_config()$package$directory == "temp") - galah_config(directory = tempfile()) - unlink("temp", recursive = TRUE) +quiet_config <- purrr::quietly(galah_config) + +test_that("`galah_config()` gives nice error messages for incorrect arguments", { + expect_error(quiet_config(something = "nothing")) }) test_that("galah_config creates nested folders where requested", { @@ -37,7 +34,7 @@ test_that("galah_config checks inputs", { expect_error(galah_config(run_checks = "value")) expect_silent(galah_config(run_checks = TRUE)) # reset defaults - galah_config(run_checks = TRUE, + quiet_config(run_checks = TRUE, verbose = FALSE, download_reason_id = "testing") }) @@ -49,5 +46,7 @@ test_that("galah_config can swap between atlases", { list(organisation = "Global Biodiversity Information Facility", acronym = "GBIF", region = "Global")) - galah_config(atlas = "ALA") + quiet_config(atlas = "ALA") }) + +rm(quiet_config) \ No newline at end of file diff --git a/tests/testthat/test-galah_geolocate.R b/tests/testthat/test-galah_geolocate.R index e9917ced..8149c172 100644 --- a/tests/testthat/test-galah_geolocate.R +++ b/tests/testthat/test-galah_geolocate.R @@ -1,3 +1,6 @@ +purrr_geolocate <- purrr::quietly(galah_geolocate) +quiet_geolocate <- function(...){purrr_geolocate(...)$result} + test_that("galah_geolocate defaults to galah_polygon", { wkt <- "POLYGON((142.36228 -29.00703,142.74131 -29.00703,142.74131 -29.39064,142.36228 -29.39064,142.36228 -29.00703))" expect_match(galah_geolocate(wkt), "MULTIPOLYGON") @@ -5,26 +8,34 @@ test_that("galah_geolocate defaults to galah_polygon", { test_that("galah_geolocate works when type is set to polygon", { wkt <- "POLYGON((142.36228 -29.00703,142.74131 -29.00703,142.74131 -29.39064,142.36228 -29.39064,142.36228 -29.00703))" - expect_match(galah_geolocate(wkt, type = "polygon"), "MULTIPOLYGON") + polygon <- quiet_geolocate(wkt, type = "polygon") + expect_match(polygon, "MULTIPOLYGON") }) test_that("galah_geolocate switches to use galah_bbox when `type = bbox`", { wkt <- "POLYGON((142.36228 -29.00703,142.74131 -29.00703,142.74131 -29.39064,142.36228 -29.39064,142.36228 -29.00703))" obj_sf <- wkt |> sf::st_as_sfc() - expect_error(galah_geolocate(wkt, type = "bbox")) - expect_match(galah_geolocate(obj_sf, type = "bbox"), "MULTIPOLYGON") + galah_geolocate(wkt, type = "bbox") |> + expect_error(label = "input must be an sf object, data.frame or tibble") + polygon <- quiet_geolocate(obj_sf, type = "bbox") + expect_match(polygon, "MULTIPOLYGON") }) test_that("galah_geolocate switches to use galah_radius when `type = radius`", { wkt <- "POLYGON((142.36228 -29.00703,142.74131 -29.00703,142.74131 -29.39064,142.36228 -29.39064,142.36228 -29.00703))" obj_sf <- wkt |> sf::st_as_sfc() - expect_error(galah_geolocate(wkt, type = "radius"), "Missing") - expect_error(galah_geolocate(obj_sf, type = "radius"), "Invalid spatial object") - expect_equal(galah_geolocate(lat = -33.66741, - lon = 151.3174, - radius = 2, - type = "radius"), + galah_geolocate(wkt, type = "radius") |> + expect_error("Missing") + galah_geolocate(obj_sf, type = "radius") |> + expect_error("Invalid spatial object") + radius_obj <- quiet_geolocate(lat = -33.66741, + lon = 151.3174, + radius = 2, + type = "radius") + expect_equal(radius_obj, list(lat = -33.66741, lon = 151.3174, radius = 2)) }) + +rm(purrr_geolocate, quiet_geolocate) diff --git a/tests/testthat/test-galah_group_by.R b/tests/testthat/test-galah_group_by.R index aa640fd5..1ef65109 100644 --- a/tests/testthat/test-galah_group_by.R +++ b/tests/testthat/test-galah_group_by.R @@ -1,3 +1,5 @@ +quiet_collect <- purrr::quietly(collect.data_request) + test_that("`group_by` fields are checked during `collapse()`", { galah_config(run_checks = TRUE) # `collapse()` should ping a check when `run_checks = TRUE` @@ -17,7 +19,7 @@ test_that("`group_by` fields are checked during `collapse()`", { galah_config(run_checks = FALSE) }) -test_that("grouped atlas_counts returns expected output", { +test_that("`count()` with `group_by()` returns expected output", { skip_if_offline(); skip_on_ci() counts <- galah_call() |> identify("Mammalia") |> @@ -27,67 +29,73 @@ test_that("grouped atlas_counts returns expected output", { expect_equal(names(counts), c("basisOfRecord", "count")) }) -test_that("grouped atlas_counts returns expected output when limit != NULL", { +test_that("`count()` with `group_by()` returns expected output when limit != NULL", { skip_if_offline(); skip_on_ci() counts <- galah_call() |> identify("Mammalia") |> group_by(basisOfRecord) |> count() |> slice_head(n = 3) |> - collect() + quiet_collect() |> + purrr::pluck("result") expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) expect_equal(names(counts), c("basisOfRecord", "count")) expect_equal(nrow(counts), 3) }) -test_that("atlas_counts returns all counts if no limit is provided", { +test_that("`count()` with `group_by()` returns all counts if no limit is provided", { skip_if_offline(); skip_on_ci() counts <- galah_call() |> group_by(basisOfRecord) |> # NOTE: basisOfRecord chosen as prone to breaking - atlas_counts() # this code; please do not change it! + count() |> # this code; please do not change it! + quiet_collect() |> + purrr::pluck("result") expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) expect_gte(nrow(counts), 5) }) -test_that("atlas_counts returns an empty tibble if number of records = 0", { +test_that("`count()` with `group_by()` returns an empty tibble if number of records = 0", { skip_if_offline(); skip_on_ci() counts <- galah_call() |> filter(year < 1900 & year > 2000) |> count() |> group_by(species) |> - collect() + quiet_collect() |> + purrr::pluck("result") expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) expect_equal(nrow(counts), 0) expect_equal(ncol(counts), 0) }) -test_that("grouped atlas_counts for species returns expected output", { +test_that("`count()` with `group_by()` for species returns expected output", { skip_if_offline(); skip_on_ci() - counts <- galah_call() |> + counts <- galah_call(type = "species") |> identify("Mammalia") |> filter(year == 2020) |> group_by(month) |> - count(type = "species") |> - collect() + count() |> + quiet_collect() |> + purrr::pluck("result") expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) expect_equal(names(counts), c("month", "count")) }) -test_that("group_by works for three groups", { +test_that("`count()` with `group_by()` works for three groups", { skip_if_offline(); skip_on_ci() counts <- galah_call() |> identify("cacatuidae") |> filter(year >= 2020) |> group_by(year, basisOfRecord, stateProvince) |> count() |> - collect() + quiet_collect() |> + purrr::pluck("result") expect_s3_class(counts, c("tbl_df", "tbl", "data.frame")) expect_gt(nrow(counts), 1) expect_true(all(names(counts) %in% c("basisOfRecord", "year", "stateProvince", "count"))) }) -test_that("group_by returns correct information when ID fields are requested", { +test_that("`count()` with `group_by()` returns correct information when ID fields are requested", { # NOTE: previously these were parsed as the `label` for that field, not the # value itself, hence this test skip_if_offline(); skip_on_ci() @@ -95,8 +103,9 @@ test_that("group_by returns correct information when ID fields are requested", { identify("pardalotus quadragintus") |> filter(year == 2023) |> group_by(species, dataResourceName, dataResourceUid) |> - count() |> - collect() + count() |> + quiet_collect() |> + purrr::pluck("result") expect_equal(colnames(counts), c("species", "dataResourceName", "dataResourceUid", "count")) expect_false(any(counts$dataResourceName == counts$dataResourceUid)) @@ -110,3 +119,5 @@ test_that("group_by fails for four groups", { group_by(year, month, basisOfRecord, stateProvince) |> expect_error() }) + +rm(quiet_collect) \ No newline at end of file diff --git a/tests/testthat/test-galah_identify.R b/tests/testthat/test-galah_identify.R index 404f1642..be81ddb4 100644 --- a/tests/testthat/test-galah_identify.R +++ b/tests/testthat/test-galah_identify.R @@ -1,117 +1,100 @@ +# set up quiet functions for testing reasons +purrr_compute <- purrr::quietly(compute.data_request) + # Warning generated by `galah_identify()` about empty query -test_that("galah_identify returns an empty tibble when no args provided", { +test_that("`galah_identify()` returns an empty tibble when no args provided", { expect_warning({result <- galah_identify()}) expect_equal(nrow(result), 0) expect_warning(galah_identify(), "No query passed") }) -test_that("galah_identify runs a search when given a string", { +test_that("`galah_identify()` runs a search when given a string", { result <- galah_identify("Litoria peronii") expect_equal(nrow(result), 1) }) -test_that("galah_identify runs a search on multiple strings", { +test_that("`galah_identify()` runs a search on multiple strings", { result <- galah_identify("amphibia", "reptilia", "aves", "mammalia") expect_equal(nrow(result), 4) }) -test_that("galah_identify runs a search on multiple strings wrapped by c()", { +test_that("`galah_identify()` runs a search on multiple strings wrapped by c()", { search_terms <- c("amphibia", "reptilia", "aves", "mammalia") result <- galah_identify(search_terms) expect_equal(nrow(result), 4) }) -test_that("galah_identify pipes correctly", { +test_that("`identify()` pipes correctly", { result <- galah_call() |> - galah_identify("Litoria") |> - galah_filter(year == 2020) + identify("Litoria") |> + filter(year == 2020) expect_false(is.null(result$identify)) expect_false(is.null(result$filter)) }) -test_that("galah_identify pipes correctly when taxa are partially returned", { +test_that("`identify()` pipes correctly when taxa are partially returned", { galah_config(verbose = FALSE) result <- galah_call() |> - galah_identify("Litoria", "blarghy") |> - galah_filter(year == 2020) + identify("Litoria", "blarghy") |> + filter(year == 2020) expect_false(is.null(result$identify)) expect_false(is.null(result$filter)) galah_config(verbose = TRUE) }) -test_that("galah_identify warns when taxa are partially returned", { +test_that("`identify()` warns when taxa are partially returned", { skip_if_offline(); skip_on_ci() - expect_message( - galah_call() |> - galah_identify("Litoria", "blarghy") |> - galah_filter(year == 2020) |> - count() |> - compute(), - cli::cli_text("Matched {.bold 1 of 2}") - ) + x <- galah_call() |> + identify("Litoria", "blarghy") |> + filter(year == 2020) |> + count() |> + purrr_compute() + x |> + purrr::pluck("messages") |> + stringr::str_detect("Matched 1 of 2 taxonomic search terms in selected atlas") |> + any() |> + expect_true() }) -test_that("galah_identify warns when identifiers are partially returned", { +test_that("`identify()` warns when identifiers are partially returned", { skip_if_offline(); skip_on_ci() galah_config(run_checks = TRUE) ids <- c("https://biodiversity.org.au/afd/taxa/0df99ece-1982-4605-a2b3-4fcb7660ee2b", "https://id.biodiversity.org.au/node/apni/2910467", "https://id.biodiversity.org.au/node/apni/291047") # wrong id - expect_message( - galah_call() |> - galah_identify(ids) |> - galah_filter(year == 2020) |> - count() |> - compute(), - cli::cli_text("Matched {.bold 2 of 3}") - ) + x <- galah_call() |> + identify(ids) |> + filter(year == 2020) |> + count() |> + purrr_compute() + x |> + purrr::pluck("messages") |> + stringr::str_detect("2 unmatched search terms:") |> + any() |> + expect_true() expect_no_warning( galah_identify(ids) ) }) -test_that("galah_identify truncates unmatched list of taxa at 3 ", { +test_that("`identify()` truncates unmatched list of taxa at 3 ", { skip_if_offline(); skip_on_ci() - expect_message( - galah_call() |> - galah_identify("Litoria", "blarghy", "blorp", "florp", "skorp") |> - galah_filter(year == 2020) |> - count() |> - compute(), - c( - cli::cli_text("Matched {.bold 1 of 5} taxonomic search terms in selected atlas (Australia)."), - "!" = cli::cli_text("{.yellow 4 unmatched search term:}"), - cli::cli_text(format_error_bullets(c("{.yellow \"blarghy\", \"blorp\", \"florp\" + 1 more}"))) - ) - ) -}) - -test_that("galah_identify errors for deprecated `search = FALSE` argument", { - skip_if_offline(); skip_on_ci() - galah_config(run_checks = TRUE) - ids <- c("https://biodiversity.org.au/afd/taxa/0df99ece-1982-4605-a2b3-4fcb7660ee2b", - "https://id.biodiversity.org.au/node/apni/2910467", - "https://id.biodiversity.org.au/node/apni/291047", - "fred", - "bort") # wrong id - expect_error( - galah_call() |> - galah_identify(ids, search = FALSE) |> - galah_filter(year == 2020) |> - count() |> - collapse()) -}) - -test_that("galah_identify warns for deprecated `search = TRUE` argument", { - skip_if_offline(); skip_on_ci() - galah_config(run_checks = TRUE) - ids <- c("Litoria", "Crinia") - expect_warning( - galah_call() |> - galah_identify(ids, search = TRUE) |> - galah_filter(year == 2020) |> - count() |> - collapse()) + x <- galah_call() |> + galah_identify("Litoria", "blarghy", "blorp", "florp", "skorp") |> + galah_filter(year == 2020) |> + count() |> + purrr_compute() + expected_messages <- c( + "Matched 1 of 5 taxonomic search terms in selected atlas (Australia).\n", + "4 unmatched search terms:\n", + "\"blarghy\", \"blorp\", \"florp\" + 1 more\"\n", + "\n") + actual_messages <- purrr::pluck(x, "messages") + # NOTE: due to differences in how dot points are represented, this test + # fails unless we handle the strings carefully + expect_equal( + stringr::str_replace_all(actual_messages, "[:punct:]", "") |> trimws(), + stringr::str_replace_all(expected_messages, "[:punct:]", "") |> trimws()) }) ## NOTE: Not certain if this is a necessary test @@ -127,3 +110,5 @@ test_that("galah_identify warns for deprecated `search = TRUE` argument", { # ) # })) # }) + +rm(purrr_compute) \ No newline at end of file diff --git a/tests/testthat/test-galah_polygon.R b/tests/testthat/test-galah_polygon.R index 26e864f5..97506ae0 100644 --- a/tests/testthat/test-galah_polygon.R +++ b/tests/testthat/test-galah_polygon.R @@ -2,21 +2,26 @@ test_that("galah_polygon uses first argument", { wkt_1 <- "POLYGON((142.36228 -29.00703,142.74131 -29.00703,142.74131 -29.39064,142.36228 -29.39064,142.36228 -29.00703))" wkt_2 <- "POLYGON((145.6765 -42.13203, 145.9652 -42.63203, 146.5425 -42.63203, 146.8312 -42.13203, 146.5425 -41.63203, 145.9652 -41.63203, 145.6765 -42.13203))" expected_polygon <- "MULTIPOLYGON (((142.3623 -29.00703, 142.7413 -29.00703, 142.7413 -29.39064, 142.3623 -29.39064, 142.3623 -29.00703)))" - polygon_1 <- expect_warning(galah_polygon(wkt_1, wkt_2)) - expect_equal(as.character(polygon_1), - galah_polygon(wkt_1)[1], - expected_polygon) + warning_text <- expect_warning(galah_polygon(wkt_1, wkt_2)) + grepl("More than 1 spatial area provided", warning_text) |> + any() |> + expect_true() + quiet_polygons <- purrr::quietly(galah_polygon) + calculated_polygon <- quiet_polygons(wkt_1, wkt_2)$result + expect_identical(calculated_polygon, + galah_polygon(wkt_1)[1], + expected_polygon) }) test_that("galah_polygon checks inputs", { poly_path <- test_path("testdata", "act_state_polygon_shp", "ACT_STATE_POLYGON_shp.shp") wkt_path <- test_path("testdata", "long_act_wkt.txt") - expect_error(galah_polygon(st_read(poly_path, quiet = TRUE))) + expect_error(galah_polygon(sf::st_read(poly_path, quiet = TRUE))) expect_error(galah_polygon(readLines(wkt_path))) }) test_that("galah_polygon finds polygon errors 1" , { - skip_on_cran() + skip_if_offline(); skip_on_ci() invalid_wkt <- "POLYGON((145.71622941565508 -32.17848852726597,))" expect_error(galah_polygon(invalid_wkt)) # NOTE: @@ -37,18 +42,19 @@ test_that("galah_polygon converts WKT strings to multipolygon", { test_that("galah_polygon converts WKT strings with spaces", { wkt_with_spaces <- "POLYGON ((143.32 -18.78,145.30 -20.52,141.52 -21.50,143.32 -18.78))" - converted_wkt_with_spaces <- build_wkt(st_as_sfc(wkt_with_spaces)) + converted_wkt_with_spaces <- build_wkt(sf::st_as_sfc(wkt_with_spaces)) expect_match(converted_wkt_with_spaces, "MULTIPOLYGON \\(\\(\\(143\\.32") }) test_that("galah_polygon converts sf object to multipolygon", { - sf_wkt <- "POLYGON((143.32 -18.78,145.30 -20.52,141.52 -21.50,143.32 -18.78))" |> st_as_sfc() + sf_wkt <- "POLYGON((143.32 -18.78,145.30 -20.52,141.52 -21.50,143.32 -18.78))" |> + sf::st_as_sfc() expect_match(galah_polygon(sf_wkt), "MULTIPOLYGON") }) test_that("galah_polygon counts vertices correctly", { wkt <- "POLYGON((143.32 -18.78,145.30 -20.52,141.52 -21.50,143.32 -18.78))" - expect_equal(n_points(st_as_sfc(wkt)), 4) + expect_equal(n_points(sf::st_as_sfc(wkt)), 4) }) test_that("galah_polygon checks for simple polygons only", { @@ -60,7 +66,8 @@ test_that("galah_polygon checks for simple polygons only", { }) test_that("galah_polygon counts n vertices correctly", { - sf_wkt <- "POLYGON((143.32 -18.78,145.30 -20.52,141.52 -21.50,143.32 -18.78))" |> st_as_sfc() + sf_wkt <- "POLYGON((143.32 -18.78,145.30 -20.52,141.52 -21.50,143.32 -18.78))" |> + sf::st_as_sfc() poly_path <- test_path("testdata", "act_state_polygon_shp", "ACT_STATE_POLYGON_shp.shp") shapefile_complex <- sf::st_read(poly_path, quiet = TRUE) expect_equal(n_points(shapefile_complex), 2787) diff --git a/tests/testthat/test-galah_radius.R b/tests/testthat/test-galah_radius.R index 9acfcac9..8191fb67 100644 --- a/tests/testthat/test-galah_radius.R +++ b/tests/testthat/test-galah_radius.R @@ -1,9 +1,13 @@ +purrr_radius <- purrr::quietly(galah_radius) +quiet_radius <- function(...){ + purrr_radius(...) |> + purrr::pluck("result")} test_that("galah_radius returns list from lon/lat/radius arguments", { lon <- 151.3174 lat <- -33.66741 radius = 3 - radius_object <- galah_radius(lon = lon, + radius_object <- quiet_radius(lon = lon, lat = lat, radius = radius) expected_object <- list(lat = -33.66741, @@ -15,12 +19,13 @@ test_that("galah_radius returns list from lon/lat/radius arguments", { test_that("galah_radius assigns default radius when missing argument", { lon <- 151.3174 lat <- -33.66741 - radius_object <- expect_warning(galah_radius(lon = lon, lat = lat), - "No radius value specified.") + radius_object <- purrr_radius(lon = lon, lat = lat) + grepl("No radius value specified.", radius_object$warning) |> + expect_true() expected_object <- list(lat = -33.66741, lon = 151.3174, radius = 10) # default is 10 km - expect_equal(radius_object, expected_object) + expect_equal(radius_object$result, expected_object) }) test_that("galah_radius returns radius for sf_POINT object", { @@ -29,7 +34,8 @@ test_that("galah_radius returns radius for sf_POINT object", { expected_object <- list(lat = -33.66741, lon = 151.3174, radius = 3) - expect_equal(galah_radius(point, radius = 3), expected_object) + quiet_radius(point, radius = 3) |> + expect_equal(expected_object) }) test_that("galah_radius errors when more complex sf objects are passed", { @@ -85,7 +91,7 @@ test_that("galah_radius messages when radius is very large", { radius <- 1600 expect_message( galah_radius(lon = 151, lat = -32, radius = radius), - "Radius is larger than the area of Australia") + "Supplied radius is larger than the area of Australia") }) test_that("galah_radius only uses first arguments supplied to lon/lat/radius", { @@ -109,21 +115,16 @@ test_that("galah_radius only uses first arguments supplied to lon/lat/radius", { radius = multiple_radius), "More than 1 radius") - expect_equal( - suppressWarnings( - galah_radius(lon = multiple_lon, lat = -31, radius = radius)$lon), - expected_object$lon - ) - expect_equal( - suppressWarnings( - galah_radius(lon = 151, lat = multiple_lat, radius = radius)$lat), - expected_object$lat - ) - expect_equal( - suppressWarnings( - galah_radius(lon = 151, lat = -31, radius = multiple_radius)$radius), - expected_object$radius - ) + quiet_radius(lon = multiple_lon, lat = -31, radius = radius) |> + purrr::pluck("lon") |> + expect_equal(expected_object$lon) + quiet_radius(lon = 151, lat = multiple_lat, radius = radius) |> + purrr::pluck("lat") |> + expect_equal(expected_object$lat) + quiet_radius(lon = 151, lat = -31, radius = multiple_radius) |> + purrr::pluck("radius") |> + expect_equal(expected_object$radius) }) # TODO: (after implementing) galah_radius uses only first coordinates of tibble with many coordinates +rm(purrr_radius, quiet_radius) \ No newline at end of file diff --git a/tests/testthat/test-international-Austria.R b/tests/testthat/test-international-Austria.R index a4d22004..917cdf1c 100644 --- a/tests/testthat/test-international-Austria.R +++ b/tests/testthat/test-international-Austria.R @@ -116,20 +116,23 @@ test_that("search_all(taxa) works for Austria", { expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) }) -test_that("show_values works for fields for Austria", { +test_that("show_values works for Austria", { skip_if_offline(); skip_on_ci() + quiet_values <- function(...){ + x <- purrr::quietly(show_values) + x(...)$result + } + # fields x <- try({search_all(fields, "basis_of_record") |> - show_values()}, + quiet_values()}, silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gte(nrow(x), 1) expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -}) -test_that("show_values works for lists for Austria", { - skip_if_offline(); skip_on_ci() + # lists x <- try({search_all(lists, "dr30") |> - show_values()}, + quiet_values()}, silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gte(nrow(x), 1) @@ -139,7 +142,7 @@ test_that("show_values works for lists for Austria", { test_that("atlas_counts works with type = 'occurrences' for Austria", { skip_if_offline(); skip_on_ci() x <- atlas_counts() |> - pull(count) |> + dplyr::pull(count) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(x, 0) @@ -148,7 +151,7 @@ test_that("atlas_counts works with type = 'occurrences' for Austria", { test_that("atlas_counts works with type = 'species' for Austria", { skip_if_offline(); skip_on_ci() x <- atlas_counts(type = "species") |> - pull(count) |> + dplyr::pull(count) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(x, 0) @@ -224,7 +227,7 @@ test_that("atlas_occurrences works for Austria", { skip_if(inherits(occ_collapse, "try-error"), message = "API not available") expect_s3_class(occ_collapse, "query") expect_equal(names(occ_collapse), - c("type", "url", "headers", "filter")) + c("type", "url", "headers", "request")) expect_equal(occ_collapse$type, "data/occurrences") # compute occ_compute <- compute(occ_collapse) @@ -250,33 +253,32 @@ test_that("atlas_media() works for Austria", { send_email = FALSE) x <- request_data() |> identify("Mammalia") |> - filter(year == 2010, - # !is.na(all_image_url) - ) |> - # count() |> - # collect() + filter(year == 2010) |> # !is.na(all_image_url) atlas_media() |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) expect_gte(nrow(x), 1) expect_equal(colnames(x)[1:2], - c("media_id", "recordID")) + c("media_id", "media_type")) # download a subset + quiet_media <- function(...){ + x <- purrr::quietly(collect_media) + x(...)$result + } n_downloads <- 5 - collect_media(x[seq_len(n_downloads), ]) + quiet_media(x[seq_len(n_downloads), ]) expect_equal(length(list.files("temp", pattern = ".jpg$")), n_downloads) unlink("temp", recursive = TRUE) }) -## FIXME: atlas_taxonomy doesn't work test_that("atlas_taxonomy works for Austria", { skip_if_offline(); skip_on_ci() y <- galah_call() |> identify("Aves") |> filter(rank >= order) |> - atlas_taxonomy()|> + atlas_taxonomy() |> try(silent = TRUE) skip_if(inherits(y, "try-error"), message = "API not available") # add tests @@ -286,4 +288,6 @@ test_that("atlas_taxonomy works for Austria", { expect_gte(nrow(y), 5) }) -galah_config(atlas = "Australia") +quiet_config <- purrr::quietly(galah_config) +quiet_config(atlas = "Australia") +rm(quiet_config) \ No newline at end of file diff --git a/tests/testthat/test-international-Brazil.R b/tests/testthat/test-international-Brazil.R index ca439ddb..4dd70b8e 100644 --- a/tests/testthat/test-international-Brazil.R +++ b/tests/testthat/test-international-Brazil.R @@ -85,45 +85,49 @@ test_that("search_all(taxa) works for Brazil", { expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) }) -test_that("show_values works for Brazil", { +test_that("`show_values()` works for Brazil", { skip_if_offline(); skip_on_ci() + quiet_values <- function(...){ + x <- purrr::quietly(show_values) + x(...)$result + } x <- search_fields("basis_of_record") |> - show_values() |> + quiet_values() |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(nrow(x), 1) y <- search_lists("drt1565630923841") |> - show_values() |> + quiet_values() |> try(silent = TRUE) skip_if(inherits(y, "try-error"), message = "API not available") expect_gt(nrow(y), 1) search_profiles("profile") |> - show_values() |> + quiet_values() |> expect_error() }) -test_that("atlas_counts works for Brazil", { +test_that("`atlas_counts()` works for Brazil", { skip_if_offline(); skip_on_ci() x <- atlas_counts() |> - pull(count) |> + dplyr::pull(count) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(x, 0) }) -test_that("atlas_counts works with type = 'species' for Brazil", { +test_that("`atlas_counts()` works with type = 'species' for Brazil", { skip_if_offline(); skip_on_ci() x <- atlas_counts(type = "species") |> - pull(count) |> + dplyr::pull(count) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(x, 0) }) -test_that("atlas_counts works with galah_identify for Brazil", { +test_that("`atlas_counts()` works with `identify()` for Brazil", { skip_if_offline(); skip_on_ci() query1 <- galah_call() |> - galah_identify("Mammalia") |> + identify("Mammalia") |> count() |> collapse() # note: this is set up differently for debugging result1 <- collect(query1) |> @@ -131,7 +135,7 @@ test_that("atlas_counts works with galah_identify for Brazil", { skip_if(inherits(result1, "try-error"), message = "API not available") expect_gt(result1$count, 1) query2 <- galah_call() |> - galah_filter(class == "Mammalia") |> + filter(class == "Mammalia") |> count() |> collapse() result2 <- collect(query2) |> @@ -144,7 +148,7 @@ test_that("atlas_counts works with galah_identify for Brazil", { ## This isn't met for this atlas, for unknown reasons }) -test_that("atlas_counts works with group_by for Brazil", { +test_that("`atlas_counts()` works with `group_by()` for Brazil", { skip_if_offline(); skip_on_ci() result <- galah_call() |> galah_filter(year >= 2020) |> @@ -156,7 +160,7 @@ test_that("atlas_counts works with group_by for Brazil", { expect_equal(names(result), c("year", "count")) }) -test_that("atlas_species works for Brazil", { +test_that("`atlas_species()` works for Brazil", { skip_if_offline(); skip_on_ci() galah_config( atlas = "Brazil", @@ -164,7 +168,7 @@ test_that("atlas_species works for Brazil", { run_checks = FALSE, send_email = FALSE) spp <- galah_call() |> - galah_identify("Carnivora") |> + identify("Carnivora") |> atlas_species() |> try(silent = TRUE) skip_if(inherits(spp, "try-error"), message = "API not available") @@ -174,7 +178,7 @@ test_that("atlas_species works for Brazil", { }) ## FIXME: Caused by taxonomic search issue -test_that("atlas_occurrences works for Brazil", { +test_that("`atlas_occurrences()` works for Brazil", { skip_if_offline(); skip_on_ci() galah_config( atlas = "Brazil", @@ -190,7 +194,7 @@ test_that("atlas_occurrences works for Brazil", { skip_if(inherits(occ_collapse, "try-error"), message = "API not available") expect_s3_class(occ_collapse, "query") expect_equal(names(occ_collapse), - c("type", "url", "headers", "filter")) + c("type", "url", "headers", "request")) occ_compute <- compute(occ_collapse) |> try(silent = TRUE) skip_if(inherits(occ_compute, "try-error"), message = "API not available") @@ -200,7 +204,7 @@ test_that("atlas_occurrences works for Brazil", { try(silent = TRUE) skip_if(inherits(occ, "try-error"), message = "API not available") expect_gt(nrow(occ), 0) - expect_equal(ncol(occ), 8) + expect_equal(ncol(occ), 9) expect_true(inherits(occ, c("tbl_df", "tbl", "data.frame"))) }) @@ -208,7 +212,7 @@ test_that("atlas_occurrences works for Brazil", { # "Ramphastos toco" # toucan # "Myrmecophaga tridactyla" # anteater -test_that("atlas_media() works for Brazil", { +test_that("`atlas_media()` works for Brazil", { skip_if_offline(); skip_on_ci() galah_config( atlas = "Brazil", @@ -217,11 +221,7 @@ test_that("atlas_media() works for Brazil", { send_email = FALSE) x <- request_data() |> identify("Mammalia") |> - filter(year == 2010 - # !is.na(all_image_url) - ) |> - # count() |> - # collect() + filter(year == 2010) |> atlas_media() |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") @@ -230,11 +230,17 @@ test_that("atlas_media() works for Brazil", { expect_equal(colnames(x)[1:2], c("media_id", "recordID")) # download a subset + quiet_media <- function(...){ + x <- purrr::quietly(collect_media) + x(...)$result + } n_downloads <- 5 - collect_media(x[seq_len(n_downloads), ]) + quiet_media(x[seq_len(n_downloads), ]) expect_equal(length(list.files("temp", pattern = ".jpg$")), n_downloads) unlink("temp", recursive = TRUE) }) -galah_config(atlas = "Australia") +quiet_config <- purrr::quietly(galah_config) +quiet_config(atlas = "Australia") +rm(quiet_config) \ No newline at end of file diff --git a/tests/testthat/test-international-Flanders.R b/tests/testthat/test-international-Flanders.R index 53f4deb1..49acfe23 100644 --- a/tests/testthat/test-international-Flanders.R +++ b/tests/testthat/test-international-Flanders.R @@ -1,311 +1,316 @@ -# Tests commented out until Flanders atlas is operational +# set verbose to off +galah_config(verbose = FALSE, run_checks = FALSE) -# # set verbose to off -# galah_config(verbose = FALSE, run_checks = FALSE) -# -# test_that("swapping to atlas = Flanders works", { -# expect_message(galah_config(atlas = "Flanders")) -# }) -# -# test_that("show_all(fields) works for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- show_all(fields) |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_gt(nrow(x), 1) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# # also that fields match those returned by default_columns() -# y <- default_columns() # internal function called by `galah_select()` -# expect_true(all(y %in% x$id)) -# }) -# -# test_that("show_all(licences) works for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- show_all(licences) |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_gt(nrow(x), 1) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("show_all(collections) works for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- show_all(collections, limit = 10) |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_lte(nrow(x), 10) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("show_all(datasets) works for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- show_all(datasets, limit = 10) |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_lte(nrow(x), 10) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("show_all(providers) works for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- show_all(providers, limit = 10) |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_lte(nrow(x), 10) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("show_all(reasons) works for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- show_all(reasons) |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_gt(nrow(x), 1) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("show_all(assertions) works for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- show_all(assertions) |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_gt(nrow(x), 1) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("show_all(profiles) works for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- show_all(profiles) |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_gt(nrow(x), 1) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("show_all(lists) works for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- show_all(lists, limit = 10) |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_lte(nrow(x), 10) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("search_all(fields) works for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- search_all(fields, "year") |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_gte(nrow(x), 1) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("search_all(taxa) works for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- search_all(taxa, "Mammalia") |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_gte(nrow(x), 1) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("search_all(taxa) works using data.frames for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- search_all(taxa, -# data.frame(kingdom = "Animalia", -# phylum = "Chordata")) |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_gte(nrow(x), 1) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("search_all(identifiers) works for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- search_all(identifiers, "359") |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_gte(nrow(x), 1) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("show_values works for fields for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- search_all(fields, "basisOfRecord") |> -# show_values() |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_gte(nrow(x), 1) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("show_values works for profiles for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- search_all(profiles, "LA") |> -# show_values() |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_gte(nrow(x), 1) -# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("atlas_counts works for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- atlas_counts() |> -# pull(count) |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_gt(x, 0) -# }) -# -# test_that("atlas_counts works with type = 'species' for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- atlas_counts(type = "species") |> -# pull(count) |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_gt(x, 0) -# }) -# -# test_that("atlas_counts works with galah_identify for Flanders", { -# skip_if_offline(); skip_on_ci() -# result <- galah_call() |> -# identify("Mammalia") |> -# count() |> -# collect() |> -# try(silent = TRUE) -# skip_if(inherits(result, "try-error"), message = "API not available") -# expect_gt(result$count, 1) -# result2 <- galah_call() |> -# filter(class == "Mammalia") |> -# count() |> -# collect() |> -# try(silent = TRUE) -# skip_if(inherits(result2, "try-error"), message = "API not available") -# expect_lt( -# sqrt((result2$count - result$count)^2) / result$count, -# 0.1) # i.e. <1% margin of error -# }) -# -# test_that("atlas_counts works with apply_profile for Flanders", { -# skip_if_offline(); skip_on_ci() -# without_profile <- galah_call() |> -# count() |> -# collect() -# with_profile <- galah_call() |> -# apply_profile(LA) |> -# count() |> -# collect() -# expect_gt(with_profile$count, 0) -# expect_equal(class(without_profile), class(with_profile)) -# expect_lt(with_profile$count, without_profile$count) -# }) -# -# test_that("atlas_counts works with group_by for Flanders", { -# skip_if_offline(); skip_on_ci() -# result <- galah_call() |> -# filter(year >= 2000) |> -# group_by(basis_of_record) |> -# count() |> -# collect() |> -# try(silent = TRUE) -# skip_if(inherits(result, "try-error"), message = "API not available") -# expect_gt(nrow(result), 1) -# expect_equal(names(result), c("basis_of_record", "count")) -# }) -# -# test_that("atlas_counts works with apply_profile for Flanders", { -# skip_if_offline(); skip_on_ci() -# without_profile <- galah_call() |> -# count() |> -# collect() -# with_profile <- galah_call() |> -# apply_profile(LA) |> -# count() |> -# collect() -# expect_gt(with_profile$count, 0) -# expect_equal(class(without_profile), class(with_profile)) -# expect_lt(with_profile$count, without_profile$count) -# }) -# -# test_that("atlas_species works for Flanders", { -# skip_if_offline(); skip_on_ci() -# galah_config( -# atlas = "Flanders", -# email = "test@ala.org.au", -# send_email = FALSE) -# spp <- galah_call() |> -# galah_identify("Carnivora") |> -# atlas_species() |> -# try(silent = TRUE) -# skip_if(inherits(spp, "try-error"), message = "API not available") -# expect_gt(nrow(spp), 20) -# expect_equal(ncol(spp), 11) -# expect_s3_class(spp, c("tbl_df", "tbl", "data.frame")) -# }) -# -# test_that("galah_select works for Flanders", { -# skip_if_offline(); skip_on_ci() -# x <- galah_select() -# y <- galah_select(basisOfRecord) -# expect_equal(length(x), 2) -# expect_equal(x$summary, "group = basic") -# expect_equal(x$group, "basic") -# expect_true(inherits(x, c("list"))) -# expect_equal(length(y), 3) -# expect_equal(y$summary, "basisOfRecord") -# expect_equal(y$group, character(0)) -# expect_true(inherits(y, c("list"))) -# expect_true(inherits(y[[1]], c("quosure", "formula"))) -# }) -# -# test_that("atlas_occurrences works for Flanders", { -# skip_if_offline(); skip_on_ci() -# galah_config( -# atlas = "Flanders", -# email = "test@ala.org.au", -# download_reason_id = 10, -# send_email = FALSE) -# occ <- galah_call() |> -# identify("Mammalia") |> -# filter(year <= 1800) |> -# select(species, year) |> -# atlas_occurrences() |> -# try(silent = TRUE) -# skip_if(inherits(occ, "try-error"), message = "API not available") -# expect_gt(nrow(occ), 0) -# expect_equal(ncol(occ), 2) -# expect_true(inherits(occ, c("tbl_df", "tbl", "data.frame"))) -# }) -# -# test_that("atlas_media() works for Flanders", { -# skip_if_offline(); skip_on_ci() -# galah_config( -# atlas = "Flanders", -# email = "test@ala.org.au", -# download_reason_id = 10, -# directory = "temp", -# send_email = FALSE) -# x <- request_data() |> -# identify("Mammalia") |> -# filter(year >= 2023 -# # imageIDsCount > 0 -# ) |> -# # count() |> -# # collect() -# atlas_media() |> -# try(silent = TRUE) -# skip_if(inherits(x, "try-error"), message = "API not available") -# expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) -# expect_gte(nrow(x), 1) -# expect_equal(colnames(x)[1:2], -# c("media_id", "recordID")) -# # download a subset -# n_downloads <- 5 -# collect_media(x[seq_len(n_downloads), ]) -# expect_equal(length(list.files("temp", pattern = ".jpg$")), -# n_downloads) -# unlink("temp", recursive = TRUE) -# }) -# -# galah_config(atlas = "Australia") +test_that("swapping to atlas = Flanders works", { + expect_message(galah_config(atlas = "Flanders")) +}) + +test_that("show_all(fields) works for Flanders", { + skip_if_offline(); skip_on_ci() + x <- show_all(fields) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gt(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) + # also that fields match those returned by default_columns() + y <- default_columns() # internal function called by `galah_select()` + expect_true(all(y %in% x$id)) +}) + +test_that("show_all(licences) works for Flanders", { + skip_if_offline(); skip_on_ci() + x <- show_all(licences) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gt(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("show_all(providers) works for Flanders", { + skip_if_offline(); skip_on_ci() + x <- show_all(providers, limit = 10) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_lte(nrow(x), 10) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("show_all(collections) works for Flanders", { + skip_if_offline(); skip_on_ci() + x <- show_all(collections, limit = 10) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_lte(nrow(x), 10) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("show_all(datasets) works for Flanders", { + skip_if_offline(); skip_on_ci() + x <- show_all(datasets, limit = 10) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_lte(nrow(x), 10) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("show_all(reasons) works for Flanders", { + skip_if_offline(); skip_on_ci() + x <- show_all(reasons) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gt(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("show_all(assertions) works for Flanders", { + skip_if_offline(); skip_on_ci() + x <- show_all(assertions) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gt(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("show_all(profiles) works for Flanders", { + skip_if_offline(); skip_on_ci() + x <- show_all(profiles) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gte(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) + + # and values + y <- request_metadata() |> + filter(profiles == x$short_name[1]) |> + unnest() |> + collect() |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gt(nrow(y), 1) + expect_true(inherits(y, c("tbl_df", "tbl", "data.frame"))) + + # and actually reduces record count + records_all <- galah_call() |> + count() |> + collect() + records_clean <- galah_call() |> + apply_profile(x$short_name[1]) |> + count() |> + collect() + expect_lt(records_clean$count, records_all$count) +}) + +test_that("show_all(lists) works for Flanders", { + skip_if_offline(); skip_on_ci() + x <- show_all(lists, limit = 10) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_lte(nrow(x), 10) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("`unnest()` works for lists in Flanders", { + skip_if_offline(); skip_on_ci() + x <- request_metadata() |> + filter(list == "dr565") |> + unnest() |> + collect() |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gte(nrow(x), 10) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("search_all(fields) works for Flanders", { + skip_if_offline(); skip_on_ci() + x <- search_all(fields, "year") |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gte(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("search_all(taxa) works for Flanders", { + skip_if_offline(); skip_on_ci() + x <- search_all(taxa, "Mammalia") |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gte(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) + expect_true(any(colnames(x) == "taxon_concept_id")) +}) + +test_that("search_all(identifiers) works for Flanders", { + skip_if_offline(); skip_on_ci() + x <- search_all(identifiers, "359") |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gte(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("show_values works for fields for Flanders", { + skip_if_offline(); skip_on_ci() + quiet_values <- function(...){ + x <- purrr::quietly(show_values) + x(...)$result + } + x <- search_all(fields, "basisOfRecord") |> + quiet_values() |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gte(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("atlas_counts works for Flanders", { + skip_if_offline(); skip_on_ci() + x <- atlas_counts() |> + dplyr::pull(count) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gt(x, 0) +}) + +test_that("atlas_counts works with type = 'species' for Flanders", { + skip_if_offline(); skip_on_ci() + x <- atlas_counts(type = "species") |> + dplyr::pull(count) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gt(x, 0) +}) + +test_that("`count()` works with galah_identify for Flanders", { + skip_if_offline(); skip_on_ci() + result <- galah_call() |> + identify("Mammalia") |> + count() |> + collect() |> + try(silent = TRUE) + skip_if(inherits(result, "try-error"), message = "API not available") + expect_gt(result$count, 1) + result2 <- galah_call() |> + filter(class == "Mammalia") |> + count() |> + collect() |> + try(silent = TRUE) + skip_if(inherits(result2, "try-error"), message = "API not available") + expect_lt( + sqrt((result2$count - result$count)^2) / result$count, + 0.1) # i.e. <1% margin of error +}) + +test_that("`glimpse()` works for Flanders", { + skip_if_offline(); skip_on_ci() + x <- galah_call() |> + filter(year == 2025) |> + glimpse() |> + collect() + expect_s3_class(x, c("occurrences_glimpse", "tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x), 3) # number of rows in the tibble + quiet_print <- purrr::quietly(print.occurrences_glimpse) + x_print <- strsplit(quiet_print(x)$output, "\n")[[1]] # print statement + expect_gt(length(x_print), 5) + stringr::str_detect(x_print, + "^\\$ (taxonConceptID|eventDate|decimalLatitude|scientificName)") |> + which() |> + length() |> + expect_equal(4) # note: recordID missing +}) + +test_that("`count()` works with `group_by()` for Flanders", { + skip_if_offline(); skip_on_ci() + result <- galah_call() |> + filter(year >= 2000) |> + group_by(basisOfRecord) |> + count() |> + collect() |> + try(silent = TRUE) + skip_if(inherits(result, "try-error"), message = "API not available") + expect_gt(nrow(result), 1) + expect_equal(names(result), c("basisOfRecord", "count")) + }) + +test_that("`atlas_species()` works for Flanders", { + skip_if_offline(); skip_on_ci() + galah_config( + atlas = "Flanders", + email = "galah@natuurdata@inbo.be", + send_email = FALSE) + spp <- galah_call() |> + identify("Corvus") |> + atlas_species() |> + try(silent = TRUE) + skip_if(inherits(spp, "try-error"), message = "API not available") + expect_gt(nrow(spp), 1) + expect_equal(ncol(spp), 11) + expect_s3_class(spp, c("tbl_df", "tbl", "data.frame")) +}) + +test_that("`atlas_occurrences()` works for Flanders", { + skip_if_offline(); skip_on_ci() + galah_config( + atlas = "Flanders", + email = "galah.natuurdata@inbo.be", + download_reason_id = 10, + send_email = FALSE) + query <- galah_call() |> + identify("Canis") |> + filter(year == 2020) |> + select(species, year) |> + collapse() + + response <- compute(query) |> + try(silent = TRUE) + skip_if(inherits(response, "try-error"), message = "API not available") + + occ <- collect(response) |> + try(silent = TRUE) + skip_if(inherits(occ, "try-error"), message = "API not available") + + expect_gt(nrow(occ), 0) + expect_equal(ncol(occ), 2) + expect_true(inherits(occ, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("`atlas_media()` works for Flanders", { + skip_if_offline(); skip_on_ci() + galah_config( + atlas = "Flanders", + email = "test@ala.org.au", + download_reason_id = 10, + directory = "temp", + send_email = FALSE) + x <- request_data() |> + identify("Vulpes") |> + filter(year == 2025, + basisOfRecord == "HUMAN_OBSERVATION", + # month == 6, + !is.na(images) + ) |> + # group_by(year) |> + # count() |> + # collect() + atlas_media() |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_gte(nrow(x), 1) + expect_equal(colnames(x)[1:2], + c("media_id", "media_type")) + # download a subset + quiet_media <- function(...){ + x <- purrr::quietly(collect_media) + x(...)$result + } + n_downloads <- 5 + quiet_media(x[seq_len(n_downloads), ]) + expect_equal(length(list.files("temp", pattern = ".jpg$")), + n_downloads) + unlink("temp", recursive = TRUE) +}) + +quiet_config <- purrr::quietly(galah_config) +quiet_config(atlas = "Australia") +rm(quiet_config) \ No newline at end of file diff --git a/tests/testthat/test-international-France.R b/tests/testthat/test-international-France.R index 0624436b..bd6b7b00 100644 --- a/tests/testthat/test-international-France.R +++ b/tests/testthat/test-international-France.R @@ -1,12 +1,15 @@ # set verbose to off galah_config(verbose = FALSE, run_checks = FALSE) +skip_message <- "French APIs disabled at source" + test_that("swapping to atlas = France works", { expect_message(galah_config(atlas = "France")) }) test_that("show_all(fields) works for France", { skip_if_offline(); skip_on_ci() + skip(skip_message) x <- show_all(fields) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") @@ -16,6 +19,7 @@ test_that("show_all(fields) works for France", { test_that("show_all(collections) works for France", { skip_if_offline(); skip_on_ci() + skip(skip_message) x <- show_all(collections, limit = 10) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") @@ -25,6 +29,7 @@ test_that("show_all(collections) works for France", { test_that("show_all(datasets) works for France", { skip_if_offline(); skip_on_ci() + skip(skip_message) x <- show_all(datasets, limit = 10) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") @@ -34,6 +39,7 @@ test_that("show_all(datasets) works for France", { test_that("show_all(providers) works for France", { skip_if_offline(); skip_on_ci() + skip(skip_message) x <- show_all(providers, limit = 10) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") @@ -42,11 +48,14 @@ test_that("show_all(providers) works for France", { }) test_that("show_all(reasons) fails for France", { + skip_if_offline(); skip_on_ci() + skip(skip_message) expect_error(show_all(reasons)) }) test_that("show_all(assertions) works for France", { skip_if_offline(); skip_on_ci() + skip(skip_message) x <- show_all(assertions) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") @@ -55,15 +64,20 @@ test_that("show_all(assertions) works for France", { }) test_that("show_all(profiles) fails for France", { + skip_if_offline(); skip_on_ci() + skip(skip_message) expect_error(show_all(profiles)) }) test_that("show_all(lists) fails for France", { + skip_if_offline(); skip_on_ci() + skip(skip_message) expect_error(show_all(lists)) }) test_that("search_all(fields) works for France", { skip_if_offline(); skip_on_ci() + skip(skip_message) x <- search_all(fields, "year") |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") @@ -73,6 +87,7 @@ test_that("search_all(fields) works for France", { test_that("search_all(taxa) works for France", { skip_if_offline(); skip_on_ci() + skip(skip_message) x <- search_all(taxa, "Vulpes vulpes") |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") @@ -82,6 +97,7 @@ test_that("search_all(taxa) works for France", { test_that("show_values works for France", { skip_if_offline(); skip_on_ci() + skip(skip_message) x <- search_fields("basisOfRecord") |> show_values() |> try(silent = TRUE) @@ -91,6 +107,7 @@ test_that("show_values works for France", { test_that("atlas_counts works for France", { skip_if_offline(); skip_on_ci() + skip(skip_message) x <- atlas_counts() |> pull(count) |> try(silent = TRUE) @@ -100,6 +117,7 @@ test_that("atlas_counts works for France", { test_that("atlas_counts works with type = 'species' for France", { skip_if_offline(); skip_on_ci() + skip(skip_message) x <- atlas_counts(type = "species") |> pull(count) |> try(silent = TRUE) @@ -109,6 +127,7 @@ test_that("atlas_counts works with type = 'species' for France", { test_that("atlas_counts works with galah_identify for France", { skip_if_offline(); skip_on_ci() + skip(skip_message) result <- galah_call() |> identify("Mammalia") |> count() |> @@ -128,6 +147,7 @@ test_that("atlas_counts works with galah_identify for France", { test_that("atlas_counts works with group_by for France", { skip_if_offline(); skip_on_ci() + skip(skip_message) result <- galah_call() |> filter(year >= 2018) |> group_by(year) |> @@ -141,6 +161,7 @@ test_that("atlas_counts works with group_by for France", { test_that("atlas_species works for France", { skip_if_offline(); skip_on_ci() + skip(skip_message) galah_config(email = "ala4r@ala.org.au") x <- galah_call(type = "species") |> identify("Lagomorpha") |> @@ -155,6 +176,7 @@ test_that("atlas_species works for France", { test_that("atlas_occurrences works for France", { skip_if_offline(); skip_on_ci() + skip(skip_message) galah_config(atlas = "France", email = "ala4r@ala.org.au") base_query <- galah_call() |> @@ -187,4 +209,6 @@ test_that("atlas_occurrences works for France", { unlink("temp", recursive = TRUE) }) -galah_config(atlas = "Australia") +quiet_config <- purrr::quietly(galah_config) +quiet_config(atlas = "Australia") +rm(quiet_config, skip_message) \ No newline at end of file diff --git a/tests/testthat/test-international-GBIF-predicates.R b/tests/testthat/test-international-GBIF-predicates.R new file mode 100644 index 00000000..99cbfaee --- /dev/null +++ b/tests/testthat/test-international-GBIF-predicates.R @@ -0,0 +1,317 @@ +quiet_config <- purrr::quietly(galah_config) + +gbif_config <- quiet_config(atlas = "GBIF", + username = "atlasoflivingaustralia", + email = "ala4r@ala.org.au", + password = "galah-gbif-test-login") + +test_that("`galah_filter()` returns predicates for GBIF", { + x <- galah_filter(year == 2024) + inherits(x, "list") |> + expect_true() + expect_equal(names(x), + c("type", "key", "value")) + expect_equal(x, + list(type = "equals", + key = "YEAR", + value = "2024") |> + structure(class = c("predicates_filter", "list"))) +}) + +test_that("`filter()` handles a single entry for GBIF", { + skip_if_offline(); skip_on_ci() + x <- galah_call() |> + filter(year == 2024) |> + count() |> + collect() + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x), 1) + expect_equal(ncol(x), 1) + expect_true(is.integer(x$count)) +}) + +test_that("`filter()` handles multiple (`AND`) queries for GBIF", { + skip_if_offline(); skip_on_ci() + # get a count limited by two different categories + x <- galah_call() |> + filter(year == 2024, basisOfRecord == "HUMAN_OBSERVATION") |> + count() |> + collect() + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x), 1) + expect_equal(ncol(x), 1) + + # group by the first category + y <- galah_call() |> + filter(year == 2024, basisOfRecord == "HUMAN_OBSERVATION") |> + group_by(basisOfRecord) |> + count() |> + collect() + expect_s3_class(y, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(y), 1) + expect_equal(ncol(y), 2) + # verify that the inputs are shown in the response + expect_equal(colnames(y)[[1]], "basisOfRecord") + expect_equal(y$basisOfRecord, "HUMAN_OBSERVATION") + + z <- galah_call() |> + filter(year == 2024, basisOfRecord == "HUMAN_OBSERVATION") |> + group_by(year) |> + count() |> + collect() + expect_s3_class(z, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(z), 1) + expect_equal(ncol(z), 2) + # verify that the inputs are shown in the response + expect_equal(colnames(z)[[1]], "year") + expect_equal(z$year, "2024") + + # test that all queries return the same sum + expect_equal(x$count, y$count) + expect_equal(x$count, z$count) +}) + +test_that("`count()` errors when real but non-indexed fields are requested", { + skip_if_offline(); skip_on_ci() + + # invalid fields + galah_call() |> + filter(something == 9) |> + count() |> + collapse() |> + expect_error() + + # real, but not indexed, group_by statement + request_data() |> + filter(class == "Mammalia") |> + group_by(order) |> + count() |> + collapse() |> + expect_error() +}) + +test_that("`count()` works with `identify()` for GBIF", { + skip_if_offline(); skip_on_ci() + # collapse + x <- request_data() |> + identify("Mammalia") |> + filter(year >= 2020, basisOfRecord == "HUMAN_OBSERVATION") |> + group_by(classKey) |> + count() |> + collect() + expect_equal(nrow(x), 1) + expect_equal(ncol(x), 2) + expect_equal(x$classKey, "359") +}) + +test_that("`filter()` handles `OR` and `%in%` for GBIF", { + skip_if_offline(); skip_on_ci() + + # first prove that these facets are collected + x <- request_data() |> + filter(basisOfRecord == "HUMAN_OBSERVATION" | basisOfRecord == "PRESERVED_SPECIMEN") |> + group_by(basisOfRecord) |> + count() |> + collect() + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x), 2) + expect_equal(ncol(x), 2) + expect_contains(x$basisOfRecord, + c("HUMAN_OBSERVATION", "PRESERVED_SPECIMEN")) + + # then check the sum against a query without `group_by()` + y <- request_data() |> + filter(basisOfRecord == "HUMAN_OBSERVATION" | basisOfRecord == "PRESERVED_SPECIMEN") |> + count() |> + collect() + expect_equal(sum(x$count), y$count) + + # check that %in% gives the same result + z <- request_data() |> + filter(basisOfRecord %in% c("HUMAN_OBSERVATION", "PRESERVED_SPECIMEN")) |> + count() |> + collect() + expect_equal(y$count, z$count) +}) + +test_that("`filter()` handles multiple queries including != for GBIF", { + skip_if_offline(); skip_on_ci() + + x <- galah_call() |> + filter(year == 2024, country != "AU") |> # FIXME: countryCode fails with cryptic warning + count() |> + collect() + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x), 1) + expect_equal(ncol(x), 1) + + # check that `!=` definitely reduces the number of records returned + y <- galah_call() |> + filter(year == 2024) |> + count() |> + collect() + expect_lt(x$count, y$count) +}) + +test_that("`filter()` handles `between()` for GBIF", { + skip_if_offline(); skip_on_ci() + + x <- galah_call() |> + filter(dplyr::between(year, 2010, 2020)) |> + group_by(year) |> + count() |> + collect() + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_equal(ncol(x), 2) + expect_gt(nrow(x), 8) + expect_lt(nrow(x), 12) + integer_years <- as.integer(x$year) + all(integer_years >= 2010 & integer_years <= 2020) |> + expect_true() +}) + +test_that("filter() handles !() for GBIF", { + skip_if_offline(); skip_on_ci() + + # exclude some levels of basisOfRecord + excluded_categories <- c("OCCURRENCE", "LIVING_SPECIMEN", "HUMAN_OBSERVATION") + x <- galah_call() |> + filter(!(basisOfRecord %in% excluded_categories)) |> + group_by(basisOfRecord) |> + count() |> + collect() + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_equal(ncol(x), 2) + expect_gt(nrow(x), 3) + + # get all levels of basisOfRecord + y <- galah_call() |> + group_by(basisOfRecord) |> + count() |> + collect() + + # check that those categories - and only those categories - are missing + missing_categories <- y$basisOfRecord[!(y$basisOfRecord %in% x$basisOfRecord)] + expect_equal(sort(excluded_categories), + sort(missing_categories)) +}) + +test_that("filter() handles `is.na()` for GBIF", { + skip_if_offline(); skip_on_ci() + + # missing values + x <- galah_call() |> + filter(is.na(country)) |> + count() |> + collect() + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x), 1) + expect_equal(ncol(x), 1) + + # present values + y <- galah_call() |> + filter(!is.na(country)) |> + count() |> + collect() + expect_s3_class(y, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(y), 1) + expect_equal(ncol(y), 1) + + # all values + z <- galah_call() |> + count() |> + collect() + expect_equal(x$count + y$count, z$count) +}) + +test_that("filter() handles c() for GBIF", { + skip_if_offline(); skip_on_ci() + + # effectively parses this as 'in' as per GBIF instructions + country_vector <- c("AU", "US", "NL") + + # check when supplied directly + x <- galah_call() |> + filter(country %in% c("AU", "US", "NL")) |> + group_by(country) |> + count() |> + collect() + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x), 3) + expect_equal(ncol(x), 2) + expect_contains(x$country, country_vector) + + # and as a vector + y <- galah_call() |> + filter(country == country_vector) |> + group_by(country) |> + count() |> + collect() + expect_s3_class(y, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(y), 3) + expect_equal(ncol(y), 2) + expect_contains(y$country, country_vector) + + # direct comparison + expect_identical(x, y) +}) + +test_that("`count()` works with `galah_polygon()` for GBIF", { + skip_if_offline(); skip_on_ci() + # errors when points given clockwise + # FIXME: This has been disableed at some point + # `st_sfc()` has a `check_ring_dir` argument that might help + # wkt <- "POLYGON((142.36 -29.01,142.74 -29.01,142.74 -29.39,142.36 -29.39,142.36 -29.01))" + # expect_error({galah_call() |> + # galah_polygon(wkt) |> + # count() |> + # collect()}) + # works when points given counter-clockwise + wkt <- "POLYGON((142.36 -29.01,142.36 -29.39,142.74 -29.39,142.74 -29.01,142.36 -29.01))" + result <- galah_call() |> + identify("Mammalia") |> + galah_polygon(wkt) |> + count() |> + collect() + # compare against a taxonomic query in the same place + result_taxa <- galah_call() |> + identify("Mammalia") |> + count() |> + collect() + # compare against a purely spatial query + result_space <- galah_call() |> + galah_polygon(wkt) |> + count() |> + collect() + expect_lt(result$count, result_taxa$count) + expect_lt(result$count, result_space$count) +}) + +test_that("`count()` works with `galah_radius()` for GBIF", { + skip_if_offline(); skip_on_ci() + # ditto for a point and radius + result <- galah_call() |> + identify("Mammalia") |> + galah_radius(lat = -33.7, + lon = 151.3, + radius = 5) |> + count() |> + collect() + result_space <- galah_call() |> + galah_radius(lat = -33.7, + lon = 151.3, + radius = 5) |> + count() |> + collect() + result_taxa <- galah_call() |> + identify("Mammalia") |> + count() |> + collect() + expect_lt(result$count, result_taxa$count) + expect_lt(result$count, result_space$count) +}) + +# TODO: add assertions? + +gbif_config <- quiet_config(atlas = "ALA") +rm(gbif_config, quiet_config) diff --git a/tests/testthat/test-international-GBIF.R b/tests/testthat/test-international-GBIF.R index 43351357..f751d684 100644 --- a/tests/testthat/test-international-GBIF.R +++ b/tests/testthat/test-international-GBIF.R @@ -9,16 +9,55 @@ test_that("swapping to atlas = GBIF works", { }) test_that("show_all(fields) works for GBIF", { - x <- request_metadata() |> collapse() + skip_if_offline(); skip_on_ci() + # first ensure underlying syntax is valid + x <- request_metadata() |> + collapse() expect_true(inherits(x, "query")) expect_true(x$type == "metadata/fields") x <- collect(x) expect_gt(nrow(x), 1) expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) + # then test 'traditional' syntax y <- show_all(fields) expect_equal(x, y) }) +test_that("search_all(fields) works for GBIF", { + skip_if_offline(); skip_on_ci() + result <- search_all(fields, "year") + expect_gte(nrow(result), 2) + result |> + inherits(c("tbl_df", "tbl", "data.frame")) |> + expect_true() + grepl("year", tolower(result$id)) |> + all() |> + expect_true() +}) + +test_that("show_values works for GBIF fields", { + skip_if_offline(); skip_on_ci() + # query syntax + x <- request_metadata() |> + filter(fields == "gbifRegion") |> + unnest() |> + collect() + # traditional syntax + quiet_values <- function(...){ + x <- purrr::quietly(show_values) + x(...)$result + } + y <- search_fields("gbifRegion") |> + quiet_values() + # tests + inherits(x, c("tbl_df", "tbl", "data.frame")) |> + expect_true() + x |> + nrow() |> + expect_gt(1) + expect_equal(x, y) +}) + test_that("show_all(collections) works for GBIF", { skip_if_offline(); skip_on_ci() x <- show_all(collections, limit = 10) @@ -84,6 +123,26 @@ test_that("search_all(taxa) works for GBIF", { expect_true(x$class == "Mammalia") }) +test_that("search_all(taxa) works using a tibble for GBIF", { + skip_if_offline(); skip_on_ci() + x <- search_all(taxa, + data.frame(kingdom = "Animalia", + phylum = "Chordata")) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_equal(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("search_all(identifiers) works for GBIF", { + skip_if_offline(); skip_on_ci() + x <- search_all(identifiers, "359") |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_equal(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + galah_config(verbose = TRUE) test_that("search_all(datasets) works for GBIF", { @@ -109,24 +168,13 @@ test_that("search_all(providers) works for GBIF", { galah_config(verbose = FALSE) -test_that("search_all(fields) works for GBIF", { - skip_if_offline(); skip_on_ci() - result <- search_all(fields, "year") - expect_equal(nrow(result), 2) - expect_true(inherits(result, c("tbl_df", "tbl", "data.frame"))) -}) - -test_that("show_values works for GBIF fields", { - skip_if_offline(); skip_on_ci() - search_fields("basisOfRecord") |> - show_values() |> - nrow() |> - expect_gt(1) -}) - test_that("atlas_counts works for GBIF", { skip_if_offline(); skip_on_ci() - expect_gt(atlas_counts()$count, 0) + galah_call() |> + count() |> + collect() |> + dplyr::pull("count") |> + expect_gt(0) }) test_that("atlas_counts fails for GBIF when type = 'species'", { @@ -135,39 +183,61 @@ test_that("atlas_counts fails for GBIF when type = 'species'", { galah_config(run_checks = TRUE) -test_that("`count()` works with `filter()` for GBIF", { +test_that("`count` works with 2 `group_by` args for GBIF", { skip_if_offline(); skip_on_ci() - # collapse - x <- request_data() |> - filter(year == 2010) |> + x <- galah_call() |> + filter(year >= 2020) |> + group_by(year, basisOfRecord) |> count() |> collapse() expect_s3_class(x, "query") - expect_equal(length(x), 5) - expect_equal(names(x), - c("type", "url", "slot_name", "expand", "headers")) - expect_equal(x$type, "data/occurrences-count") + # expect_equal(length(x), 6) # for some reason this fails on Positron?!?!?!! + expect_contains(names(x), + c("type", "url", "headers", "request")) # "options", "body" ? + expect_equal(x$type, "data/occurrences-count-groupby") # compute y <- compute(x) expect_s3_class(y, "computed_query") # collect z <- collect(y) expect_s3_class(z, c("tbl_df", "tbl", "data.frame")) - expect_gt(z$count, 1) - expect_equal(nrow(z), 1) + expect_gt(nrow(z), 1) + expect_equal(names(z), c("year", "basisOfRecord", "count")) + # in early versions, iterating by a variable wasn't working properly + # check that same level of second variable differs across first variable + z_counts <- z |> + dplyr::filter(basisOfRecord == "HUMAN_OBSERVATION") |> + dplyr::pull(count) + expect_true(max(z_counts) - min(z_counts) > 0) }) -test_that("`count` works with `identify` for GBIF", { +## group_by fails when an invalid field is given +## NOTE: fails: no checks run at present +# expect_error({ +# galah_call() |> +# identify("Crinia") |> +# group_by(species) |> +# count() |> +# collect() +# }) + +# FIXME: `slice_head()` not tested for GBIF + +test_that("`count()` works with `identify` for GBIF when `run_checks` = TRUE", { skip_if_offline(); skip_on_ci() + galah_config(run_checks = TRUE) # collapse x <- request_data() |> - identify("Mammalia") |> + identify("Litoria peronii") |> + filter(year >= 2020, + basisOfRecord == "HUMAN_OBSERVATION") |> count() |> collapse() expect_s3_class(x, "query") - expect_equal(length(x), 5) + expect_equal(length(x), 6) expect_equal(names(x), - c("type", "url", "slot_name", "expand", "headers")) + c("type", "url", "headers", + "options", "body", "request")) expect_equal(x$type, "data/occurrences-count") # compute y <- compute(x) @@ -179,94 +249,38 @@ test_that("`count` works with `identify` for GBIF", { expect_equal(nrow(z), 1) }) -test_that("`count` works with `group_by` for GBIF", { +test_that("`glimpse()` works for GBIF", { skip_if_offline(); skip_on_ci() x <- galah_call() |> - identify("Litoria") |> - filter(year >= 2020) |> - group_by(year) |> - count() |> - collapse() - expect_s3_class(x, "query") - expect_equal(length(x), 4) - expect_equal(names(x), c("type", - "url", - "expand", - "headers")) - expect_equal(x$type, "data/occurrences-count-groupby") - # compute - y <- compute(x) - expect_s3_class(y, "computed_query") - # collect - z <- collect(y) - expect_s3_class(z, c("tbl_df", "tbl", "data.frame")) - expect_gt(nrow(z), 1) - expect_equal(names(z), c("year", "count")) - # group_by fails when an invalid field is given - expect_error({ - galah_call() |> - identify("Crinia") |> - group_by(species) |> - count() |> - collect() - }) -}) - -# FIXME: GBIF grouped counts only work for n = 1 - expand this or add warning -# FIXME: `slice_head()` not tested for GBIF -# FIXME: `check_fields()` not tested for GBIF - try sending invalid fields to `filter()` - -test_that("`count()` works with `galah_polygon()` for GBIF", { - skip_if_offline(); skip_on_ci() - # errors when points given clockwise - wkt <- "POLYGON((142.36 -29.01,142.74 -29.01,142.74 -29.39,142.36 -29.39,142.36 -29.01))" - expect_error({galah_call() |> - galah_polygon(wkt) |> - count() |> - collect()}) - # works when points given counter-clockwise - wkt <- "POLYGON((142.36 -29.01,142.36 -29.39,142.74 -29.39,142.74 -29.01,142.36 -29.01))" - result <- galah_call() |> - identify("Mammalia") |> - galah_polygon(wkt) |> - count() |> - collect() - # compare against a taxonomic query in the same place - result_taxa <- galah_call() |> - identify("Mammalia") |> - count() |> - collect() - # compare against a purely spatial query - result_space <- galah_call() |> - galah_polygon(wkt) |> - count() |> + filter(year == 2025) |> + glimpse() |> collect() - expect_lt(result$count, result_taxa$count) - expect_lt(result$count, result_space$count) + expect_s3_class(x, c("occurrences_glimpse", "tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x), 3) # number of rows in the tibble + quiet_print <- purrr::quietly(print.occurrences_glimpse) + x_print <- strsplit(quiet_print(x)$output, "\n")[[1]] # print statement + expect_gt(length(x_print), 5) + stringr::str_detect(x_print, + "^\\$ (taxonConceptID|eventDate|decimalLatitude)") |> + which() |> + length() |> + expect_equal(3) }) -test_that("`count()` works with `galah_radius()` for GBIF", { +test_that("`atlas_occurrences()` works for GBIF", { skip_if_offline(); skip_on_ci() - # ditto for a point and radius - result <- galah_call() |> - identify("Mammalia") |> - galah_radius(lat = -33.7, - lon = 151.3, - radius = 5) |> - count() |> - collect() - result_space <- galah_call() |> - galah_radius(lat = -33.7, - lon = 151.3, - radius = 5) |> - count() |> - collect() - result_taxa <- galah_call() |> - identify("Mammalia") |> - count() |> + galah_config(atlas = "GBIF", + username = "atlasoflivingaustralia", + email = "ala4r@ala.org.au", + password = "galah-gbif-test-login") + x <- galah_call() |> + filter(year == 1890, + classKey == "359", + country == "AU") |> collect() - expect_lt(result$count, result_taxa$count) - expect_lt(result$count, result_space$count) + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_gt(nrow(x), 10) + expect_gt(ncol(x), 10) }) test_that("`atlas_occurrences()` works with `galah_polygon()` for GBIF", { @@ -313,9 +327,9 @@ test_that("atlas_species works for GBIF", { identify("Litoria") |> collapse() expect_s3_class(x, "query") - expect_equal(length(x), 5) + expect_equal(length(x), 6) expect_equal(names(x), - c("type", "url", "headers", "options", "body")) + c("type", "url", "headers", "options", "body", "request")) expect_equal(x$type, "data/species") y <- compute(x) expect_s3_class(y, "computed_query") @@ -338,7 +352,7 @@ test_that("atlas_media fails for GBIF", { }) }) -test_that("`collapse()` et al. work for GBIF with `type = 'occurrences'`", { +test_that("`collect()` works for GBIF with `type = 'occurrences' or 'occurrences-doi'` ", { skip_if_offline(); skip_on_ci() # collapse base_query <- request_data() |> @@ -352,7 +366,7 @@ test_that("`collapse()` et al. work for GBIF with `type = 'occurrences'`", { # NOTE: the above query should return 72 records (tested 2025-06-10) expect_s3_class(x, "query") expect_equal(names(x), - c("type", "url", "headers", "options", "body")) + c("type", "url", "headers", "options", "body", "request")) expect_equal(x$type, "data/occurrences") # compute y <- compute(x) @@ -366,6 +380,16 @@ test_that("`collapse()` et al. work for GBIF with `type = 'occurrences'`", { expect_true(inherits(z, c("tbl_df", "tbl", "data.frame"))) expect_equal(nrow(z), count$count) expect_true(!is.null(attributes(z)$doi)) + + # FIXME: need DOI search test + recent_doi <- attributes(z)$doi + a <- galah_call() |> + filter(doi == recent_doi) |> + collect() + expect_equal(a, z, ignore_attr = TRUE) + expect_equal(attributes(a)$doi, attributes(z)$doi) }) -galah_config(atlas = "Australia") +quiet_config <- purrr::quietly(galah_config) +quiet_config(atlas = "Australia") +rm(quiet_config) \ No newline at end of file diff --git a/tests/testthat/test-international-Guatemala.R b/tests/testthat/test-international-Guatemala.R index 2919fa09..b409400b 100644 --- a/tests/testthat/test-international-Guatemala.R +++ b/tests/testthat/test-international-Guatemala.R @@ -66,7 +66,7 @@ test_that("show_all(profiles) fails for Guatemala", { expect_error(show_all(profiles)) }) -test_that("show_all(lists) works for Guatemala", { +test_that("show_all(profiles) fails for Guatemala", { expect_error(show_all(profiles)) }) @@ -90,8 +90,12 @@ test_that("search_all(taxa) works for Guatemala", { test_that("show_values works for fields for Guatemala", { skip_if_offline(); skip_on_ci() + quiet_values <- function(...){ + x <- purrr::quietly(show_values) + x(...)$result + } x <- search_all(fields, "basis_of_record") |> - show_values() |> + quiet_values() |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gte(nrow(x), 1) @@ -101,7 +105,7 @@ test_that("show_values works for fields for Guatemala", { test_that("atlas_counts works for Guatemala", { skip_if_offline(); skip_on_ci() x <- atlas_counts() |> - pull(count) |> + dplyr::pull(count) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(x, 0) @@ -110,7 +114,7 @@ test_that("atlas_counts works for Guatemala", { test_that("atlas_counts works with type = 'species' for Guatemala", { skip_if_offline(); skip_on_ci() x <- atlas_counts(type = "species") |> - pull(count) |> + dplyr::pull(count) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(x, 0) @@ -186,7 +190,7 @@ test_that("atlas_occurrences works for Guatemala", { skip_if(inherits(occ_collapse, "try-error"), message = "API not available") expect_s3_class(occ_collapse, "query") expect_equal(names(occ_collapse), - c("type", "url", "headers", "filter")) + c("type", "url", "headers", "request")) occ_compute <- compute(occ_collapse) |> try(silent = TRUE) skip_if(inherits(occ_compute, "try-error"), message = "API not available") @@ -196,7 +200,7 @@ test_that("atlas_occurrences works for Guatemala", { try(silent = TRUE) skip_if(inherits(occ, "try-error"), message = "API not available") expect_gt(nrow(occ), 0) - expect_equal(ncol(occ), 8) + expect_equal(ncol(occ), 9) expect_true(inherits(occ, c("tbl_df", "tbl", "data.frame"))) }) @@ -222,11 +226,17 @@ test_that("atlas_media() works for Guatemala", { expect_equal(colnames(x)[1:2], c("media_id", "recordID")) # download a subset + quiet_media <- function(...){ + x <- purrr::quietly(collect_media) + x(...)$result + } n_downloads <- 5 - collect_media(x[seq_len(n_downloads), ]) + quiet_media(x[seq_len(n_downloads), ]) expect_equal(length(list.files("temp", pattern = ".jpg$")), n_downloads) unlink("temp", recursive = TRUE) }) -galah_config(atlas = "Australia") +quiet_config <- purrr::quietly(galah_config) +quiet_config(atlas = "Australia") +rm(quiet_config) \ No newline at end of file diff --git a/tests/testthat/test-international-Kew.R b/tests/testthat/test-international-Kew.R new file mode 100644 index 00000000..f0149d21 --- /dev/null +++ b/tests/testthat/test-international-Kew.R @@ -0,0 +1,249 @@ +# set verbose to off +galah_config(verbose = FALSE, run_checks = FALSE) + +test_that("swapping to atlas = Kew works", { + expect_message(galah_config(atlas = "Kew", + email = "ala4r@ala.org.au", + password = "galah-Kew-test-login")) +}) + +test_that("show_all(fields) works for Kew", { + skip_if_offline(); skip_on_ci() + x <- show_all(fields) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gt(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) + # also that fields match those returned by default_columns() + y <- default_columns() # internal function called by `galah_select()` + expect_true(all(y %in% x$id)) +}) + +test_that("show_all(licences) works for Kew", { + # NOTE: When tested on 2025-07-04 this API works, but contains no data + skip_if_offline(); skip_on_ci() + x <- show_all(licences) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gte(nrow(x), 0) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("show_all(collections) works for Kew", { + skip_if_offline(); skip_on_ci() + x <- show_all(collections, limit = 10) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_lte(nrow(x), 10) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("show_all(datasets) works for Kew", { + skip_if_offline(); skip_on_ci() + x <- show_all(datasets, limit = 10) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_lte(nrow(x), 10) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("show_all(providers) works for Kew", { + skip_if_offline(); skip_on_ci() + x <- show_all(providers, limit = 10) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_lte(nrow(x), 10) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("show_all(reasons) works for Kew", { + skip_if_offline(); skip_on_ci() + x <- show_all(reasons) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gt(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("show_all(assertions) works for Kew", { + skip_if_offline(); skip_on_ci() + x <- show_all(assertions) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gt(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("show_all(profiles) unavailable for Kew", { + show_all(profiles) |> + expect_error(label = "No API is available for type `metadata/profiles`") +}) + +## NOTE: When tested on 2025-07-04 this API works, but contains no data +# test_that("show_all(lists) works for Kew", { +# skip_if_offline(); skip_on_ci() +# x <- show_all(lists, limit = 10) |> +# try(silent = TRUE) +# skip_if(inherits(x, "try-error"), message = "API not available") +# expect_lte(nrow(x), 10) +# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +# }) + +test_that("search_all(fields) works for Kew", { + skip_if_offline(); skip_on_ci() + x <- search_all(fields, "year") |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gte(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("search_all(taxa) works for Kew", { + skip_if_offline(); skip_on_ci() + x <- search_all(taxa, "Acer") |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gte(nrow(x), 1) + expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("search_all(identifiers) unavailable for Kew", { + x <- search_all(identifiers, "359") |> + expect_error(label = "No API is available for type `metadata/identifiers`") +}) + +## Currently failing; API exists but doesn't return data +## Server-side problem? +# test_that("show_values works for fields for Kew", { +# skip_if_offline(); skip_on_ci() +# x <- search_all(fields, "basis_of_record") |> +# show_values() |> +# try(silent = TRUE) +# skip_if(inherits(x, "try-error"), message = "API not available") +# expect_gte(nrow(x), 1) +# expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) +# }) + +test_that("atlas_counts works for Kew", { + skip_if_offline(); skip_on_ci() + x <- atlas_counts() |> + dplyr::pull(count) |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gt(x, 0) +}) + +## Currently failing: see `show_values()` comment above +## which calls the same API +# test_that("atlas_counts works with type = 'species' for Kew", { +# skip_if_offline(); skip_on_ci() +# x <- atlas_counts(type = "species") |> +# pull(count) |> +# try(silent = TRUE) +# skip_if(inherits(x, "try-error"), message = "API not available") +# expect_gt(x, 0) +# }) + +test_that("`atlas_counts()` works with `identify()` for Kew", { + skip_if_offline(); skip_on_ci() + result <- galah_call() |> + identify("Acer") |> + count() |> + collect() |> + try(silent = TRUE) + skip_if(inherits(result, "try-error"), message = "API not available") + expect_gt(result$count, 1) + result2 <- galah_call() |> + filter(genus == "Acer") |> + count() |> + collect() |> + try(silent = TRUE) + skip_if(inherits(result2, "try-error"), message = "API not available") + expect_lt( + sqrt((result2$count - result$count)^2) / result$count, + 0.1) # i.e. <1% margin of error +}) + +## Again, facetting not functional yet +# test_that("`atlas_counts()` works with `group_by()` for Kew", { +# skip_if_offline(); skip_on_ci() +# result <- galah_call() |> +# filter(year >= 2000) |> +# group_by(basis_of_record) |> +# count() |> +# collect() |> +# try(silent = TRUE) +# skip_if(inherits(result, "try-error"), message = "API not available") +# expect_gt(nrow(result), 1) +# expect_equal(names(result), c("basis_of_record", "count")) +# }) + +test_that("`atlas_species()` works for Kew", { + skip_if_offline(); skip_on_ci() + galah_config( + atlas = "Kew", + email = "ala4r@ala.org.au", + send_email = FALSE) + spp <- galah_call() |> + identify("Pinus") |> + atlas_species() |> + try(silent = TRUE) + skip_if(inherits(spp, "try-error"), message = "API not available") + expect_gt(nrow(spp), 20) + expect_gte(ncol(spp), 10) + expect_s3_class(spp, c("tbl_df", "tbl", "data.frame")) +}) + +test_that("`atlas_occurrences()` works for Kew", { + skip_if_offline(); skip_on_ci() + galah_config( + atlas = "Kew", + email = "ala4r@ala.org.au", + download_reason_id = 10, + send_email = FALSE) + occ <- galah_call() |> + identify("Acer") |> + filter(year >= 1999) |> + select(species, year) |> + atlas_occurrences() |> + try(silent = TRUE) + skip_if(inherits(occ, "try-error"), message = "API not available") + expect_gt(nrow(occ), 0) + expect_equal(ncol(occ), 2) + expect_false(any(occ$year < 1999)) + expect_true(inherits(occ, c("tbl_df", "tbl", "data.frame"))) +}) + +test_that("`atlas_media()` works for Kew", { + skip_if_offline(); skip_on_ci() + galah_config( + atlas = "Kew", + email = "ala4r@ala.org.au", + download_reason_id = 10, + directory = "temp", + send_email = FALSE) + x <- request_data() |> + identify("Acer") |> + filter(year >= 2020) |> + atlas_media() |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_gte(nrow(x), 1) + expect_equal(colnames(x)[1:2], + c("media_id", "media_type")) + # download a subset + quiet_media <- function(...){ + x <- purrr::quietly(collect_media) + x(...)$result + } + n_downloads <- min(c(nrow(x), 5)) + quiet_media(x[seq_len(n_downloads), ]) + expect_equal(length(list.files("temp", pattern = ".jpg$")), + n_downloads) + unlink("temp", recursive = TRUE) +}) + +quiet_config <- purrr::quietly(galah_config) +quiet_config(atlas = "Australia") +rm(quiet_config) \ No newline at end of file diff --git a/tests/testthat/test-international-Portugal.R b/tests/testthat/test-international-Portugal.R index 2176d8b4..670c9c77 100644 --- a/tests/testthat/test-international-Portugal.R +++ b/tests/testthat/test-international-Portugal.R @@ -88,8 +88,12 @@ test_that("search_all(taxa) works for Portugal", { test_that("show_values works for fields for Portugal", { skip_if_offline(); skip_on_ci() + quiet_values <- function(...){ + x <- purrr::quietly(show_values) + x(...)$result + } x <- search_all(fields, "basis_of_record") |> - show_values() |> + quiet_values() |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gte(nrow(x), 1) @@ -99,7 +103,7 @@ test_that("show_values works for fields for Portugal", { test_that("atlas_counts works for Portugal", { skip_if_offline(); skip_on_ci() x <- atlas_counts() |> - pull(count) |> + dplyr::pull(count) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(x, 0) @@ -108,7 +112,7 @@ test_that("atlas_counts works for Portugal", { test_that("atlas_counts works with type = 'species' for Portugal", { skip_if_offline(); skip_on_ci() x <- atlas_counts(type = "species") |> - pull(count) |> + dplyr::pull(count) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(x, 0) @@ -166,4 +170,6 @@ test_that("atlas_occurrences returns error for Portugal", { # Note: atlas_media() should also work, in theory, but again am unable to test -galah_config(atlas = "Australia") +quiet_config <- purrr::quietly(galah_config) +quiet_config(atlas = "Australia") +rm(quiet_config) \ No newline at end of file diff --git a/tests/testthat/test-international-Spain.R b/tests/testthat/test-international-Spain.R index 6e471df7..f0cbd252 100644 --- a/tests/testthat/test-international-Spain.R +++ b/tests/testthat/test-international-Spain.R @@ -71,13 +71,33 @@ test_that("show_all(assertions) works for Spain", { expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) }) -test_that("show_all(profiles) works for Spain", { +test_that("show_all(profiles) works for Flanders", { skip_if_offline(); skip_on_ci() x <- show_all(profiles) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") - expect_gt(nrow(x), 1) + expect_gte(nrow(x), 1) expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) + + # and values + y <- request_metadata() |> + filter(profiles == x$short_name[1]) |> + unnest() |> + collect() |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gt(nrow(y), 1) + expect_true(inherits(y, c("tbl_df", "tbl", "data.frame"))) + + # and actually reduces record count + records_all <- galah_call() |> + count() |> + collect() + records_clean <- galah_call() |> + apply_profile(x$short_name[1]) |> + count() |> + collect() + expect_lt(records_clean$count, records_all$count) }) test_that("show_all(lists) works for Spain", { @@ -129,18 +149,12 @@ test_that("search_all(identifiers) works for Spain", { test_that("show_values works for fields for Spain", { skip_if_offline(); skip_on_ci() + quiet_values <- function(...){ + x <- purrr::quietly(show_values) + x(...)$result + } x <- search_all(fields, "basisOfRecord") |> - show_values() |> - try(silent = TRUE) - skip_if(inherits(x, "try-error"), message = "API not available") - expect_gte(nrow(x), 1) - expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -}) - -test_that("show_values works for profiles for Spain", { - skip_if_offline(); skip_on_ci() - x <- search_all(profiles, "LA") |> - show_values() |> + quiet_values() |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gte(nrow(x), 1) @@ -150,7 +164,7 @@ test_that("show_values works for profiles for Spain", { test_that("atlas_counts works for Spain", { skip_if_offline(); skip_on_ci() x <- atlas_counts() |> - pull(count) |> + dplyr::pull(count) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(x, 0) @@ -159,7 +173,7 @@ test_that("atlas_counts works for Spain", { test_that("atlas_counts works with type = 'species' for Spain", { skip_if_offline(); skip_on_ci() x <- atlas_counts(type = "species") |> - pull(count) |> + dplyr::pull(count) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(x, 0) @@ -203,29 +217,15 @@ test_that("atlas_counts works with group_by for Spain", { skip_if_offline(); skip_on_ci() result <- galah_call() |> filter(year >= 2000) |> - group_by(basis_of_record) |> + group_by(basisOfRecord) |> count() |> collect() |> try(silent = TRUE) skip_if(inherits(result, "try-error"), message = "API not available") expect_gt(nrow(result), 1) - expect_equal(names(result), c("basis_of_record", "count")) + expect_equal(names(result), c("basisOfRecord", "count")) }) -test_that("atlas_counts works with apply_profile for Spain", { - skip_if_offline(); skip_on_ci() - without_profile <- galah_call() |> - count() |> - collect() - with_profile <- galah_call() |> - apply_profile(LA) |> - count() |> - collect() - expect_gt(with_profile$count, 0) - expect_equal(class(without_profile), class(with_profile)) - expect_lt(with_profile$count, without_profile$count) -}) - test_that("atlas_species works for Spain", { skip_if_offline(); skip_on_ci() galah_config( @@ -233,7 +233,7 @@ test_that("atlas_species works for Spain", { email = "test@ala.org.au", send_email = FALSE) spp <- galah_call() |> - galah_identify("Carnivora") |> + identify("Carnivora") |> atlas_species() |> try(silent = TRUE) skip_if(inherits(spp, "try-error"), message = "API not available") @@ -246,15 +246,15 @@ test_that("galah_select works for Spain", { skip_if_offline(); skip_on_ci() x <- galah_select() y <- galah_select(basisOfRecord) - expect_equal(length(x), 2) + expect_equal(length(x), 3) expect_equal(x$summary, "group = basic") expect_equal(x$group, "basic") expect_true(inherits(x, c("list"))) expect_equal(length(y), 3) - expect_equal(y$summary, "basisOfRecord") + expect_equal(y$summary, "~basisOfRecord") expect_equal(y$group, character(0)) expect_true(inherits(y, c("list"))) - expect_true(inherits(y[[1]], c("quosure", "formula"))) + expect_true(inherits(y$quosure[[1]], c("quosure", "formula"))) }) test_that("atlas_occurrences works for Spain", { @@ -286,24 +286,26 @@ test_that("atlas_media() works for Spain", { send_email = FALSE) x <- request_data() |> identify("Mammalia") |> - filter(year >= 2023 - # imageIDsCount > 0 - ) |> - # count() |> - # collect() + filter(year >= 2023) |> atlas_media() |> try(silent = TRUE) - skip_if(inherits(x, "try-error"), message = "API not available") + skip_if(inherits(x, "try-error"), message = "API not available") # FIXME: failing here expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) expect_gte(nrow(x), 1) expect_equal(colnames(x)[1:2], - c("media_id", "recordID")) + c("media_id", "media_type")) # download a subset + quiet_media <- function(...){ + x <- purrr::quietly(collect_media) + x(...)$result + } n_downloads <- 5 - collect_media(x[seq_len(n_downloads), ]) + quiet_media(x[seq_len(n_downloads), ]) expect_equal(length(list.files("temp", pattern = ".jpg$")), n_downloads) unlink("temp", recursive = TRUE) }) -galah_config(atlas = "Australia") +quiet_config <- purrr::quietly(galah_config) +quiet_config(atlas = "Australia") +rm(quiet_config) \ No newline at end of file diff --git a/tests/testthat/test-international-Sweden.R b/tests/testthat/test-international-Sweden.R index b720b5e9..817590bc 100644 --- a/tests/testthat/test-international-Sweden.R +++ b/tests/testthat/test-international-Sweden.R @@ -1,11 +1,11 @@ # set verbose to off galah_config(verbose = FALSE, run_checks = FALSE) -test_that("swapping to atlas = Sweden works", { +test_that("`galah_config(atlas = Sweden)` works", { expect_message(galah_config(atlas = "Sweden")) }) -test_that("show_all(collections) works for Sweden", { +test_that("`show_all(collections)` works for Sweden", { skip_if_offline(); skip_on_ci() x <- show_all(collections, limit = 10) |> try(silent = TRUE) @@ -14,7 +14,7 @@ test_that("show_all(collections) works for Sweden", { expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) }) -test_that("show_all(datasets) works for Sweden", { +test_that("`show_all(datasets)` works for Sweden", { skip_if_offline(); skip_on_ci() x <- show_all(datasets, limit = 10) |> try(silent = TRUE) @@ -23,7 +23,7 @@ test_that("show_all(datasets) works for Sweden", { expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) }) -test_that("show_all(fields) works for Sweden", { +test_that("`show_all(fields)` works for Sweden", { skip_if_offline(); skip_on_ci() x <- show_all(fields) |> try(silent = TRUE) @@ -32,7 +32,7 @@ test_that("show_all(fields) works for Sweden", { expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) }) -test_that("show_all(licences) works for Sweden", { +test_that("`show_all(licences)` works for Sweden", { skip_if_offline(); skip_on_ci() x <- show_all(licences, limit = 10) |> try(silent = TRUE) @@ -60,12 +60,12 @@ test_that("show_all(providers) works for Sweden", { expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) }) -test_that("show_all(reasons) fails for Sweden", { +test_that("show_all(reasons) works for Sweden", { skip_if_offline(); skip_on_ci() x <- show_all(reasons) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") - expect_gte(nrow(x), 0) # no data at present + expect_gt(nrow(x), 0) expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) }) @@ -85,6 +85,26 @@ test_that("show_all(profiles) works for Sweden", { skip_if(inherits(x, "try-error"), message = "API not available") expect_gte(nrow(x), 1) expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) + + # and values + y <- request_metadata() |> + filter(profiles == x$short_name[1]) |> + unnest() |> + collect() |> + try(silent = TRUE) + skip_if(inherits(x, "try-error"), message = "API not available") + expect_gt(nrow(y), 1) + expect_true(inherits(y, c("tbl_df", "tbl", "data.frame"))) + + # and actually reduces record count + records_all <- galah_call() |> + count() |> + collect() + records_clean <- galah_call() |> + apply_profile(x$short_name[1]) |> + count() |> + collect() + expect_lt(records_clean$count, records_all$count) }) test_that("search_all(fields) works for Sweden", { @@ -138,17 +158,20 @@ test_that("`search_taxa()` works for multiple ranks in Sweden", { expect_true(all(grepl("^[[:digit:]]+$", taxa$taxon_concept_id))) }) -test_that("show_values works fields in Sweden", { +test_that("s`how_values()` works fields in Sweden", { skip_if_offline(); skip_on_ci() + quiet_values <- function(...){ + x <- purrr::quietly(show_values) + x(...)$result + } + # fields x <- search_fields("basisOfRecord") |> - show_values() |> + quiet_values() |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(nrow(x), 1) -}) -test_that("show_values works for lists in Sweden", { - skip_if_offline(); skip_on_ci() + # lists x <- try({search_all(lists, "dr156") |> show_values()}, silent = TRUE) @@ -157,20 +180,10 @@ test_that("show_values works for lists in Sweden", { expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) }) -test_that("show_values works for profiles in Sweden", { - skip_if_offline(); skip_on_ci() - x <- try({search_all(profiles, "SBDI") |> - show_values()}, - silent = TRUE) - skip_if(inherits(x, "try-error"), message = "API not available") - expect_gte(nrow(x), 1) - expect_true(inherits(x, c("tbl_df", "tbl", "data.frame"))) -}) - test_that("atlas_counts works with type = 'occurrences' for Sweden", { skip_if_offline(); skip_on_ci() x <- atlas_counts() |> - pull(count) |> + dplyr::pull(count) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(x, 0) @@ -179,7 +192,7 @@ test_that("atlas_counts works with type = 'occurrences' for Sweden", { test_that("atlas_counts works with type = 'species' for Sweden", { skip_if_offline(); skip_on_ci() x <- atlas_counts(type = "species") |> - pull(count) |> + dplyr::pull(count) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(x, 0) @@ -259,15 +272,16 @@ test_that("atlas_occurrences works for Sweden", { skip_if(inherits(occ_collapse, "try-error"), message = "API not available") expect_s3_class(occ_collapse, "query") expect_equal(names(occ_collapse), - c("type", "url", "headers", "filter")) + c("type", "url", "headers", "request")) expect_equal(occ_collapse$type, "data/occurrences") # compute occ_compute <- compute(occ_collapse) + skip_if(inherits(occ_compute, "try-error"), message = "API not available") expect_s3_class(occ_compute, "computed_query") # collect occ <- collect(occ_compute) |> try(silent = TRUE) - skip_if(inherits(occ_compute, "try-error"), message = "API not available") + skip_if(inherits(occ, "try-error"), message = "API not available") expect_s3_class(occ, c("tbl_df", "tbl", "data.frame")) expect_equal(ncol(occ), length(default_columns())) }) @@ -288,7 +302,7 @@ test_that("atlas_media() works for Sweden", { expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) expect_gte(nrow(x), 1) expect_equal(colnames(x)[1:2], - c("media_id", "recordID")) + c("media_id", "media_type")) }) test_that("collect_media() works for Sweden", { @@ -330,10 +344,16 @@ test_that("collect_media() works for Sweden", { n_downloads) unlink("temp", recursive = TRUE) # try with collect_media() - collect_media(media_meta[seq_len(n_downloads), ]) + quiet_media <- function(...){ + x <- purrr::quietly(collect_media) + x(...)$result + } + quiet_media(x[seq_len(n_downloads), ]) expect_equal(length(list.files("temp", pattern = ".jpg$")), n_downloads) unlink("temp", recursive = TRUE) }) -galah_config(atlas = "Australia") +quiet_config <- purrr::quietly(galah_config) +quiet_config(atlas = "Australia") +rm(quiet_config) \ No newline at end of file diff --git a/tests/testthat/test-international-UK.R b/tests/testthat/test-international-UK.R index 5e3783d7..b1a4a25d 100644 --- a/tests/testthat/test-international-UK.R +++ b/tests/testthat/test-international-UK.R @@ -108,16 +108,20 @@ test_that("search_taxa doesn't break with typos", { test_that("show_values works for UK", { skip_if_offline(); skip_on_ci() - x <- search_fields("basis_of_record") |> + quiet_values <- function(...){ + x <- purrr::quietly(show_values) + x(...)$result + } + + # fields + x <- search_fields("basisOfRecord") |> show_values() |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(nrow(x), 1) -}) -test_that("show_list_values works for United Kingdom", { - skip_if_offline(); skip_on_ci() - x <- search_lists("dr556") |> + # lists + x <- search_lists("dr1445") |> show_values() |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") @@ -127,7 +131,7 @@ test_that("show_list_values works for United Kingdom", { test_that("atlas_counts works with type = 'occurrences' for United Kingdom", { skip_if_offline(); skip_on_ci() x <- atlas_counts() |> - pull(count) |> + dplyr::pull(count) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(x, 0) @@ -136,13 +140,13 @@ test_that("atlas_counts works with type = 'occurrences' for United Kingdom", { test_that("atlas_counts works with type = 'species' for United Kingdom", { skip_if_offline(); skip_on_ci() x <- atlas_counts(type = "species") |> - pull(count) |> + dplyr::pull(count) |> try(silent = TRUE) skip_if(inherits(x, "try-error"), message = "API not available") expect_gt(x, 0) }) -test_that("atlas_counts works with galah_identify for United Kingdom", { +test_that("atlas_counts works with `identify()` for United Kingdom", { skip_if_offline(); skip_on_ci() result <- galah_call() |> identify("Vulpes") |> @@ -167,8 +171,8 @@ test_that("atlas_counts works with galah_identify for United Kingdom", { test_that("atlas_counts works with group_by for United Kingdom", { skip_if_offline(); skip_on_ci() result <- galah_call() |> - galah_filter(year >= 2020) |> - galah_group_by(year) |> + filter(year >= 2020) |> + group_by(year) |> atlas_counts() |> try(silent = TRUE) skip_if(inherits(result, "try-error"), message = "API not available") @@ -218,7 +222,7 @@ test_that("atlas_occurrences works for United Kingdom", { # with run checks, this gives n = 5. Without it's n = 2 expect_s3_class(occ_collapse, "query") expect_equal(names(occ_collapse), - c("type", "url", "headers", "filter")) + c("type", "url", "headers", "request")) expect_equal(occ_collapse$type, "data/occurrences") # compute # notes: @@ -256,13 +260,19 @@ test_that("atlas_media() works for UK", { expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) expect_gte(nrow(x), 1) expect_equal(colnames(x)[1:2], - c("media_id", "recordID")) + c("media_id", "media_type")) # download a subset + quiet_media <- function(...){ + x <- purrr::quietly(collect_media) + x(...)$result + } n_downloads <- 5 - collect_media(x[seq_len(n_downloads), ]) + quiet_media(x[seq_len(n_downloads), ]) expect_equal(length(list.files("temp", pattern = ".jpg$")), n_downloads) unlink("temp", recursive = TRUE) }) -galah_config(atlas = "Australia") +quiet_config <- purrr::quietly(galah_config) +quiet_config(atlas = "Australia") +rm(quiet_config) diff --git a/tests/testthat/test-masked-functions.R b/tests/testthat/test-masked-functions.R index dd794e92..32a6fc4f 100644 --- a/tests/testthat/test-masked-functions.R +++ b/tests/testthat/test-masked-functions.R @@ -14,7 +14,7 @@ test_that("`filter` works identically to piped `galah_filter`", { test_that("`select` works identically to piped `galah_select`", { result1 <- galah_call() |> select(year, group = "basic") result2 <- galah_call() |> galah_select(year, group = "basic") - expect_equal(result1, result2) + expect_equal(result1, result2, ignore_attr = TRUE) }) test_that("`group_by` works identically to piped `galah_group_by`", { diff --git a/tests/testthat/test-print.R b/tests/testthat/test-print.R new file mode 100644 index 00000000..f24c0632 --- /dev/null +++ b/tests/testthat/test-print.R @@ -0,0 +1,71 @@ +test_that("object of class `data-request` formats correctly", { + expect_snapshot(request_data()) +}) + +test_that("populated `data_request()` prints correctly", { + galah_call() |> + identify("crinia") |> + filter(year == 2025) |> + expect_snapshot() +}) + +test_that("object of class `metadata-request` formats correctly", { + request_data() |> + expect_snapshot() +}) + +test_that("object of class `metadata-request` formats correctly with `filter()", { + request_metadata() |> + filter(list == "dr650") |> + expect_snapshot() +}) + +test_that("object of class `metadata-request` formats correctly with `identify()", { + request_metadata() |> + identify("Crinia") |> + expect_snapshot() +}) + +test_that("object of class `metadata-request` formats correctly with `identify() |> unnest()", { + request_metadata() |> + identify("Crinia") |> + unnest() |> + expect_snapshot() +}) + +test_that("object of class `query` formats correctly", { + request_metadata() |> + identify("Crinia") |> + capture() |> + expect_snapshot() +}) + +test_that("object of class `computed_query` formats correctly", { + x <- request_metadata() |> + identify("Crinia") |> + capture() + class(x) <- c("computed_query", "list") + expect_snapshot(x) +}) + +test_that("object of class `query_set` formats correctly", { + # prevent earlier caching (or lack thereof) affecting the result + reset_cache() + galah_call() |> + filter(basisOfRecord == "HUMAN_OBSERVATION") |> + compound() |> + expect_snapshot() +}) + +test_that("`galah_config()` formats correctly", { + galah_config(atlas = "ALA", + directory = "something", + verbose = FALSE, + caching = TRUE, + run_checks = TRUE, + download_reason_id = 10) + galah_config() |> + expect_snapshot() + galah_config(directory = tempdir(check = TRUE)) + unlink("something", recursive = TRUE) +}) \ No newline at end of file diff --git a/tests/testthat/test-request_metadata_select.R b/tests/testthat/test-request_metadata_select.R new file mode 100644 index 00000000..8c7cd8de --- /dev/null +++ b/tests/testthat/test-request_metadata_select.R @@ -0,0 +1,255 @@ +# script to test whether `everything()` is respected (present or absent) +# in metadata requests. Caching is an important consideration here. + +purrr_collect <- purrr::quietly(collect) +quiet_collect <- function(...){ + purrr_collect(...) |> + purrr::pluck("result") +} + +check_select_structure <- function(query){ + purrr::pluck(query, "request", "select") |> + is.null() |> + expect_false() + purrr::pluck(query, !!!list("request", "select", "quosure", 1)) |> + rlang::is_quosure() |> + expect_true() + purrr::pluck(query, "request", "select", "summary") |> + is.null() |> + expect_false() +} + +test_that("`request_metadata()` works with `select()` for local APIs", { + type_list <- c("atlases", + "apis", + "ranks") + x <- purrr::map(type_list, \(a){ + + # build a query + query <- request_metadata(type = a) |> + collapse() + + # check this requests data + query |> + purrr::pluck("data") |> + is.null() |> + expect_false() + + # check `select` exists, and contains a quosure and a summary + check_select_structure(query) + + # collect result + result <- collect(query) + result |> + inherits(c("tbl_df", "tbl", "data.frame")) |> + expect_true() + result |> + nrow() |> + expect_gt(0) + + # `select()` first two columns only + first_2_cols <- colnames(result)[1:2] + result2 <- request_metadata(type = a) |> + select(tidyselect::any_of(first_2_cols)) |> + collect() + + # check has worked + expect_equal(colnames(result2), + first_2_cols) + }) +}) + +test_that("`request_metadata()` works with `select()` for remote APIs *without* default columns", { + skip_if_offline() + type_list <- c("collections", + "datasets", + "providers") + reset_cache() + + x <- purrr::map(type_list, \(a){ + + # build a query + query <- request_metadata(type = a) |> + collapse() + + # check this requests data + query |> + purrr::pluck("url") |> + is.null() |> + expect_false() + # check `select` exists, and contains a quosure and a summary + check_select_structure(query) + + # collect result + result <- collect(query) + result |> + inherits(c("tbl_df", "tbl", "data.frame")) |> + expect_true() + result |> + nrow() |> + expect_gt(0) + + # `select()` first two columns only + first_2_cols <- colnames(result)[1:2] + result2 <- request_metadata(type = a) |> + select(tidyselect::any_of(first_2_cols)) |> + collect() + + # check has worked + expect_equal(colnames(result2), + first_2_cols) + }) +}) + +test_that("`request_metadata()` works with `select()` for remote APIs *with* default columns", { + skip_if_offline(); skip_on_ci() + type_list <- c("assertions", + "fields", + "licences", + "lists", + "profiles", + "reasons") + reset_cache() + + # run in a loop to check for all types + # note `x` is captured to silence output, not because we need the results + x <- purrr::map(type_list, \(a){ + + # setup + expected_columns <- lookup_select_columns(a) + expected_n <- length(expected_columns) + + # set up a query _without_ `everything()` + query <- request_metadata(type = a) |> + collapse() + # check this requests a url + query |> + purrr::pluck("url") |> + is.null() |> + expect_false() + # check `select` exists, and contains a quosure and a summary + check_select_structure(query) + + # collect that query, and check for expected columns + result <- quiet_collect(query) + result |> + ncol() |> + expect_equal(expected_n) + result |> + colnames() |> + expect_equal(expected_columns) + + # ensure results from the API are cached + result_cached <- retrieve_cache(a) + # because `everything()` was not called, cached tibble will have more cols + # than returned tibble + expect_gt(ncol(result_cached), ncol(result)) + + # now construct a query _with_ `everything()` + query_everything <- request_metadata(type = a) |> + select(everything()) |> + collapse() + # because the full query is always cached, this should not include an API call + query_everything |> + purrr::pluck("url") |> + is.null() |> + expect_true() + result_everything <- quiet_collect(query_everything) + result_everything |> + ncol() |> + expect_gt(expected_n) + result_everything |> + colnames() |> + expect_contains(expected_columns) + result_cached <- retrieve_cache(a) + expect_equal(colnames(result_everything), + colnames(result_cached)) + expect_equal(nrow(result_everything), + nrow(result_cached)) + + # clean up + reset_cache() + return(a) # probably pointless, but neater than returning nothing + }) +}) + +test_that("`request_metdata()` works with `select()` for `type = 'taxa'`", { + skip_if_offline(); skip_on_ci() + + query <- request_metadata() |> + identify("Crinia") |> + select(everything()) |> + collapse() + # check this requests a url + query |> + purrr::pluck("url") |> + is.null() |> + expect_false() + # check `select` exists, and contains a quosure and a summary + check_select_structure(query) + # now run the query + basic_search <- search_taxa("Crinia") + everything_search <- quiet_collect(query) + expect_gt(ncol(everything_search), + ncol(basic_search)) + expect_equal(nrow(everything_search), 1) + # look for some 'unusual' columns in the result + expect_contains(colnames(everything_search), + c("lft", "rgt", "species_group", "genus_id")) +}) + +test_that("`request_metdata()` works with `select()` for complex taxa", { + skip_if_offline(); skip_on_ci() + crinia_tibble <- tibble::tibble(kingdom = "Animalia", + phylum = "Chordata", + genus = "Crinia") + query <- request_metadata() |> + identify(crinia_tibble) |> + select(everything()) |> + collapse() + # check this requests a url + query |> + purrr::pluck("url") |> + is.null() |> + expect_false() + # check `select` exists, and contains a quosure and a summary + check_select_structure(query) + # now run the query + basic_search <- search_taxa(crinia_tibble) + everything_search <- quiet_collect(query) + expect_gt(ncol(everything_search), + ncol(basic_search)) + expect_equal(nrow(everything_search), 1) + # look for some 'unusual' columns in the result + expect_contains(colnames(everything_search), + c("lft", "rgt", "species_group", "genus_id")) +}) + +test_that("`request_metdata()` works with `select()` for `type = 'identifiers'`", { + skip_if_offline(); skip_on_ci() + tcid <- search_taxa("Chordata") |> + dplyr::pull("taxon_concept_id") + query <- request_metadata() |> + filter(identifier == tcid) |> + select(everything()) |> + collapse() + # check this requests a url + query |> + purrr::pluck("url") |> + dplyr::pull("url") |> + stringr::str_detect("namematching\\/api\\/getByTaxonID") |> + expect_true() + # check `select` exists, and contains a quosure and a summary + check_select_structure(query) + # now run the query + basic_search <- search_identifiers(tcid) + everything_search <- quiet_collect(query) + expect_gt(ncol(everything_search), + ncol(basic_search)) + expect_equal(nrow(everything_search), 1) + # look for some 'unusual' columns in the result + expect_contains(colnames(everything_search), + c("success", "lft", "rgt", "kingdom_id")) +}) + +rm(purrr_collect, quiet_collect, check_select_structure) \ No newline at end of file diff --git a/tests/testthat/test-request_metadata_unnest.R b/tests/testthat/test-request_metadata_unnest.R index 798feb7c..8efc2ecc 100644 --- a/tests/testthat/test-request_metadata_unnest.R +++ b/tests/testthat/test-request_metadata_unnest.R @@ -3,76 +3,167 @@ test_that("request_metadata() |> unnest() works for type = 'fields'", { # no filter provided causes an error expect_error({request_metadata() |> unnest() |> - collapse()}) + collapse()}, + label = "Requests of type `fields-unnest` must supply `filter()`") # an incorrect filter argument errors at `collapse()` expect_error({request_metadata() |> filter(something == 10) |> unnest() |> - collapse()}) + collapse()}, + label = "Invalid `type` supplied to `unnest()`") # passing a correct `type` but not `value` errors at `collapse()`... expect_error(request_metadata() |> unnest() |> filter(field == unknown) |> - collapse()) + collapse(), + label = "Can't use fields that don't exist.") + # supplying `filter()` without unnest() works + x <- request_metadata() |> + filter(field == "basisOfRecord") |> + collect() + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x), 1) + expect_equal(x$id, "basisOfRecord") # whole thing works when... - x <- request_metadata() |> + y <- request_metadata() |> unnest() |> - filter(field == basisOfRecord) |> + filter(field == "basisOfRecord") |> + collect() + expect_s3_class(y, c("tbl_df", "tbl", "data.frame")) + expect_gte(nrow(y), 4) + expect_equal(ncol(y), 1) + expect_equal(colnames(y), "basisOfRecord") + expect_true(any(y[[1]] == "HUMAN_OBSERVATION")) +}) + +test_that("request_metadata() |> select() |> unnest() works for type = 'fields'", { + skip_if_offline(); skip_on_ci() + base_query <- request_metadata() |> + filter(field == "basisOfRecord") |> + unnest() + x <- base_query |> collect() expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) expect_gte(nrow(x), 4) expect_equal(ncol(x), 1) expect_equal(colnames(x), "basisOfRecord") expect_true(any(x[[1]] == "HUMAN_OBSERVATION")) + y <- base_query |> + select(everything()) |> + collect() + expect_gt(ncol(y), ncol(x)) + z <- base_query |> + select(label, count) |> + collect() + expect_gt(ncol(z), ncol(x)) + expect_lt(ncol(z), ncol(y)) }) test_that("request_metadata() |> unnest() works for type = 'lists'", { skip_if_offline(); skip_on_ci() + x1 <- request_metadata() |> + filter(list == "dr947") |> + collect() + expect_s3_class(x1, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x1), 1) + expect_equal(x1[[1]], "dr947") x <- request_metadata() |> - filter(list == dr947) |> + filter(list == "dr947") |> unnest() |> collapse() expect_s3_class(x, "query") expect_equal(x$type, "metadata/lists-unnest") - expect_equal(names(x), c("type", "url")) + expect_equal(names(x), + c("type", "url", "request")) y <- compute(x) expect_s3_class(y, "computed_query") z <- collect(y) expect_s3_class(z, c("tbl_df", "tbl", "data.frame")) expect_gte(nrow(z), 10) expect_gte(ncol(z), 3) + # now check `everything()` + xx <- request_metadata() |> + filter(list == "dr947") |> + unnest() |> + select(everything()) |> + collect() + expect_gt(ncol(xx), ncol(z)) }) -test_that("request_metadata() |> unnest() works for type = 'profiles'", { +test_that("`request_metadata() |> unnest()` fails for invalid profiles", { skip_if_offline(); skip_on_ci() x <- request_metadata() |> unnest() |> filter(profile == "something") - expect_error(collapse(x)) - y <- request_metadata() |> + expect_error(collapse(x), + label = "Unknown profile detected") +}) + +test_that("`request_metadata() |> unnest() |> collapse()` works for type = profiles", { + skip_if_offline(); skip_on_ci() + x1 <- request_metadata() |> + filter(profile == "ALA") |> + collect() + expect_s3_class(x1, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x1), 1) + expect_equal(x1$short_name, "ALA") + x <- request_metadata() |> + filter(profile == "ALA") |> + unnest() |> + collapse() + expect_s3_class(x, "query") + expect_equal(x$type, "metadata/profiles-unnest") + expect_equal(names(x), + c("type", "url", "request")) +}) + +test_that("request_metadata() |> unnest() works for type = 'profiles'", { + skip_if_offline(); skip_on_ci() + x <- request_metadata() |> filter(profile == "ALA") |> unnest() |> collect() - expect_s3_class(y, c("tbl_df", "tbl", "data.frame")) - expect_gte(ncol(y), 3) - expect_gte(nrow(y), 10) + expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) + expect_gte(ncol(x), 3) + expect_gte(nrow(x), 10) + # check `select()` works + y <- request_metadata() |> + filter(profile == "ALA") |> + unnest() |> + select(filter, enabled) |> + collect() + expect_equal(nrow(x), nrow(y)) + expect_equal(ncol(y), 2) + # now check `everything()` + z <- request_metadata() |> + filter(profile == "ALA") |> + unnest() |> + select(everything()) |> + collect() + expect_gt(ncol(z), ncol(x)) }) test_that("request_metadata() |> unnest() works for type = 'taxa' using `identify()`", { skip_if_offline(); skip_on_ci() + x1 <- request_metadata() |> + identify("crinia") |> + collect() + expect_s3_class(x1, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(x1), 1) + expect_equal(x1[[1]], "crinia") x <- request_metadata() |> identify("crinia") |> unnest() |> collapse() expect_s3_class(x, "query") - expect_equal(length(x), 3) - expect_equal(names(x), c("type", "url", "headers")) + expect_equal(length(x), 4) + expect_equal(names(x), c("type", "url", "headers", "request")) expect_equal(x$type, "metadata/taxa-unnest") y <- compute(x) expect_s3_class(y, "computed_query") z <- collect(y) expect_s3_class(z, c("tbl_df", "tbl", "data.frame")) - expect_gte(ncol(z), 3) + expect_equal(ncol(z), 4) expect_gte(nrow(z), 10) }) @@ -84,13 +175,42 @@ test_that("request_metadata() |> unnest() works for type = 'taxa' using `filter( unnest() |> collapse() expect_s3_class(x, "query") - expect_equal(length(x), 3) - expect_equal(names(x), c("type", "url", "headers")) + expect_equal(length(x), 4) + expect_equal(names(x), c("type", "url", "headers", "request")) expect_equal(x$type, "metadata/taxa-unnest") y <- compute(x) expect_s3_class(y, "computed_query") z <- collect(y) expect_s3_class(z, c("tbl_df", "tbl", "data.frame")) - expect_gte(ncol(z), 3) + expect_equal(ncol(z), 4) expect_gte(nrow(z), 10) }) + +test_that("`request_metadata() |> unnest() |> select()` works for type = 'taxa'", { + skip_if_offline(); skip_on_ci() + lookup <- search_taxa("Crinia")$taxon_concept_id + # request one column only + x <- request_metadata() |> + filter(taxa == lookup) |> + unnest() |> + select(name) |> + collect() + # request defaults (4 columns) + y <- request_metadata() |> + filter(taxa == lookup) |> + unnest() |> + collect() + # request all columns + z <- request_metadata() |> + filter(taxa == lookup) |> + unnest() |> + select(everything()) |> + collect() + # should all have same number of rows + expect_equal(nrow(x), nrow(y)) + expect_equal(nrow(x), nrow(z)) + # but increasing numbers of columns + expect_gt(ncol(y), ncol(x)) + expect_gt(ncol(z), ncol(x)) + # +}) diff --git a/tests/testthat/test-search_all.R b/tests/testthat/test-search_all.R index e65f0bd1..e8370c33 100644 --- a/tests/testthat/test-search_all.R +++ b/tests/testthat/test-search_all.R @@ -1,13 +1,9 @@ -# NOTE: Tests are skipped on GH Actions using `skip_on_ci()` to avoid throttling -# API -# (these are probably not built for many fast queries if output is large) - -test_that("search_all checks inputs, returns helpful error", { +test_that("`search_all()` checks inputs, returns helpful error", { skip_if_offline(); skip_on_ci() expect_error(search_all(attributes, ""), "Unrecognised metadata requested") }) -test_that("search_all returns correct output for type", { +test_that("`search_all()` returns correct output for type", { skip_if_offline(); skip_on_ci() fields <- search_all(fields, "year") reasons <- search_all(reasons, "genus") @@ -16,9 +12,9 @@ test_that("search_all returns correct output for type", { expect_s3_class(fields, c("tbl_df", "tbl", "data.frame")) expect_s3_class(reasons, c("tbl_df", "tbl", "data.frame")) expect_s3_class(profiles, c("tbl_df", "tbl", "data.frame")) - expect_equivalent(fields, search_fields("year")) - expect_equivalent(reasons, search_reasons("genus")) - expect_equivalent(profiles, search_profiles("ala")) + expect_equal(fields, search_fields("year")) + expect_equal(reasons, search_reasons("genus")) + expect_equal(profiles, search_profiles("ala")) expect_equal(attributes(fields)$call, "fields") expect_equal(attributes(reasons)$call, "reasons") expect_equal(attributes(profiles)$call, "profiles") @@ -27,13 +23,13 @@ test_that("search_all returns correct output for type", { expect_equal(ncol(profiles), 4) }) -test_that("search_all returns error when missing query", { +test_that("`search_all()` returns error when missing query", { skip_if_offline(); skip_on_ci() - expect_error(search_all(profiles), "We didn't detect a search query") + expect_error(search_all(profiles), "We didn't detect a search") expect_error(search_all(fields, blah)) }) -test_that("search_assertions returns a filtered result", { +test_that("`search_assertions()` returns a filtered result", { skip_if_offline(); skip_on_ci() all <- show_all_assertions() search <- search_assertions("INVALID") @@ -49,180 +45,225 @@ test_that("search_assertions returns a filtered result", { expect_equal(search, search2) }) -test_that("search_apis returns a filtered result", { - skip_if_offline(); skip_on_ci() - all <- show_all_apis() - search <- search_apis("image") - search2 <- search_all(apis, "image") - search_result_check <- all(grepl(pattern = "image", search$url, - ignore.case = TRUE)) - - expect_lt(nrow(search), nrow(all)) - expect_equal(attributes(search)$call, "apis") - expect_s3_class(search, c("tbl_df", "tbl", "data.frame")) - expect_true(search_result_check) - expect_equal(search, search2) +test_that("`search_apis()` returns a filtered result", { + search_string <- "image" + result <- search_all(apis, search_string) + result |> + dplyr::pull(url) |> + tolower() |> + stringr::str_detect(search_string) |> + all() |> + expect_true() + expect_equal(attributes(result)$call, "apis") + expect_s3_class(result, c("tbl_df", "tbl", "data.frame")) + # check synonymous functions call the above syntax + # this is a parsimonious way to do checking, as it reduces API calls + deparse(search_apis) |> + stringr::str_detect("search_all\\(\"apis\"") |> + any() |> + expect_true() }) -test_that("search_atlases returns a filtered result", { - skip_if_offline(); skip_on_ci() - all <- show_all_atlases() - search <- search_atlases("guat") - search2 <- search_all(atlases, "guat") - search_result_check <- all(grepl(pattern = "guat", search$region, - ignore.case = TRUE)) - - expect_lt(nrow(search), nrow(all)) - expect_equal(attributes(search)$call, "atlases") - expect_s3_class(search, c("tbl_df", "tbl", "data.frame")) - expect_true(search_result_check) - expect_equal(search, search2) +test_that("`search_atlases()` returns a filtered result", { + search_string <- "guat" + result <- search_all(atlases, search_string) + result |> + dplyr::pull(region) |> + tolower() |> + stringr::str_detect(search_string) |> + all() |> + expect_true() + expect_equal(attributes(result)$call, "atlases") + expect_s3_class(result, c("tbl_df", "tbl", "data.frame")) + # check synonymous function calls the above syntax + deparse(search_atlases) |> + stringr::str_detect("search_all\\(\"atlases\"") |> + any() |> + expect_true() }) -test_that("search_collections returns a filtered result", { +test_that("`search_collections()` returns a filtered result", { skip_if_offline(); skip_on_ci() - all <- show_all_collections() - search <- search_collections("dna") - search2 <- search_all(collections, "dna") - search_result_check <- all(grepl(pattern = "dna", search$name, - ignore.case = TRUE)) - - expect_lt(nrow(search), nrow(all)) - expect_equal(attributes(search)$call, "collections") - expect_s3_class(search, c("tbl_df", "tbl", "data.frame")) - expect_true(search_result_check) - expect_equal(search, search2) + search_string <- "dna" + result <- search_all(collections, search_string) + result |> + dplyr::pull(name) |> + tolower() |> + stringr::str_detect(search_string) |> + all() |> + expect_true() + expect_equal(attributes(result)$call, "collections") + expect_s3_class(result, c("tbl_df", "tbl", "data.frame")) + # check synonymous function calls the above syntax + deparse(search_collections) |> + stringr::str_detect("search_all\\(\"collections\"") |> + any() |> + expect_true() }) -test_that("search_datasets returns a filtered result", { +test_that("`search_datasets()` returns a filtered result", { skip_if_offline(); skip_on_ci() - all <- show_all_datasets() - search <- search_datasets("endangered") - search2 <- search_all(datasets, "endangered") - search_result_check <- all(grepl(pattern = "endangered", search$name, - ignore.case = TRUE)) - - expect_lt(nrow(search), nrow(all)) - expect_equal(attributes(search)$call, "datasets") - expect_s3_class(search, c("tbl_df", "tbl", "data.frame")) - expect_true(search_result_check) - expect_equal(search, search2) + search_string <- "endangered" + result <- search_all(datasets, search_string) + result |> + dplyr::pull(name) |> + tolower() |> + stringr::str_detect(search_string) |> + all() |> + expect_true() + expect_equal(attributes(result)$call, "datasets") + expect_s3_class(result, c("tbl_df", "tbl", "data.frame")) + # check synonymous function calls the above syntax + deparse(search_datasets) |> + stringr::str_detect("search_all\\(\"datasets\"") |> + any() |> + expect_true() }) -test_that("search_fields returns a filtered result", { +test_that("`search_fields()` returns a filtered result", { skip_if_offline(); skip_on_ci() - all <- show_all_fields() - search <- search_fields("precipitation") - search2 <- search_all(fields, "precipitation") - search_result_check <- all(grepl(pattern = "precipitation", search$description, - ignore.case = TRUE)) - - expect_lt(nrow(search), nrow(all)) - expect_equal(attributes(search)$call, "fields") - expect_s3_class(search, c("tbl_df", "tbl", "data.frame")) - expect_true(search_result_check) - expect_equal(search, search2) + search_string <- "precipitation" + result <- search_all(fields, search_string) + result |> + dplyr::pull(description) |> + tolower() |> + stringr::str_detect(search_string) |> + all() |> + expect_true() + expect_equal(attributes(result)$call, "fields") + expect_s3_class(result, c("tbl_df", "tbl", "data.frame")) + # check synonymous function calls the above syntax + deparse(search_fields) |> + stringr::str_detect("search_all\\(\"fields\"") |> + any() |> + expect_true() }) -test_that("search_fields helpful warning with blank argument", { +test_that("`search_fields()` helpful warning with blank argument", { skip_if_offline(); skip_on_ci() - expect_error(search_fields(), "We didn't detect a search query.") + expect_error(search_fields(), "We didn't detect a search") }) -test_that("search_licenses returns a filtered result", { +test_that("`search_licenses()` returns a filtered result", { skip_if_offline(); skip_on_ci() - all <- show_all_licences() - search <- search_licences("3.0") - search2 <- search_all(licences, "3.0") - search_result_check <- all(grepl(pattern = "3.0", search$acronym, - ignore.case = TRUE)) - - expect_lt(nrow(search), nrow(all)) - expect_equal(attributes(search)$call, "licences") - expect_s3_class(search, c("tbl_df", "tbl", "data.frame")) - expect_true(search_result_check) - expect_equal(search, search2) + search_string <- "3.0" + result <- search_all(licences, search_string) + result |> + dplyr::pull(acronym) |> + tolower() |> + stringr::str_detect(search_string) |> + all() |> + expect_true() + expect_equal(attributes(result)$call, "licences") + expect_s3_class(result, c("tbl_df", "tbl", "data.frame")) + # check synonymous function calls the above syntax + deparse(search_licences) |> + stringr::str_detect("search_all\\(\"licences\"") |> + any() |> + expect_true() }) -test_that("search_lists returns a filtered result", { +test_that("`search_lists()` returns a filtered result", { skip_if_offline(); skip_on_ci() - all_lists <- show_all_lists() - search1 <- search_lists("threatened") - search2 <- search_all(lists, "threatened") - # check whether search_lists is correctly detecting the target string - chr_lookup <- purrr::map(colnames(search1), is.character) |> + search_string <- "threatened" + quiet_lists_search <- purrr::quietly(search_lists) + result <- quiet_lists_search(search_string) |> + purrr::pluck("result") + # elaborate check for matching terms in any character column + chr_lookup <- purrr::map(colnames(result), + is.character) |> unlist() - chr_cols <- colnames(search1)[chr_lookup] - contains_threatened <- purrr::map(chr_cols, \(a){ - grepl(pattern = "threatened", search1[[a]], ignore.case = TRUE) + chr_cols <- colnames(result)[chr_lookup] + contains_term <- purrr::map(chr_cols, + \(a){ + result[[a]] |> + tolower() |> + stringr::str_detect("threatened") }) - search_result_check <- purrr::map( - purrr::list_transpose(contains_threatened), any) |> + purrr::map(purrr::list_transpose(contains_term), any) |> unlist() |> - all() - expect_lt(nrow(search1), nrow(all_lists)) - expect_equal(attributes(search1)$call, "lists") - expect_s3_class(search1, c("tbl_df", "tbl", "data.frame")) - expect_true(search_result_check) - expect_equal(search1, search2) + all() |> + expect_true() + expect_equal(attributes(result)$call, "lists") + expect_s3_class(result, c("tbl_df", "tbl", "data.frame")) + # check synonymous function calls the above syntax + deparse(search_lists) |> + stringr::str_detect("search_all\\(\"lists\"") |> + any() |> + expect_true() }) -test_that("search_reasons returns a filtered result", { +test_that("`search_reasons()` returns a filtered result", { skip_if_offline(); skip_on_ci() - all <- show_all_reasons() - search <- search_reasons("sci") - search2 <- search_all(reasons, "sci") - search_result_check <- all(grepl(pattern = "sci", search$name, - ignore.case = TRUE)) - - expect_lt(nrow(search), nrow(all)) - expect_equal(attributes(search)$call, "reasons") - expect_s3_class(search, c("tbl_df", "tbl", "data.frame")) - expect_true(search_result_check) - expect_equal(search, search2) + search_string <- "sci" + result <- search_all(reasons, search_string) + result |> + dplyr::pull(name) |> + tolower() |> + stringr::str_detect(search_string) |> + all() |> + expect_true() + expect_equal(attributes(result)$call, "reasons") + expect_s3_class(result, c("tbl_df", "tbl", "data.frame")) + # check synonymous function calls the above syntax + deparse(search_reasons) |> + stringr::str_detect("search_all\\(\"reasons\"") |> + any() |> + expect_true() }) -test_that("search_ranks returns a filtered result", { - skip_if_offline(); skip_on_ci() - all <- show_all_ranks() - search <- search_ranks("kingdom") - search2 <- search_all(ranks, "kingdom") - search_result_check <- all(grepl(pattern = "kingdom", search$name, - ignore.case = TRUE)) - - expect_lt(nrow(search), nrow(all)) - expect_equal(attributes(search)$call, "ranks") - expect_s3_class(search, c("tbl_df", "tbl", "data.frame")) - expect_true(search_result_check) - expect_equal(search, search2) +test_that("`search_ranks()` returns a filtered result", { + search_string <- "kingdom" + result <- search_all(ranks, search_string) + result |> + dplyr::pull(name) |> + tolower() |> + stringr::str_detect(search_string) |> + all() |> + expect_true() + expect_equal(attributes(result)$call, "ranks") + expect_s3_class(result, c("tbl_df", "tbl", "data.frame")) + # check synonymous function calls the above syntax + deparse(search_ranks) |> + stringr::str_detect("search_all\\(\"ranks\"") |> + any() |> + expect_true() }) -test_that("search_profiles returns a filtered result", { +test_that("`search_profiles()` returns a filtered result", { skip_if_offline(); skip_on_ci() - all <- show_all_profiles() - search <- search_profiles("base") - search2 <- search_all(profiles, "base") - search_result_check <- all(grepl(pattern = "base", search$description, - ignore.case = TRUE)) - - expect_lt(nrow(search), nrow(all)) - expect_equal(attributes(search)$call, "profiles") - expect_s3_class(search, c("tbl_df", "tbl", "data.frame")) - expect_true(search_result_check) - expect_equal(search, search2) + search_string <- "base" + result <- search_all(profiles, search_string) + result |> + dplyr::pull(description) |> + tolower() |> + stringr::str_detect(search_string) |> + all() |> + expect_true() + expect_equal(attributes(result)$call, "profiles") + expect_s3_class(result, c("tbl_df", "tbl", "data.frame")) + # check synonymous function calls the above syntax + deparse(search_profiles) |> + stringr::str_detect("search_all\\(\"profiles\"") |> + any() |> + expect_true() }) -test_that("search_providers returns a filtered result", { +test_that("`search_providers()` returns a filtered result", { skip_if_offline(); skip_on_ci() - all <- show_all_providers() - search <- search_providers("inaturalist") - search2 <- search_all(providers, "inaturalist") - search_result_check <- all(grepl(pattern = "inaturalist", search$name, - ignore.case = TRUE)) - - expect_lt(nrow(search), nrow(all)) - expect_equal(attributes(search)$call, "providers") - expect_s3_class(search, c("tbl_df", "tbl", "data.frame")) - expect_true(search_result_check) - expect_equal(search, search2) + search_string <- "inaturalist" + result <- search_all(providers, search_string) + result |> + dplyr::pull(name) |> + tolower() |> + stringr::str_detect(search_string) |> + all() |> + expect_true() + expect_equal(attributes(result)$call, "providers") + expect_s3_class(result, c("tbl_df", "tbl", "data.frame")) + # check synonymous function calls the above syntax + deparse(search_providers) |> + stringr::str_detect("search_all\\(\"providers\"") |> + any() |> + expect_true() }) diff --git a/tests/testthat/test-search_taxa.R b/tests/testthat/test-search_taxa.R index d73ab68a..5ff37992 100644 --- a/tests/testthat/test-search_taxa.R +++ b/tests/testthat/test-search_taxa.R @@ -1,42 +1,64 @@ -test_that("search_taxa checks inputs", { +purrr_taxa <- purrr::quietly(search_taxa) +purrr_identifiers <- purrr::quietly(search_identifiers) + +test_that("`search_taxa()` checks inputs", { expect_error(search_taxa()) }) -test_that("search_taxa works for simple queries", { +test_that("`search_taxa()` works for simple queries", { skip_if_offline(); skip_on_ci() taxa <- search_taxa("Microseris lanceolata") expect_equal(nrow(taxa), 1) }) -test_that("search_taxa works for multiple queries", { +test_that("`search_taxa()` works for multiple queries", { skip_if_offline(); skip_on_ci() taxa <- search_taxa(c("Eucalyptus", "Banksia", "Acacia")) expect_equal(nrow(taxa), 3) }) -test_that("search_taxa handles data.frame input", { +test_that("`search_taxa()` handles data.frame input", { skip_if_offline(); skip_on_ci() - taxa <- search_taxa( - data.frame(genus = c("Banksia", "Microseris"), kingdom = "Plantae")) + test_df <- data.frame(genus = c("Banksia", "Microseris"), + kingdom = "Plantae") + x <- request_metadata() |> + identify(test_df) |> + collect() + taxa <- search_taxa(test_df) + expect_true(identical(taxa, x)) expect_equal(nrow(taxa), 2) }) -test_that("search_taxa handles a mix of valid and invalid queries", { +test_that("`search_taxa()` gives a message for invalid names", { skip_if_offline(); skip_on_ci() galah_config(verbose = TRUE) - expect_message(taxa <- search_taxa(c("Eucalyptus", "Banksia", "Wattle", "wootle"))) - expect_equal(nrow(taxa), 4) + taxa <- purrr_taxa("bad_term") + taxa |> + purrr::pluck("messages") |> + stringr::str_detect("^Matched 0 of 1 taxonomic search terms") |> + any() |> + expect_true() galah_config(verbose = FALSE) }) -test_that("search_taxa gives a message for invalid names", { +test_that("`search_taxa()` handles a mix of valid and invalid queries", { skip_if_offline(); skip_on_ci() galah_config(verbose = TRUE) - expect_message(search_taxa("bad_term")) + taxa <- c("Eucalyptus", "Banksia", "Wattle", "wootle") |> + purrr_taxa() + taxa |> + purrr::pluck("messages") |> + stringr::str_detect("^Matched 3 of 4 taxonomic search terms") |> + any() |> + expect_true() + taxa |> + purrr::pluck("result") |> + nrow() |> + expect_equal(4) galah_config(verbose = FALSE) }) -test_that("search_taxa searches using multiple ranks", { +test_that("`search_taxa()` searches using multiple ranks", { skip_if_offline(); skip_on_ci() taxa <- search_taxa(data.frame(genus = "Acacia", kingdom = "Plantae")) expect_s3_class(taxa, c("tbl_df", "tbl", "data.frame")) @@ -44,19 +66,26 @@ test_that("search_taxa searches using multiple ranks", { expect_equal(nrow(taxa), 1) }) -test_that("`search_identifiers()` works via `search_all()`", { +test_that("`search_taxa()` gives an error when homonyms are returned", { skip_if_offline(); skip_on_ci() - id <- "urn:lsid:biodiversity.org.au:afd.taxon:08b9a1f0-62ae-45ca-9208-e773b00021ed" - search <- search_identifiers(id) - search2 <- search_all(identifiers, id) + expect_warning(search_taxa("ACANTHOCEPHALA")) +}) - expect_equal(attributes(search)$call, "identifiers") - expect_s3_class(search, c("tbl_df", "tbl", "data.frame")) - expect_equal(nrow(search), 1) - expect_equal(search, search2) +test_that("`search_taxa()` handles name issues", { + skip_if_offline(); skip_on_ci() + expect_warning(search_taxa("Microseris")) }) -test_that("search_identifiers searches using identifier", { +test_that("`search_taxa()` give an error when homonym is returned with other issues", { + skip_if_offline(); skip_on_ci() + expect_warning(search_taxa("Gallinago sp.")) +}) + +test_that("`search_taxa()` errors nicely when piped in `galah_call()`", { + expect_error(galah_call() |> search_taxa("perameles"), "Can't pipe `search_taxa()") +}) + +test_that("`search_identifiers()` searches using identifier", { skip_if_offline(); skip_on_ci() # check different types of id identifier <- c("urn:lsid:biodiversity.org.au:afd.taxon:08b9a1f0-62ae-45ca-9208-e773b00021ed", @@ -66,48 +95,48 @@ test_that("search_identifiers searches using identifier", { expect_equal(nrow(taxa), 3) }) -test_that("search_identifiers works when one value is missing", { +test_that("`search_identifiers()` gives a message for invalid ids", { skip_if_offline(); skip_on_ci() - # check different types of id - identifier <- c("urn:lsid:biodiversity.org.au:afd.taxon:08b9a1f0-62ae-45ca-9208-e773b00021ed", - "something") galah_config(verbose = TRUE) - expect_message({taxa <- search_identifiers(identifier)}) - expect_s3_class(taxa, c("tbl_df", "tbl", "data.frame")) - expect_equal(nrow(taxa), 2) + taxa <- purrr_identifiers("1234") + taxa |> + purrr::pluck("messages") |> + stringr::str_detect("^Matched 0 of 1 taxonomic search terms") |> + any() |> + expect_true() galah_config(verbose = FALSE) }) -test_that("search_identifiers gives a message for invalid ids", { +test_that("`search_identifiers()` works when one value is missing", { skip_if_offline(); skip_on_ci() + # check different types of id + identifier <- c("urn:lsid:biodiversity.org.au:afd.taxon:08b9a1f0-62ae-45ca-9208-e773b00021ed", + "something") galah_config(verbose = TRUE) - expect_message(search_identifiers("1234")) + taxa <- purrr_identifiers(identifier) + taxa |> + purrr::pluck("messages") |> + stringr::str_detect("^Matched 1 of 2 taxonomic search terms") |> + any() |> + expect_true() + taxa |> + purrr::pluck("result") |> + expect_s3_class(c("tbl_df", "tbl", "data.frame")) + taxa |> + purrr::pluck("result") |> + nrow() |> + expect_equal(2) galah_config(verbose = FALSE) }) -test_that("search_taxa gives an error when homonyms are returned", { - skip_if_offline(); skip_on_ci() - expect_warning(search_taxa("ACANTHOCEPHALA")) -}) - -test_that("search_taxa handles name issues", { - skip_if_offline(); skip_on_ci() - expect_warning(search_taxa("Microseris")) -}) - -test_that("search_taxa handles multiple issues", { +test_that("`search_identifiers()` works via `search_all()`", { skip_if_offline(); skip_on_ci() - expected <- c("homonym, parentChildSynonym") - result <- search_taxa("Gallinago sp.") - - expect_no_error(search_taxa("Gallinago sp.")) - expect_equal(length(result$issues), 1) - expect_equal(result$issues, expected) # NOTE: This test might be too rigid - -}) - -test_that("search_taxa errors nicely when piped in galah_call", { - expect_error(galah_call() |> search_taxa("perameles"), "Can't pipe `search_taxa()") + id <- "urn:lsid:biodiversity.org.au:afd.taxon:08b9a1f0-62ae-45ca-9208-e773b00021ed" + search <- search_identifiers(id) + search2 <- search_all(identifiers, id) + expect_s3_class(search, c("tbl_df", "tbl", "data.frame")) + expect_equal(nrow(search), 1) + expect_equal(search, search2) }) test_that("`request_metadata()` works for `type = 'taxa'`", { @@ -119,8 +148,10 @@ test_that("`request_metadata()` works for `type = 'taxa'`", { expect_equal(x$identify$search_term, "crinia") y <- collapse(x) expect_s3_class(y, "query") - expect_equal(names(y), c("type", "url", "headers")) + expect_equal(names(y), c("type", "url", "headers", "request")) z <- collect(y) expect_s3_class(z, c("tbl_df", "tbl", "data.frame")) expect_equal(nrow(z), 1) }) + +rm(purrr_taxa, purrr_identifiers) \ No newline at end of file diff --git a/tests/testthat/test-show_all.R b/tests/testthat/test-show_all.R index 366dc045..89684ce9 100644 --- a/tests/testthat/test-show_all.R +++ b/tests/testthat/test-show_all.R @@ -11,10 +11,10 @@ test_that("show_all parses ... correctly", { skip_if_offline(); skip_on_ci() fields1 <- show_all(fields) fields2 <- show_all("fields") - expect_equivalent(fields1, fields2) + expect_equal(fields1, fields2) }) -test_that("all show_all() functions return correctly with all syntax", { +test_that("all `show_all()` functions return correctly with all syntax", { skip_if_offline(); skip_on_ci() valid_types <- c("apis", "assertions", @@ -23,21 +23,38 @@ test_that("all show_all() functions return correctly with all syntax", { "datasets", "fields", "licences", - "lists", "profiles", "providers", "ranks", "reasons") - invisible(lapply(valid_types, function(a){ - syntax1 <- paste0("show_all_", a) |> do.call(args = list()) # e.g. show_all_fields() - syntax2 <- paste0("show_all(", a, ")") |> parse(text = _) |> eval() # e.g. show_all(fields) - syntax3 <- request_metadata(type = a) |> collect() - limit_test <- paste0("show_all_", a) |> do.call(args = list(limit = 3)) + invisible(purrr::map(valid_types, function(a){ + syntax1 <- paste0("show_all_", a) |> + do.call(args = list()) # e.g. show_all_fields() + limit_test <- paste0("show_all_", a) |> + do.call(args = list(limit = 3)) + syntax2 <- paste0("show_all(", a, ")") |> + parse(text = _) |> + eval() # e.g. show_all(fields) expect_s3_class(syntax1, c("tbl_df", "tbl", "data.frame")) expect_equal(attributes(syntax1)$call, a) expect_equal(attributes(syntax1)$region, "Australia") expect_equal(syntax1, syntax2) - expect_equal(syntax1, syntax3) expect_equal(nrow(limit_test), 3) })) }) + +# lists queries are noisy, so run separately +test_that("`show_all_lists()` functions work correctly", { + skip_if_offline(); skip_on_ci() + quiet_lists <- function(...){ + list_fun <- purrr::quietly(show_all_lists) + list_fun(...) |> + purrr::pluck("result") + } + syntax1 <- quiet_lists() + limit_test <- quiet_lists(limit = 3) + expect_s3_class(syntax1, c("tbl_df", "tbl", "data.frame")) + expect_equal(attributes(syntax1)$call, "lists") + expect_equal(attributes(syntax1)$region, "Australia") + expect_equal(nrow(limit_test), 3) +}) \ No newline at end of file diff --git a/tests/testthat/test-show_values.R b/tests/testthat/test-show_values.R index 88086319..710c2ab3 100644 --- a/tests/testthat/test-show_values.R +++ b/tests/testthat/test-show_values.R @@ -1,4 +1,17 @@ -test_that("show_values checks values", { +# quiet `show_values()` +purrr_values <- purrr::quietly(show_values) +quiet_values <- function(x, ...){ + purrr_values(x, ...) |> + purrr::pluck("result") +} +# quiet `search_values()` +purrr_search <- purrr::quietly(search_values) +quiet_search <- function(x, y){ + purrr_search(x, query = y) |> + purrr::pluck("result") +} + +test_that("`show_values()` checks values", { skip_if_offline(); skip_on_ci() df <- tibble::tibble(x = c(1:2), y = c("a", "b")) wrong_type_search <- search_all(reasons, "sci") @@ -7,94 +20,79 @@ test_that("show_values checks values", { expect_error(wrong_type_search |> show_values(), "Can't lookup values for metadata type `reasons`.") }) -test_that("show_values accepts search & show_all inputs from fields", { +test_that("`show_values()` accepts search & show_all inputs from fields", { skip_if_offline(); skip_on_ci() - search <- search_all(lists, "EPBC act") - filtered_show <- show_all(lists) |> - dplyr::filter(species_list_uid == "dr656") - values_search <- search |> show_values() - values_show <- filtered_show |> show_values() + values_search <- search_all(fields, "basisOfRecord") |> + quiet_values() expect_s3_class(values_search, c("tbl_df", "tbl", "data.frame")) expect_gt(nrow(values_search), 0) - expect_s3_class(values_show, c("tbl_df", "tbl", "data.frame")) - expect_gt(nrow(values_show), 0) }) -test_that("show_values accepts search & show_all inputs from profiles", { +test_that("`show_values()` accepts search & show_all inputs from profiles", { skip_if_offline(); skip_on_ci() - search <- search_all(profiles, "ALA") - filtered_show <- show_all(profiles) |> - dplyr::filter(shortName == "ALA") - values_search <- search |> show_values() - values_show <- filtered_show |> show_values() + values_search <- search_all(profiles, "ALA") |> + quiet_values() expect_s3_class(values_search, c("tbl_df", "tbl", "data.frame")) expect_gt(nrow(values_search), 0) - expect_s3_class(values_show, c("tbl_df", "tbl", "data.frame")) - expect_gt(nrow(values_show), 0) }) -test_that("show_values accepts search & show_all inputs from lists", { +test_that("`show_values()` accepts search & show_all inputs from lists", { skip_if_offline(); skip_on_ci() - search <- search_all(fields, "cl22") - filtered_show <- show_all(fields) |> - dplyr::filter(id == "year") - values_search <- search |> show_values() - values_show <- filtered_show |> show_values() + values_search <- search_all(lists, "dr650") |> + quiet_values() expect_s3_class(values_search, c("tbl_df", "tbl", "data.frame")) expect_gt(nrow(values_search), 0) - expect_s3_class(values_show, c("tbl_df", "tbl", "data.frame")) - expect_gt(nrow(values_show), 0) }) -test_that("search_values returns helpful error when missing query", { +test_that("`search_values()` returns helpful error when missing query", { skip_if_offline(); skip_on_ci() expect_error(search_values(), "Missing information for values lookup") - expect_error(search_all(fields, "cl22") |> search_values(), "didn't detect a search query") + expect_error(search_all(fields, "cl22") |> search_values(), "didn't detect a search") }) -test_that("search_values returns filtered results for fields", { +test_that("`search_values()` returns filtered results for fields", { skip_if_offline(); skip_on_ci() search <- search_all(fields, "cl22") - values_search <- search |> search_values("new") - values_show <- search |> show_values() + values_search <- search |> quiet_search("new") + values_show <- search |> quiet_values() search_result_check <- all(grepl(pattern = "new", paste(values_search[,1]), ignore.case = TRUE)) expect_s3_class(values_search, c("tbl_df", "tbl", "data.frame")) - expect_equivalent(names(values_search), names(values_show)) + expect_equal(names(values_search), names(values_show)) expect_lt(nrow(values_search), nrow(values_show)) expect_true(search_result_check) }) -test_that("search_values returns filtered results for profiles", { +test_that("`search_values()` returns filtered results for profiles", { skip_if_offline(); skip_on_ci() search <- search_all(profiles, "ALA") - values_search <- search |> search_values("kingdom") - values_show <- search |> show_values() + values_search <- search |> quiet_search("kingdom") + values_show <- search |> quiet_values() search_result_check <- all(grepl(pattern = "kingdom", paste(values_search$description), ignore.case = TRUE)) expect_s3_class(values_search, c("tbl_df", "tbl", "data.frame")) - expect_equivalent(names(values_search), names(values_show)) + expect_equal(names(values_search), names(values_show)) expect_lt(nrow(values_search), nrow(values_show)) expect_true(search_result_check) }) -test_that("search_values returns filtered results for lists", { +test_that("`search_values()` returns filtered results for lists", { skip_if_offline(); skip_on_ci() - search <- search_all(lists, "ALA") - values_search <- search |> search_values("frog") - values_show <- search |> show_values() + base_df <- search_all(lists, "dr650") + values_search <- base_df |> quiet_search("frog") + values_show <- base_df |> quiet_values() search_result_check <- all(grepl(pattern = "frog", - paste(values_search$commonName, values_search$scientificName), + paste(values_search$vernacular_name, values_search$scientific_name), ignore.case = TRUE)) expect_s3_class(values_search, c("tbl_df", "tbl", "data.frame")) - expect_equivalent(names(values_search), names(values_show)) + expect_equal(names(values_search), names(values_show)) expect_lt(nrow(values_search), nrow(values_show)) expect_true(search_result_check) }) -test_that("show_values & search_values return number of matched fields", { +test_that("`show_values()` & `search_values()` return number of matched fields", { skip_if_offline(); skip_on_ci() search1 <- search_fields("year") search2 <- search_fields("basisOfRecord") @@ -102,7 +100,7 @@ test_that("show_values & search_values return number of matched fields", { expect_message(search2 |> show_values(), "Showing values for 'basisOfRecord'") }) -test_that("search_values specifies matched field", { +test_that("`search_values()` specifies matched field", { skip_if_offline(); skip_on_ci() search1 <- search_fields("year") search2 <- search_fields("state") @@ -115,46 +113,35 @@ test_that("search_values specifies matched field", { # expect_message(search3 |> show_values(), n_fields3) }) -test_that("show_values returns unformatted names", { +test_that("`show_values()` returns unformatted names", { skip_if_offline(); skip_on_ci() - expected <- tibble(basisOfRecord = c("HUMAN_OBSERVATION", - "PRESERVED_SPECIMEN")) + expected <- tibble::tibble(basisOfRecord = c("HUMAN_OBSERVATION", + "PRESERVED_SPECIMEN")) search <- search_all(fields, "basisOfRecord") - expect_equal(search |> show_values() |> head(2L), + expect_equal(search |> quiet_values() |> head(2L), expected) }) -test_that("unnest syntax works", { - skip_if_offline(); skip_on_ci() - # fields - x <- request_metadata() |> - filter(field == "cl22") |> - unnest() |> - collect() - expect_s3_class(x, c("tbl_df", "tbl", "data.frame")) - expect_equal(colnames(x), "cl22") - expect_gte(nrow(x), 1) - # profiles - y <- request_metadata() |> - filter(profile == "ALA") |> - unnest() |> - collect() - expect_s3_class(y, c("tbl_df", "tbl", "data.frame")) - expect_gte(ncol(y), 4) - expect_gte(nrow(y), 1) -}) - -test_that("show_values all_fields = TRUE works for lists", { +test_that("`show_values()` all_fields = TRUE works for lists", { skip_if_offline(); skip_on_ci() - search <- search_all(lists, "dr650") |> - show_values(all_fields = TRUE) + # simple, fake version for testing `show_values()` + df <- tibble::tibble(species_list_uid = "dr650") + attr(df, "call") <- "lists" + show_values_query <- quiet_values(df, all_fields = TRUE) + # NOTE: above is same as following code, but much faster + # search <- search_all(lists, "dr650") |> + # show_values(all_fields = TRUE) extra_cols <- c("raw_scientificName", "status", "sourceStatus", "IUCN_equivalent_status") - - expect_s3_class(search, c("tbl_df", "tbl", "data.frame")) - expect_gt(nrow(search), 0) - expect_true(any(colnames(search) %in% extra_cols)) - expect_gt(ncol(search), 6) # adds additional columns - expect_warning(search_all(fields, "cl22") |> - show_values(all_fields = TRUE)) + expect_s3_class(show_values_query, c("tbl_df", "tbl", "data.frame")) + expect_gt(nrow(show_values_query), 0) + expect_true(any(colnames(show_values_query) %in% extra_cols)) + expect_gt(ncol(show_values_query), 6) # adds additional columns + # doesn't work for fields + x <- search_all(fields, "cl22") |> + purrr_values(all_fields = TRUE) + stringr::str_detect(x$messages, "cl22") |> + any() |> + expect_true() }) +rm(purrr_values, quiet_values, purrr_search, quiet_search) \ No newline at end of file diff --git a/tests/testthat/test-url_lookup.R b/tests/testthat/test-url_lookup.R new file mode 100644 index 00000000..36e8c277 --- /dev/null +++ b/tests/testthat/test-url_lookup.R @@ -0,0 +1,30 @@ +test_that("`url_lookup()` errors for nonsense strings", { + url_lookup("something") |> + expect_error(label = "No API is available") +}) + +test_that("`url_lookup()` returns a URL for a valid input", { + url_lookup("metadata/assertions") |> + stringr::str_detect("^https://api.ala.org.au") |> + expect_true() +}) + +test_that("`url_lookup()` parses named inputs correctly", { + url_lookup("metadata/taxa-single", + name = "Crinia") |> + stringr::str_detect("search\\?q=Crinia$") |> + expect_true() +}) + +test_that("`url_lookup()` errors for incorrect named inputs", { + url_lookup("metadata/taxa-single", + something = "Crinia") |> + expect_error() +}) + +test_that("`url_lookup()` parses multiple named inputs correctly", { + url_lookup("metadata/taxa-single", + name = c("Crinia", "Limnodynastes")) |> + length() |> + expect_equal(2) +}) diff --git a/vignettes/accessing_sensitive_data.Rmd b/vignettes/accessing_sensitive_data.Rmd new file mode 100644 index 00000000..fe12040d --- /dev/null +++ b/vignettes/accessing_sensitive_data.Rmd @@ -0,0 +1,606 @@ +--- +title: "Accessing sensitive data" +author: "Martin Westgate" +date: "2026-02-11" +output: + rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Accessing sensitive data} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + + +`galah` provides access to biodiversity information stored by GBIF and its' +partner nodes. While much of this information is shared freely and without +restriction, there are a number of cases where this is not appropriate, such +as the locations of: + + - threatened species, whose locations are protected by law in many jurisdictions + - species at risk from poachers, particularly for wildlife trade + +This leads to a problem: data that is more open helps scientists and policy-makers +understand and conserve biodiversity, but also generates threats to those +species. To balance these concerns against one another, it is common to +'obfuscate' sensitive data, which consists of providing location information +at a lower spatial resolution, making it harder to locate threatened species on +the ground. + +# How ALA handles sensitive data + +While many data providers solve this problem themselves in a range of ways - +such as by not sharing data at all, randomising some locations, or reducing +the number of decimal places of their locations - others provide high-precision +data on the understanding that it will only be made available to specific users, +and then only by written agreement. In these cases, the ALA displays the +obfuscated data publicly, but retains the original data for use for specific +purposes. Researchers can request access to the original data via the National +Framework for the Sharing of Restricted Access Species Data in Australia, more +simply known as the 'RASD framework' (https://www.rasd.org.au). + +If your access to sensitive data is approved by the provider(s) in question, +you can use 'galah' to access that sensitive data. + +# Using authentication + +You have two choices for how to call authentication in your queries. The +simplest way is to 'switch on' authentication using `galah_config()`: + + +``` r +galah_config(authenticate = TRUE) +``` + +This is straightforward, but you'll have to remember to switch +`authentication` to `FALSE` again once you're done. A safer choice is to +use the `authenticate()` function in-pipe: + + +``` r +df <- galah_call() |> + identify("Mammalia") |> + filter(year == 2025) |> + authenticate() |> + collect() +``` + +It doesn't matter where in the pipe you place `authenticate()`, as it will only +trigger your browser to open once you run `collect()`. Whichever method +you use, you'll notice a page pop up in your default browser, encouraging +you to sign in. Once you have done so, you should be redirected back to your +chosen IDE to continue working. + + +# Deciding what sensitive data to access + +In the the ALA, sensitive data are stored in bespoke fields, which have an +existing field name prefixed with `sensitive_`. They cannot be requested +directly. Instead, if you request a field that has a sensitive counterpart, both +the public and sensitive version of that field will be returned. + +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
public_fieldrestricted_field
eventIDsensitive_eventID
eventDatesensitive_eventDate
eventTimesensitive_eventTime
monthsensitive_month
daysensitive_day
localitysensitive_locality
locationRemarkssensitive_locationRemarks
decimalLatitudesensitive_decimalLatitude
decimalLongitudesensitive_decimalLongitude
footprintWKTsensitive_footprintWKT
verbatimEventDatesensitive_verbatimEventDate
verbatimLocalitysensitive_verbatimLocality
verbatimCoordinatessensitive_verbatimCoordinates
verbatimLatitudesensitive_verbatimLatitude
verbatimLongitudesensitive_verbatimLongitude
+
+ + +So to download data, we might try something like: + +``` +result <- galah_call() |> + filter(species_list_uid == "dr491") |> + collect() + +> result +# A tibble: 487 × 12 + recordID scientificName taxonConceptID decimalLatitude sensitive_decimalLat…¹ decimalLongitude + + 1 00825ab0-… Caladenia vul… https://id.bi… -37.8 NA 145. + 2 0094e7df-… Caladenia vul… https://id.bi… -37.7 NA 141. + 3 00d3a4e3-… Caladenia vul… https://id.bi… -39.6 NA 147. + 4 02305849-… Caladenia vul… https://id.bi… -38.0 NA 145. + 5 02e28dc1-… Caladenia vul… https://id.bi… -37.7 NA 145. + 6 068b4c68-… Caladenia vul… https://id.bi… -37.7 NA 141. + 7 07b5356b-… Caladenia vul… https://id.bi… -37.0 NA 143. + 8 0807fcbe-… Caladenia vul… https://id.bi… -37.9 NA 145. + 9 093df7f4-… Caladenia vul… https://id.bi… -37.9 NA 145. +10 0942b709-… Caladenia vul… https://id.bi… -38.4 NA 145. +# ℹ 477 more rows +# ℹ abbreviated name: ¹​sensitive_decimalLatitude +# ℹ 6 more variables: sensitive_decimalLongitude , eventDate , +# sensitive_eventDate , basisOfRecord , occurrenceStatus , dataResourceName +# ℹ Use `print(n = ...)` to see more rows + +> colnames(result) + [1] "recordID" "scientificName" "taxonConceptID" + [4] "decimalLatitude" "sensitive_decimalLatitude" "decimalLongitude" + [7] "sensitive_decimalLongitude" "eventDate" "sensitive_eventDate" +[10] "basisOfRecord" "occurrenceStatus" "dataResourceName" +``` diff --git a/vignettes/accessing_sensitive_data.Rmd.orig b/vignettes/accessing_sensitive_data.Rmd.orig new file mode 100644 index 00000000..2986d024 --- /dev/null +++ b/vignettes/accessing_sensitive_data.Rmd.orig @@ -0,0 +1,132 @@ +--- +title: "Accessing sensitive data" +author: "Martin Westgate" +date: "2026-02-11" +output: + rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Accessing sensitive data} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- +```{r, include = FALSE} +galah_config(atlas = "Australia", verbose = FALSE) +``` + +`galah` provides access to biodiversity information stored by GBIF and its' +partner nodes. While much of this information is shared freely and without +restriction, there are a number of cases where this is not appropriate, such +as the locations of: + + - threatened species, whose locations are protected by law in many jurisdictions + - species at risk from poachers, particularly for wildlife trade + +This leads to a problem: data that is more open helps scientists and policy-makers +understand and conserve biodiversity, but also generates threats to those +species. To balance these concerns against one another, it is common to +'obfuscate' sensitive data, which consists of providing location information +at a lower spatial resolution, making it harder to locate threatened species on +the ground. + +# How ALA handles sensitive data + +While many data providers solve this problem themselves in a range of ways - +such as by not sharing data at all, randomising some locations, or reducing +the number of decimal places of their locations - others provide high-precision +data on the understanding that it will only be made available to specific users, +and then only by written agreement. In these cases, the ALA displays the +obfuscated data publicly, but retains the original data for use for specific +purposes. Researchers can request access to the original data via the National +Framework for the Sharing of Restricted Access Species Data in Australia, more +simply known as the 'RASD framework' (https://www.rasd.org.au). + +If your access to sensitive data is approved by the provider(s) in question, +you can use 'galah' to access that sensitive data. + +# Using authentication + +You have two choices for how to call authentication in your queries. The +simplest way is to 'switch on' authentication using `galah_config()`: + +```{r, eval = FALSE} +galah_config(authenticate = TRUE) +``` + +This is straightforward, but you'll have to remember to switch +`authentication` to `FALSE` again once you're done. A safer choice is to +use the `authenticate()` function in-pipe: + +```{r, eval = FALSE} +df <- galah_call() |> + identify("Mammalia") |> + filter(year == 2025) |> + authenticate() |> + collect() +``` + +It doesn't matter where in the pipe you place `authenticate()`, as it will only +trigger your browser to open once you run `collect()`. Whichever method +you use, you'll notice a page pop up in your default browser, encouraging +you to sign in. Once you have done so, you should be redirected back to your +chosen IDE to continue working. + + +# Deciding what sensitive data to access + +In the the ALA, sensitive data are stored in bespoke fields, which have an +existing field name prefixed with `sensitive_`. They cannot be requested +directly. Instead, if you request a field that has a sensitive counterpart, both +the public and sensitive version of that field will be returned. + +```{r, echo = FALSE} +library(gt) +library(tibble) + +fields <- c("eventID", "eventDate", + "eventTime", "month", "day", + "locality", "locationRemarks", + "decimalLatitude", "decimalLongitude", + "footprintWKT", + "verbatimEventDate", "verbatimLocality", + "verbatimCoordinates", "verbatimLatitude", + "verbatimLongitude") +tibble::tibble(public_field = fields, + restricted_field = glue::glue("sensitive_{fields}")) |> + gt::gt() |> + gt::cols_align(align = "left") +``` + + +So to download data, we might try something like: + +``` +result <- galah_call() |> + filter(species_list_uid == "dr491") |> + collect() + +> result +# A tibble: 487 × 12 + recordID scientificName taxonConceptID decimalLatitude sensitive_decimalLat…¹ decimalLongitude + + 1 00825ab0-… Caladenia vul… https://id.bi… -37.8 NA 145. + 2 0094e7df-… Caladenia vul… https://id.bi… -37.7 NA 141. + 3 00d3a4e3-… Caladenia vul… https://id.bi… -39.6 NA 147. + 4 02305849-… Caladenia vul… https://id.bi… -38.0 NA 145. + 5 02e28dc1-… Caladenia vul… https://id.bi… -37.7 NA 145. + 6 068b4c68-… Caladenia vul… https://id.bi… -37.7 NA 141. + 7 07b5356b-… Caladenia vul… https://id.bi… -37.0 NA 143. + 8 0807fcbe-… Caladenia vul… https://id.bi… -37.9 NA 145. + 9 093df7f4-… Caladenia vul… https://id.bi… -37.9 NA 145. +10 0942b709-… Caladenia vul… https://id.bi… -38.4 NA 145. +# ℹ 477 more rows +# ℹ abbreviated name: ¹​sensitive_decimalLatitude +# ℹ 6 more variables: sensitive_decimalLongitude , eventDate , +# sensitive_eventDate , basisOfRecord , occurrenceStatus , dataResourceName +# ℹ Use `print(n = ...)` to see more rows + +> colnames(result) + [1] "recordID" "scientificName" "taxonConceptID" + [4] "decimalLatitude" "sensitive_decimalLatitude" "decimalLongitude" + [7] "sensitive_decimalLongitude" "eventDate" "sensitive_eventDate" +[10] "basisOfRecord" "occurrenceStatus" "dataResourceName" +``` \ No newline at end of file diff --git a/vignettes/atlas_stats.csv b/vignettes/atlas_stats.csv deleted file mode 100644 index 6eebb165..00000000 --- a/vignettes/atlas_stats.csv +++ /dev/null @@ -1,11 +0,0 @@ -"region","institution","count","n_services" -"Global","Global Biodiversity Information Facility",2457308452,11 -"United Kingdom","National Biodiversity Network",298318126,19 -"Sweden","Swedish Biodiversity Data Infrastructure",153805087,23 -"France","Portail français d'accès aux données d'observation sur les espèces",153402324,14 -"Australia","Atlas of Living Australia",146132636,24 -"Spain","GBIF Spain",59673279,24 -"Brazil","Sistemas de Informações sobre a Biodiversidade Brasileira",36509671,18 -"Portugal","GBIF Portugal",16043865,15 -"Austria","Biodiversitäts-Atlas Österreich",9173597,19 -"Guatemala","Sistema Nacional de Información sobre Diversidad Biológica de Guatemala",4225159,16 diff --git a/vignettes/atlases_plot.R b/vignettes/atlases_plot.R index 706c6559..93325796 100644 --- a/vignettes/atlases_plot.R +++ b/vignettes/atlases_plot.R @@ -4,6 +4,8 @@ library(ggfun) library(ggtext) library(dplyr) library(readr) +library(glue) +library(ggh4x) # get new copies of raw atlas data data_dir <- getwd() @@ -19,86 +21,168 @@ df <- paste0(data_dir, "/data-raw/node_config.csv") |> !is.na(type) # this happens rn because of GBIF collectory search not being properly integrated ) |> select(-functional, -url) |> - bind_rows( # add cached gbif data + bind_rows( + # add cached gbif data tibble( atlas = "Global", type = c("data/species", "metadata/fields", "metadata/assertions")), + # some atlases link directly to media rather than support an API; add those here tibble( atlas = c("Austria", "Brazil", "Guatemala", "Portugal", "Spain", "United Kingdom"), type = "files/media" - )) |> + ) + ) |> arrange(atlas, type) |> left_join( select(node_metadata, region, url), by = c("atlas" = "region") ) |> - mutate(atlas_label = paste(atlas, url, sep = "\n")) - -# clean up -df_functions <- lapply(strsplit(df$type, "/"), - function(a){ - tibble(group = a[1], type = a[2]) - }) |> - bind_rows() |> - mutate(atlas = df$atlas_label) + mutate(atlas_label = glue::glue("{atlas}
+ {gsub('^https://', '', url)}"), + api_group = case_when( + grepl("^data/occurrences", type) ~ "occurrences", + grepl("^data/species|lists", type) ~ "species", + grepl("collections|datasets|providers", type) ~ "sources", + grepl("assertions|profiles|fields|licences", type) ~ "filters", + grepl("taxa|identifiers", type) ~ "taxa", + # grepl("media", type) ~ "media", + # grepl("reasons", type) ~ "other", + .default = "other" + )) # order groups -df_functions$group <- factor( - case_match(df_functions$group, "metadata" ~ 1, "data" ~ 2, "files" ~ 3), +df$group <- factor( + case_when(grepl("^metadata/", df$type) ~ 1, + grepl("^data/", df$type) ~ 2, + grepl("^files/", df$type) ~ 3), levels = seq_len(3), - labels = c("metadata", "data", "files")) - -# add extra space to distinguish between "metadata/media" and "files/media" -df_functions$type[df_functions$type == "media" & df_functions$group == "files"] <- "media " - -# order types -count_df <- df_functions |> - group_by(type) |> - summarize(count = n()) |> - arrange(desc(count)) |> - mutate(order = seq_len(24)) + labels = c("Metadata", + "Data", + "Files")) -type_seq <- lapply(df_functions$type, function(a){ - count_df$order[which(count_df$type == a)] -}) |> unlist() +df$subgroup <- factor( + case_match(df$api_group, + "sources" ~ 1, + "taxa" ~ 2, + "filters" ~ 3, + "occurrences" ~ 4, + "species" ~ 5, + "other" ~ 6 + ), + levels = seq_len(6), + labels = c("Sources", + "Taxa", + "Filters", + "Occurrences", + "Species", + "Other")) -df_functions$type <- factor(type_seq, - levels = count_df$order, - labels = count_df$type) +df$atlas_label <- factor( + case_match(df$atlas, + "Global" ~ 1, + "Australia" ~ 2, + "Spain" ~ 3, + "Sweden" ~ 4, + "Flanders" ~ 5, + "United Kingdom" ~ 6, + "Kew" ~ 7, + "Austria" ~ 8, + "Brazil" ~ 9, + "Guatemala" ~ 10, + "Portugal" ~ 11, + "France" ~ 12 + ), + levels = seq_len(12), + labels = c( + "Global
\ngbif.org", + "Australia
\nwww.ala.org.au", + "Spain
\ngbif.es", + "Sweden
\nbiodiversitydata.se" , + "Flanders
\nnatuurdata.inbo.be", + "United Kingdom
\nnbn.org.uk", + "Kew
\ndata.kew.org", + "Austria
\nbiodiversityatlas.at", + "Brazil
\nsibbr.gov.br", + "Guatemala
\nsnib.conap.gob.gt", + "Portugal
\nwww.gbif.pt", + "France
\nopenobs.mnhn.fr" + ) +) -# order atlases in descending order of availability -count_df <- df_functions |> - group_by(atlas) |> - summarize(count = n()) -count_df$count[grepl("Global", count_df$atlas)] <- 100 # put GBIF on top -count_df$count[grepl("Australia", count_df$atlas)] <- 90 # Australia second -count_df <- count_df |> - arrange(count) |> - mutate(order = seq_len(nrow(node_metadata))) - -atlas_seq <- lapply(df_functions$atlas, function(a){ - count_df$order[which(count_df$atlas == a)] -}) |> unlist() - -df_functions$atlas <- factor(atlas_seq, - levels = count_df$order, - labels = count_df$atlas) +df$type_label <- factor( + case_match(df$type, + "metadata/providers" ~ 1, + "metadata/collections" ~ 2, + "metadata/datasets" ~ 3, + "metadata/taxa-single" ~ 4, + "metadata/taxa-unnest" ~ 5, + "metadata/taxa-multiple" ~ 6, + "metadata/identifiers" ~ 7, + "metadata/fields" ~ 8, + "metadata/fields-unnest" ~ 9, + "metadata/assertions" ~ 10, + "metadata/licences" ~ 11, + "metadata/profiles" ~ 12, + "metadata/profiles-unnest" ~ 13, + "metadata/lists" ~ 14, + "metadata/lists-unnest" ~ 15, + "metadata/media" ~ 16, + "metadata/reasons" ~ 17, + "metadata/config" ~ 18, + "data/occurrences" ~ 19, + "data/occurrences-doi" ~ 20, + "data/occurrences-count" ~ 21, + "data/occurrences-count-groupby" ~ 22, + "data/species" ~ 23, + "data/species-count" ~ 24, + "files/media" ~ 25 +), + levels = seq_len(25), + labels = c("providers", + "collections", + "datasets", + "taxa-single", + "taxa-unnest", + "taxa-multiple", + "identifiers", + "fields", + "fields-unnest", + "assertions", + "licences", + "profiles", + "profiles-unnest", + "lists", + "lists-unnest", + "media", + "reasons", + "authentication", + "occurrences", + "occurrences-doi", + "occurrences-count", + "occurrences-count-groupby", + "species", + "species-count", + "media" + )) # plot -p <- ggplot(df_functions, - aes(x = type, y = atlas, color = group)) + +p <- ggplot(df, + aes(x = type_label, y = atlas_label, color = group)) + geom_point() + - scale_x_discrete(position = "top") + - facet_grid(cols = vars(group), - scales = "free_x", - space = "free_x") + + scale_x_discrete(position = "bottom") + + scale_y_discrete(limits = rev(levels(df$atlas_label))) + + ggh4x::facet_nested(~ group + subgroup, + scales = "free_x", + space = "free_x") + scale_color_manual( values = c("#eb2d83", "grey40", "#279c9c")) + theme( axis.title = element_blank(), - axis.text.y = element_text(hjust = 0), - axis.text.x = element_text(angle = 45, - hjust = 0), + axis.text.y = element_markdown(hjust = 0, + vjust = 0.6), + axis.text.x.bottom = element_text(angle = 45, + hjust = 1, + size = 8), axis.ticks = element_blank(), panel.grid.minor.x = element_blank(), panel.grid.major.x = element_blank(), @@ -106,13 +190,37 @@ p <- ggplot(df_functions, panel.grid.major.y = element_line(color = "grey90", lineend = "round", linewidth = 7), + # panel.grid.major.y = element_blank(), panel.background = element_blank(), - strip.background = element_roundrect(fill = "#fce7f0", + strip.background = element_roundrect(color = "white", + fill = "#fce7f0", r = grid::unit(2, "mm")), + strip.text = element_text(hjust = 0, + size = 8), plot.margin = margin(2, 8, 0, 2, unit = "mm"), legend.position = "none") + +# recolor the strip elements +## code modified from https://github.com/tidyverse/ggplot2/issues/2096 +# g <- ggplot_build(p) |> +# ggplot_gtable() +# +# strip_elements <- which(grepl('strip-t', g$layout$name)) +# fills <- c("#fce7f0", "#d9dbdb", "#defafa", +# "#eb2d83", "#eb2d83", "#eb2d83", "#eb2d83", "#eb2d83", +# "grey40", "grey40", +# "#279c9c") +# ## length(fills) == length(strip_elements) +# for (i in strip_elements) { +# j <- which(grepl('rect', g$grobs[[i]]$grobs[[1]]$children)) +# g$grobs[[i]]$grobs[[1]]$children[[j]]$gp$fill <- fills[i] +# } +# grid::grid.draw(g) +# +## fails + ggsave("./man/figures/atlases_plot.png", - width = 8, - height = 5.5, + width = 8, + height = 6.0, units = "in") diff --git a/vignettes/choosing_an_atlas.Rmd b/vignettes/choosing_an_atlas.Rmd deleted file mode 100644 index c6767479..00000000 --- a/vignettes/choosing_an_atlas.Rmd +++ /dev/null @@ -1,50 +0,0 @@ ---- -title: "Choosing an atlas" -author: "Martin Westgate & Dax Kellie" -date: '2024-11-05' -output: - rmarkdown::html_vignette -vignette: > - %\VignetteIndexEntry{Choosing an atlas} - %\VignetteEngine{knitr::rmarkdown} - %\VignetteEncoding{UTF-8} -resource_files: - - '../man/figures/atlases_plot.png' ---- - -The GBIF network consists of a series of a series of 'node' organisations who -collate biodiversity data from their own countries, with GBIF acting as an -umbrella organisation to store data from all nodes. Several nodes have their -own APIs, often built from the 'living atlas' codebase developed by the ALA. -`galah` enables you to download data either from GBIF (see also `rgbif`) or -from one of 9 GBIF nodes: - - -```{r, echo = FALSE} -library(reactable) -read.csv("atlas_stats.csv") |> - reactable(defaultPageSize = 12, - columns = list(region = colDef("Region", minWidth = 50), - institution = colDef("Organisation", - minWidth = 150), - count = colDef("Number of Records", minWidth = 50, - format = colFormat(separators = TRUE)), - n_services = colDef("Number of supported APIs", minWidth = 50))) -``` - -Choosing which node to query is not entirely straightforward. Broadly -speaking, GBIF is always an easy answer, because it has information from many -countries. If you only want data from a single country, however, the nodes may -offer some advantages. Namely, GBIF nodes may support locally-specific: - - - **fields** that can be used for more efficient filtering - - **taxonomies** that reflect changes not yet adopted by the GBIF taxonomic backbone - - **services** that are not offered by GBIF such as error checking or large downloads - -Ultimately, `galah` aims to provide _access_ to as many GBIF nodes as possible; -it's up to you which node organisation's data are suitable for your needs! -We currently support the following functions and atlases: - -```{r atlas-support, echo = FALSE, out.width = "100%"} -knitr::include_graphics('../man/figures/atlases_plot.png') -``` \ No newline at end of file diff --git a/vignettes/download-data-reproducibly.Rmd b/vignettes/download-data-reproducibly.Rmd index 40e452d4..fc210145 100644 --- a/vignettes/download-data-reproducibly.Rmd +++ b/vignettes/download-data-reproducibly.Rmd @@ -62,11 +62,9 @@ In galah, you can also add a DOI to your download query. You just need to add `mint_doi = TRUE` to `atlas_occurrences()`. A unique DOI will be assigned to the resulting object once the query is run. -Please note that DOI generation and reload is currently supported only for -queries to the Atlas of Living Australia. GBIF provides a DOI with every -download, but at the time of writing, they don't provide an API to use -that DOI to download the dataset a second time. Other atlases don't support -DOIs at all (yet). +Please note that as of version 2.2.0, DOI generation and reload is currently +supported for queries to the Atlas of Living Australia and GBIF. +Other atlases don't support DOIs at all (yet). diff --git a/vignettes/download-data-reproducibly.Rmd.orig b/vignettes/download-data-reproducibly.Rmd.orig index 2cbf2024..f22f940b 100644 --- a/vignettes/download-data-reproducibly.Rmd.orig +++ b/vignettes/download-data-reproducibly.Rmd.orig @@ -62,11 +62,9 @@ In galah, you can also add a DOI to your download query. You just need to add `mint_doi = TRUE` to `atlas_occurrences()`. A unique DOI will be assigned to the resulting object once the query is run. -Please note that DOI generation and reload is currently supported only for -queries to the Atlas of Living Australia. GBIF provides a DOI with every -download, but at the time of writing, they don't provide an API to use -that DOI to download the dataset a second time. Other atlases don't support -DOIs at all (yet). +Please note that as of version 2.2.0, DOI generation and reload is currently +supported for queries to the Atlas of Living Australia and GBIF. +Other atlases don't support DOIs at all (yet). ```{r} diff --git a/vignettes/download_data.Rmd b/vignettes/download_data.Rmd deleted file mode 100644 index 65f99ceb..00000000 --- a/vignettes/download_data.Rmd +++ /dev/null @@ -1,280 +0,0 @@ ---- -title: "Download data" -author: "Martin Westgate & Dax Kellie" -date: '2024-11-19' -output: - rmarkdown::html_vignette -vignette: > - %\VignetteIndexEntry{Download data} - %\VignetteEngine{knitr::rmarkdown} - %\VignetteEncoding{UTF-8} ---- -The `atlas_` functions are used to return data from the atlas chosen using -`galah_config()`. They are: - -- `atlas_counts()` -- `atlas_occurrences()` -- `atlas_species()` -- `atlas_media()` -- `atlas_taxonomy()` - -The final `atlas_` function---`atlas_citation()`---is unusual: It does not -return any new data, but instead provides a citation for an existing dataset -(downloaded using `atlas_occurrences()`) with an associated DOI. The other -functions are described below. - -It is equally permissable to use the `type` argument of `galah_call()` -to specify the kind of data you want, and then retrieve the data using `collect()`. -Here we use the `atlas_` prefix for consistency with earlier versions of galah, -and because many `atlas_` functions sometimes include shortcuts to make life -easier. - - -# Record counts -`atlas_counts()` provides summary counts of records in the specified atlas -without needing to download all the records first. - - -``` r -galah_config(atlas = "Australia") -# Total number of records in the ALA -atlas_counts() -``` - -``` -## # A tibble: 1 × 1 -## count -## -## 1 146185520 -``` - -Group and summarise record counts by specific fields using `galah_group_by()`. - - -``` r -galah_call() |> - galah_group_by(kingdom) |> - atlas_counts() -``` - -``` -## # A tibble: 12 × 2 -## kingdom count -## -## 1 Animalia 113408280 -## 2 Plantae 27572183 -## 3 Fungi 2448600 -## 4 Chromista 1057157 -## 5 Protista 316541 -## 6 Bacteria 113480 -## 7 Archaea 4120 -## 8 Virus 2382 -## 9 Bamfordvirae 210 -## 10 Orthornavirae 138 -## 11 Viroid 104 -## 12 Shotokuvirae 41 -``` - - -# Species lists -A common use case of atlas data is to identify which species occur in a specified -region, time period, or taxonomic group. `atlas_species()` is similar to -`search_taxa()`, in that it returns taxonomic information and unique identifiers, -but differs by returning information only on species and is far more flexible by -supporting filtering. - - -``` r -species <- galah_call() |> - galah_identify("Rodentia") |> - galah_filter(stateProvince == "Northern Territory") |> - atlas_species() - -species |> head() -``` - -``` -## # A tibble: 6 × 11 -## taxon_concept_id species_name scientific_name_auth…¹ taxon_rank kingdom phylum class order family genus vernacular_name -## -## 1 https://biodive… Pseudomys d… (Gould, 1842) species Animal… Chord… Mamm… Rode… Murid… Pseu… Delicate Mouse -## 2 https://biodive… Mesembriomy… (J.E. Gray, 1843) species Animal… Chord… Mamm… Rode… Murid… Mese… Black-footed T… -## 3 https://biodive… Zyzomys arg… (Thomas, 1889) species Animal… Chord… Mamm… Rode… Murid… Zyzo… Common Rock-rat -## 4 https://biodive… Pseudomys h… (Waite, 1896) species Animal… Chord… Mamm… Rode… Murid… Pseu… Sandy Inland M… -## 5 https://biodive… Melomys bur… (Ramsay, 1887) species Animal… Chord… Mamm… Rode… Murid… Melo… Grassland Melo… -## 6 https://biodive… Notomys ale… Thomas, 1922 species Animal… Chord… Mamm… Rode… Murid… Noto… Spinifex Hoppi… -## # ℹ abbreviated name: ¹​scientific_name_authorship -``` - - -# Occurrence data -To download occurrence data you will need to specify an email in -`galah_config()` that has been registered to an account with your selected GBIF node. -See more information in the [config section](#config). - - -``` r -galah_config(email = "your_email@email.com", atlas = "Australia") -``` - -Download occurrence records for *Eolophus roseicapilla*. - - -``` r -occ <- galah_call() |> - galah_identify("Eolophus roseicapilla") |> - galah_filter( - stateProvince == "Australian Capital Territory", - year >= 2010, - profile = "ALA" - ) |> - galah_select(institutionID, group = "basic") |> - atlas_occurrences() -``` - -``` -## Retrying in 1 seconds. -## Retrying in 2 seconds. -## Retrying in 4 seconds. -``` - -``` r -occ |> head() -``` - -``` -## # A tibble: 6 × 9 -## recordID scientificName taxonConceptID decimalLatitude decimalLongitude eventDate occurrenceStatus -## -## 1 0000a928-d756-42eb… Eolophus rose… https://biodi… -35.6 149. 2017-04-19 09:11:00 PRESENT -## 2 0001bc78-d2e9-48aa… Eolophus rose… https://biodi… -35.2 149. 2019-08-13 15:13:00 PRESENT -## 3 0002064f-08ea-425b… Eolophus rose… https://biodi… -35.3 149. 2014-03-16 06:48:00 PRESENT -## 4 00022dd2-9f85-4802… Eolophus rose… https://biodi… -35.3 149. 2022-05-08 08:20:00 PRESENT -## 5 0002cc35-8d5a-4d20… Eolophus rose… https://biodi… -35.3 149. 2015-11-01 08:00:00 PRESENT -## 6 00030a8c-082f-44f0… Eolophus rose… https://biodi… -35.3 149. 2022-01-06 11:47:00 PRESENT -## # ℹ 2 more variables: dataResourceName , institutionID -``` - - -# Media metadata -In addition to text data describing individual occurrences and their attributes, -ALA stores images, sounds and videos associated with a given record. Metadata on -these records can be downloaded using `atlas_media()`. - - -``` r -media_data <- galah_call() |> - galah_identify("Eolophus roseicapilla") |> - galah_filter( - year == 2020, - cl22 == "Australian Capital Territory") |> - atlas_media() - -media_data |> head() -``` - -``` -## # A tibble: 6 × 19 -## media_id recordID scientificName taxonConceptID decimalLatitude decimalLongitude eventDate occurrenceStatus -## -## 1 ff8322d0-… 003a192… Eolophus rose… https://biodi… -35.3 149. 2020-09-12 16:11:00 PRESENT -## 2 c66fc819-… 015ee7c… Eolophus rose… https://biodi… -35.4 149. 2020-08-09 15:11:00 PRESENT -## 3 fe6d7b94-… 05e86b7… Eolophus rose… https://biodi… -35.4 149. 2020-11-13 22:29:00 PRESENT -## 4 2f4d32c0-… 063bb0f… Eolophus rose… https://biodi… -35.6 149. 2020-08-04 11:50:00 PRESENT -## 5 73407414-… 063bb0f… Eolophus rose… https://biodi… -35.6 149. 2020-08-04 11:50:00 PRESENT -## 6 89171c49-… 063bb0f… Eolophus rose… https://biodi… -35.6 149. 2020-08-04 11:50:00 PRESENT -## # ℹ 11 more variables: dataResourceName , multimedia , images , sounds , videos , -## # creator , license , mimetype , width , height , image_url -``` - -To actually download the media files to your computer, use [collect_media()]. - - -``` r -media_data |> - collect_media() -``` - -# Taxonomic trees -`atlas_taxonomy()` provides a way to build taxonomic trees from one clade down to -another using each GBIF node's internal taxonomy. Specify which taxonomic level -your tree will go down to with `galah_filter()` using the `rank` argument. - - -``` r -galah_call() |> - galah_identify("chordata") |> - galah_filter(rank == class) |> - atlas_taxonomy() -``` - -``` -## # A tibble: 19 × 4 -## name rank parent_taxon_concept_id taxon_concept_id -## -## 1 Chordata phylum https://biodivers… -## 2 Cephalochordata subphylum https://biodiversity.org.au/afd/taxa/065f1da4-53cd-40b8-a396-80fa5c74dedd https://biodivers… -## 3 Tunicata subphylum https://biodiversity.org.au/afd/taxa/065f1da4-53cd-40b8-a396-80fa5c74dedd https://biodivers… -## 4 Appendicularia class https://biodiversity.org.au/afd/taxa/1c20ed62-d918-4e42-b625-8b86d533cc51 https://biodivers… -## 5 Ascidiacea class https://biodiversity.org.au/afd/taxa/1c20ed62-d918-4e42-b625-8b86d533cc51 https://biodivers… -## 6 Thaliacea class https://biodiversity.org.au/afd/taxa/1c20ed62-d918-4e42-b625-8b86d533cc51 https://biodivers… -## 7 Vertebrata subphylum https://biodiversity.org.au/afd/taxa/065f1da4-53cd-40b8-a396-80fa5c74dedd https://biodivers… -## 8 Agnatha informal https://biodiversity.org.au/afd/taxa/5d6076b1-b7c7-487f-9d61-0fea0111cc7e https://biodivers… -## 9 Myxini informal https://biodiversity.org.au/afd/taxa/66db22c8-891d-4b16-a1a2-b66feaeaa3e0 https://biodivers… -## 10 Petromyzontida informal https://biodiversity.org.au/afd/taxa/66db22c8-891d-4b16-a1a2-b66feaeaa3e0 https://biodivers… -## 11 Gnathostomata informal https://biodiversity.org.au/afd/taxa/5d6076b1-b7c7-487f-9d61-0fea0111cc7e https://biodivers… -## 12 Amphibia class https://biodiversity.org.au/afd/taxa/ef5515fd-a0a2-4e16-b61a-0f19f8900f76 https://biodivers… -## 13 Aves class https://biodiversity.org.au/afd/taxa/ef5515fd-a0a2-4e16-b61a-0f19f8900f76 https://biodivers… -## 14 Mammalia class https://biodiversity.org.au/afd/taxa/ef5515fd-a0a2-4e16-b61a-0f19f8900f76 https://biodivers… -## 15 Reptilia class https://biodiversity.org.au/afd/taxa/ef5515fd-a0a2-4e16-b61a-0f19f8900f76 https://biodivers… -## 16 Pisces informal https://biodiversity.org.au/afd/taxa/ef5515fd-a0a2-4e16-b61a-0f19f8900f76 https://biodivers… -## 17 Actinopterygii class https://biodiversity.org.au/afd/taxa/e22efeb4-2cb5-4250-8d71-61c48bdaa051 https://biodivers… -## 18 Chondrichthyes class https://biodiversity.org.au/afd/taxa/e22efeb4-2cb5-4250-8d71-61c48bdaa051 https://biodivers… -## 19 Sarcopterygii class https://biodiversity.org.au/afd/taxa/e22efeb4-2cb5-4250-8d71-61c48bdaa051 https://biodivers… -``` - -# Configuring galah -Various aspects of the galah package can be customized. - -## Email -To download occurrence records, species lists or media, you will need to -provide an email address registered with the service that you want to use -(e.g. for the ALA you can create an account -[here](https://auth.ala.org.au/userdetails/registration/createAccount)). - -Once an email is registered, it should be stored in the config: - -``` r -galah_config(email = "myemail@gmail.com") -``` - -## Setting your directory -By default, galah stores downloads in a temporary folder, meaning that the -local files are automatically deleted when the R session is ended. This -behaviour can be altered so that downloaded files are preserved by setting the -directory to a non-temporary location. - - -``` r -galah_config(directory = "example/dir") -``` - -## Setting the download reason -ALA requires that you provide a reason when downloading occurrence data -(via the galah `atlas_occurrences()` function). `reason` is set as -"scientific research" by default, but you can change this using `galah_config()`. -See `show_all(reasons)` for valid download reasons. - - -``` r -galah_config(download_reason_id = your_reason_id) -``` - -## Debugging -If things aren't working as expected, more detail (particularly about web -requests and caching behaviour) can be obtained by setting `verbose = TRUE`. - - -``` r -galah_config(verbose = TRUE) -``` diff --git a/vignettes/download_data.Rmd.orig b/vignettes/download_data.Rmd.orig deleted file mode 100644 index e3b306ae..00000000 --- a/vignettes/download_data.Rmd.orig +++ /dev/null @@ -1,175 +0,0 @@ ---- -title: "Download data" -author: "Martin Westgate & Dax Kellie" -date: '`r Sys.Date()`' -output: - rmarkdown::html_vignette -vignette: > - %\VignetteIndexEntry{Download data} - %\VignetteEngine{knitr::rmarkdown} - %\VignetteEncoding{UTF-8} ---- -The `atlas_` functions are used to return data from the atlas chosen using -`galah_config()`. They are: - -- `atlas_counts()` -- `atlas_occurrences()` -- `atlas_species()` -- `atlas_media()` -- `atlas_taxonomy()` - -The final `atlas_` function---`atlas_citation()`---is unusual: It does not -return any new data, but instead provides a citation for an existing dataset -(downloaded using `atlas_occurrences()`) with an associated DOI. The other -functions are described below. - -It is equally permissable to use the `type` argument of `galah_call()` -to specify the kind of data you want, and then retrieve the data using `collect()`. -Here we use the `atlas_` prefix for consistency with earlier versions of galah, -and because many `atlas_` functions sometimes include shortcuts to make life -easier. - -```{r include = FALSE} -galah_config(email = "ala4r@ala.org.au", - atlas = "Australia", - caching = FALSE, - verbose = FALSE) -``` -# Record counts -`atlas_counts()` provides summary counts of records in the specified atlas -without needing to download all the records first. - -```{r, warning = FALSE} -galah_config(atlas = "Australia") -# Total number of records in the ALA -atlas_counts() -``` - -Group and summarise record counts by specific fields using `galah_group_by()`. - -```{r, warning = FALSE} -galah_call() |> - galah_group_by(kingdom) |> - atlas_counts() -``` - - -# Species lists -A common use case of atlas data is to identify which species occur in a specified -region, time period, or taxonomic group. `atlas_species()` is similar to -`search_taxa()`, in that it returns taxonomic information and unique identifiers, -but differs by returning information only on species and is far more flexible by -supporting filtering. - -```{r} -species <- galah_call() |> - galah_identify("Rodentia") |> - galah_filter(stateProvince == "Northern Territory") |> - atlas_species() - -species |> head() -``` - - -# Occurrence data -To download occurrence data you will need to specify an email in -`galah_config()` that has been registered to an account with your selected GBIF node. -See more information in the [config section](#config). - -```{r, eval = FALSE} -galah_config(email = "your_email@email.com", atlas = "Australia") -``` - -Download occurrence records for *Eolophus roseicapilla*. - -```{r} -occ <- galah_call() |> - galah_identify("Eolophus roseicapilla") |> - galah_filter( - stateProvince == "Australian Capital Territory", - year >= 2010, - profile = "ALA" - ) |> - galah_select(institutionID, group = "basic") |> - atlas_occurrences() - -occ |> head() -``` - - -# Media metadata -In addition to text data describing individual occurrences and their attributes, -ALA stores images, sounds and videos associated with a given record. Metadata on -these records can be downloaded using `atlas_media()`. - -```{r, warning=FALSE} -media_data <- galah_call() |> - galah_identify("Eolophus roseicapilla") |> - galah_filter( - year == 2020, - cl22 == "Australian Capital Territory") |> - atlas_media() - -media_data |> head() -``` - -To actually download the media files to your computer, use [collect_media()]. - -```{r, eval=FALSE} -media_data |> - collect_media() -``` - -# Taxonomic trees -`atlas_taxonomy()` provides a way to build taxonomic trees from one clade down to -another using each GBIF node's internal taxonomy. Specify which taxonomic level -your tree will go down to with `galah_filter()` using the `rank` argument. - -```{r, warning = FALSE} -galah_call() |> - galah_identify("chordata") |> - galah_filter(rank == class) |> - atlas_taxonomy() -``` - -# Configuring galah -Various aspects of the galah package can be customized. - -## Email -To download occurrence records, species lists or media, you will need to -provide an email address registered with the service that you want to use -(e.g. for the ALA you can create an account -[here](https://auth.ala.org.au/userdetails/registration/createAccount)). - -Once an email is registered, it should be stored in the config: -```{r eval=FALSE} -galah_config(email = "myemail@gmail.com") -``` - -## Setting your directory -By default, galah stores downloads in a temporary folder, meaning that the -local files are automatically deleted when the R session is ended. This -behaviour can be altered so that downloaded files are preserved by setting the -directory to a non-temporary location. - -```{r eval=FALSE} -galah_config(directory = "example/dir") -``` - -## Setting the download reason -ALA requires that you provide a reason when downloading occurrence data -(via the galah `atlas_occurrences()` function). `reason` is set as -"scientific research" by default, but you can change this using `galah_config()`. -See `show_all(reasons)` for valid download reasons. - -```{r eval=FALSE} -galah_config(download_reason_id = your_reason_id) -``` - -## Debugging -If things aren't working as expected, more detail (particularly about web -requests and caching behaviour) can be obtained by setting `verbose = TRUE`. - -```{r eval=FALSE} -galah_config(verbose = TRUE) -``` \ No newline at end of file diff --git a/vignettes/narrow_your_results.Rmd b/vignettes/narrow_your_results.Rmd deleted file mode 100644 index 9b80a5de..00000000 --- a/vignettes/narrow_your_results.Rmd +++ /dev/null @@ -1,366 +0,0 @@ ---- -title: "Narrow your results" -author: "Martin Westgate & Dax Kellie" -date: '2024-11-19' -output: html_document -editor_options: - chunk_output_type: inline -vignette: > - %\VignetteIndexEntry{Narrow your results} - %\VignetteEncoding{UTF-8} - %\VignetteEngine{knitr::rmarkdown} ---- - - - -Each occurrence record contains taxonomic information and -information about the observation itself, like its location and the date -of observation. These pieces of information are recorded and categorised into -respective **fields**. When you import data using galah, columns of the -resulting `tibble` correspond to these fields. - -Data fields are important because they provide a means to narrow and refine -queries to return only the information that you need, and no more. Consequently, -much of the architecture of galah has been designed to make narrowing as simple -as possible. For legacy reasons, there are both `dplyr`-style verbs and galah- -specific versions of these functions; but they are largely synonymous. They -include: - -- `identify()` or `galah_identify()` -- `filter()` or `galah_filter()` -- `select()` or `galah_select()` -- `group_by()` or `galah_group_by()` -- `geolocate()` or `galah_geolocate()` - -Below we discuss each of these functions in turn. - -# `search_taxa` & `identify` -Perhaps unsurprisingly, `search_taxa()` searches for taxonomic information. -`search_taxa()` uses fuzzy-matching to work a lot like the search bar on the -[Atlas of Living Australia website](https://www.ala.org.au/), -and you can use it to search for taxa by their scientific name. - -Finding your desired taxon with `search_taxa()` is an important step to using -this taxonomic information to download data. For example, to search for -reptiles, we first need to identify whether we have the correct query: - - -``` r -search_taxa("Reptilia") -``` - -``` -## # A tibble: 1 × 9 -## search_term scientific_name taxon_concept_id rank match_type kingdom phylum class issues -## -## 1 Reptilia REPTILIA https://biodiversity.org.au/afd/taxa/682e1228… class exactMatch Animal… Chord… Rept… noIss… -``` - -If we want to be more specific, we can provide a `tibble` (or `data.frame`) -providing additional taxonomic information. - - -``` r -search_taxa(tibble(genus = "Eolophus", kingdom = "Aves")) -``` - -``` -## # A tibble: 1 × 13 -## search_term scientific_name scientific_name_auth…¹ taxon_concept_id rank match_type kingdom phylum class order family -## -## 1 Eolophus_Av… Eolophus Bonaparte, 1854 https://biodive… genus exactMatch Animal… Chord… Aves Psit… Cacat… -## # ℹ abbreviated name: ¹​scientific_name_authorship -## # ℹ 2 more variables: genus , issues -``` - -Once we know that our search matches the correct taxon or taxa, we -can use `identify()` to narrow the results of our query. - -``` r -galah_call() |> - identify("Reptilia") |> - atlas_counts() -``` - -``` -## # A tibble: 1 × 1 -## count -## -## 1 1841182 -``` - -If you're using an international atlas, `search_taxa()` will automatically -switch to using the local name-matching service. For example, Portugal uses the -GBIF taxonomic backbone, but integrates seamlessly with our standard workflow. - - -``` r -galah_config(atlas = "Portugal") -``` - -``` -## Atlas selected: GBIF Portugal (GBIF.pt) [Portugal] -``` - -``` r -galah_call() |> - identify("Lepus") |> - group_by(species) |> - atlas_counts() -``` - -``` -## # A tibble: 5 × 2 -## species count -## -## 1 Lepus granatensis 1378 -## 2 Lepus microtis 64 -## 3 Lepus europaeus 10 -## 4 Lepus saxatilis 2 -## 5 Lepus capensis 1 -``` - -Conversely, the UK's [National Biodiversity Network](https://nbn.org.uk) (NBN), -has its own taxonomic backbone, but is supported using the same function call. - - -``` r -galah_config(atlas = "United Kingdom") -``` - -``` -## Atlas selected: National Biodiversity Network (NBN) [United Kingdom] -``` - -``` r -galah_call() |> - filter(genus == "Bufo") |> - group_by(species) |> - atlas_counts() -``` - -``` -## # A tibble: 3 × 2 -## species count -## -## 1 Bufo bufo 77009 -## 2 Bufo spinosus 143 -## 3 Bufo marinus 1 -``` - -# filter -Perhaps the most important function in galah is `filter()`, which is used -to filter the rows of queries. - - -``` r -galah_config(atlas = "Australia") -``` - -``` -## Atlas selected: Atlas of Living Australia (ALA) [Australia] -``` - -``` r -# Get total record count since 2000 -galah_call() |> - filter(year > 2000) |> - atlas_counts() -``` - -``` -## # A tibble: 1 × 1 -## count -## -## 1 104768572 -``` - -``` r -# Get total record count for iNaturalist in 2021 -galah_call() |> - filter( - year > 2000, - dataResourceName == "iNaturalist Australia") |> - atlas_counts() -``` - -``` -## # A tibble: 1 × 1 -## count -## -## 1 8085678 -``` - -To find available fields and corresponding valid values, use the field lookup -functions `show_all(fields)`, `search_all(fields)` & `show_values()`. - -`galah_filter()` can also be used to make more complex taxonomic -queries than are possible using `search_taxa()`. By using the `taxonConceptID` -field, it is possible to build queries that exclude certain taxa, for example. -This can be useful to filter for paraphyletic concepts such as invertebrates. - - -``` r -galah_call() |> - filter( - taxonConceptID == search_taxa("Animalia")$taxon_concept_id, - taxonConceptID != search_taxa("Chordata")$taxon_concept_id - ) |> - group_by(class) |> - atlas_counts() -``` - -``` -## # A tibble: 70 × 2 -## class count -## -## 1 Insecta 6636702 -## 2 Gastropoda 1079236 -## 3 Arachnida 880799 -## 4 Maxillopoda 701466 -## 5 Malacostraca 667094 -## 6 Polychaeta 278997 -## 7 Bivalvia 238787 -## 8 Anthozoa 228733 -## 9 Cephalopoda 150198 -## 10 Demospongiae 119207 -## # ℹ 60 more rows -``` - -In addition to single filters, some atlases (currently Australia, Sweden & -Spain) also support 'data profiles'. These are effectively pre-formed sets of -filters that are designed to remove records that are suspect in some way. This -feature has its' own function, `apply_profile()`: - - -``` r -galah_call() |> - filter(year > 2000) |> - apply_profile(ALA) |> - atlas_counts() -``` - -``` -## # A tibble: 1 × 1 -## count -## -## 1 91982400 -``` - -To see a full list of data profiles, use `show_all(profiles)`. - -# group_by -Use `group_by()` to group and summarise record counts by specified fields. - - -``` r -# Get record counts since 2010, grouped by year and basis of record -galah_call() |> - filter(year > 2015 & year <= 2020) |> - group_by(year, basisOfRecord) |> - atlas_counts() -``` - -``` -## # A tibble: 35 × 3 -## year basisOfRecord count -## -## 1 2020 HUMAN_OBSERVATION 6859463 -## 2 2020 OCCURRENCE 188090 -## 3 2020 PRESERVED_SPECIMEN 87730 -## 4 2020 MACHINE_OBSERVATION 39642 -## 5 2020 OBSERVATION 4417 -## 6 2020 MATERIAL_SAMPLE 2104 -## 7 2020 LIVING_SPECIMEN 62 -## 8 2019 HUMAN_OBSERVATION 6104069 -## 9 2019 PRESERVED_SPECIMEN 166446 -## 10 2019 OCCURRENCE 93853 -## # ℹ 25 more rows -``` - -# select -Use `select()` to choose which columns are returned when downloading records. - - - - -``` r -Return columns 'kingdom', 'eventDate' & `species` only -occurrences <- galah_call() |> - identify("reptilia") |> - filter(year == 1930) |> - select(kingdom, species, eventDate) |> - atlas_occurrences() - -occurrences |> head() -``` - -``` -## # A tibble: 6 × 3 -## kingdom species eventDate -## -## 1 Animalia Drysdalia coronoides 1930-06-16 00:00:00 -## 2 Animalia Antaresia maculosa 1930-01-01 00:00:00 -## 3 Animalia NA 1930-04-23 00:00:00 -## 4 Animalia Stegonotus australis 1930-01-01 00:00:00 -## 5 Animalia Oxyuranus scutellatus 1930-01-01 00:00:00 -## 6 Animalia Lerista wilkinsi 1930-01-01 00:00:00 -``` - -You can also use other `{dplyr}` functions that work *within* `dplyr::select()`. - - -``` r -occurrences <- galah_call() |> - identify("reptilia") |> - filter(year == 1930) |> - select(starts_with("accepted") | ends_with("record")) |> - atlas_occurrences() -``` - -``` -## Retrying in 1 seconds. -``` - -``` r -occurrences |> head() -``` - -``` -## # A tibble: 6 × 6 -## acceptedNameUsage acceptedNameUsageID basisOfRecord raw_basisOfRecord OCCURRENCE_STATUS_INFE…¹ userDuplicateRecord -## -## 1 NA HUMAN_OBSERVATION HumanObservation FALSE FALSE -## 2 NA PRESERVED_SPECIMEN PreservedSpecimen FALSE FALSE -## 3 NA PRESERVED_SPECIMEN PreservedSpecimen FALSE FALSE -## 4 NA HUMAN_OBSERVATION HumanObservation FALSE FALSE -## 5 NA PRESERVED_SPECIMEN PreservedSpecimen FALSE FALSE -## 6 NA PRESERVED_SPECIMEN PreservedSpecimen FALSE FALSE -## # ℹ abbreviated name: ¹​OCCURRENCE_STATUS_INFERRED_FROM_BASIS_OF_RECORD -``` - -# geolocate -Use `geolocate()` to specify a geographic area or region to limit your search. - - -``` r -# Get list of perameles species in area specified: -# (Note: This can also be specified by a shapefile) -wkt <- "POLYGON((131.36328125 -22.506468769126,135.23046875 -23.396716654542,134.17578125 -27.287832521411,127.40820312499 -26.661206402316,128.111328125 -21.037340349154,131.36328125 -22.506468769126))" - -galah_call() |> - identify("perameles") |> - geolocate(wkt) |> - atlas_species() -``` - -``` -## # A tibble: 1 × 11 -## taxon_concept_id species_name scientific_name_auth…¹ taxon_rank kingdom phylum class order family genus vernacular_name -## -## 1 https://biodive… Perameles e… Spencer, 1897 species Animal… Chord… Mamm… Pera… Peram… Pera… Desert Bandico… -## # ℹ abbreviated name: ¹​scientific_name_authorship -``` - -`geolocate()` also accepts shapefiles. More complex shapefiles may need to -be simplified first (e.g., using [`rmapshaper::ms_simplify()`](https://andyteucher.ca/rmapshaper/reference/ms_simplify.html)) diff --git a/vignettes/narrow_your_results.Rmd.orig b/vignettes/narrow_your_results.Rmd.orig deleted file mode 100644 index 018e47cf..00000000 --- a/vignettes/narrow_your_results.Rmd.orig +++ /dev/null @@ -1,208 +0,0 @@ ---- -title: "Narrow your results" -author: "Martin Westgate & Dax Kellie" -date: '`r Sys.Date()`' -output: html_document -editor_options: - chunk_output_type: inline -vignette: > - %\VignetteIndexEntry{Narrow your results} - %\VignetteEncoding{UTF-8} - %\VignetteEngine{knitr::rmarkdown} ---- - -```{r, include = FALSE} -galah_config(atlas = "Australia", verbose = FALSE) -``` - -Each occurrence record contains taxonomic information and -information about the observation itself, like its location and the date -of observation. These pieces of information are recorded and categorised into -respective **fields**. When you import data using galah, columns of the -resulting `tibble` correspond to these fields. - -Data fields are important because they provide a means to narrow and refine -queries to return only the information that you need, and no more. Consequently, -much of the architecture of galah has been designed to make narrowing as simple -as possible. For legacy reasons, there are both `dplyr`-style verbs and galah- -specific versions of these functions; but they are largely synonymous. They -include: - -- `identify()` or `galah_identify()` -- `filter()` or `galah_filter()` -- `select()` or `galah_select()` -- `group_by()` or `galah_group_by()` -- `geolocate()` or `galah_geolocate()` - -Below we discuss each of these functions in turn. - -# `search_taxa` & `identify` -Perhaps unsurprisingly, `search_taxa()` searches for taxonomic information. -`search_taxa()` uses fuzzy-matching to work a lot like the search bar on the -[Atlas of Living Australia website](https://www.ala.org.au/), -and you can use it to search for taxa by their scientific name. - -Finding your desired taxon with `search_taxa()` is an important step to using -this taxonomic information to download data. For example, to search for -reptiles, we first need to identify whether we have the correct query: - -```{r} -search_taxa("Reptilia") -``` - -If we want to be more specific, we can provide a `tibble` (or `data.frame`) -providing additional taxonomic information. - -```{r} -search_taxa(tibble(genus = "Eolophus", kingdom = "Aves")) -``` - -Once we know that our search matches the correct taxon or taxa, we -can use `identify()` to narrow the results of our query. -```{r} -galah_call() |> - identify("Reptilia") |> - atlas_counts() -``` - -If you're using an international atlas, `search_taxa()` will automatically -switch to using the local name-matching service. For example, Portugal uses the -GBIF taxonomic backbone, but integrates seamlessly with our standard workflow. - -```{r} -galah_config(atlas = "Portugal") - -galah_call() |> - identify("Lepus") |> - group_by(species) |> - atlas_counts() -``` - -Conversely, the UK's [National Biodiversity Network](https://nbn.org.uk) (NBN), -has its own taxonomic backbone, but is supported using the same function call. - -```{r} -galah_config(atlas = "United Kingdom") - -galah_call() |> - filter(genus == "Bufo") |> - group_by(species) |> - atlas_counts() -``` - -# filter -Perhaps the most important function in galah is `filter()`, which is used -to filter the rows of queries. - -```{r} -galah_config(atlas = "Australia") - -# Get total record count since 2000 -galah_call() |> - filter(year > 2000) |> - atlas_counts() - - -# Get total record count for iNaturalist in 2021 -galah_call() |> - filter( - year > 2000, - dataResourceName == "iNaturalist Australia") |> - atlas_counts() -``` - -To find available fields and corresponding valid values, use the field lookup -functions `show_all(fields)`, `search_all(fields)` & `show_values()`. - -`galah_filter()` can also be used to make more complex taxonomic -queries than are possible using `search_taxa()`. By using the `taxonConceptID` -field, it is possible to build queries that exclude certain taxa, for example. -This can be useful to filter for paraphyletic concepts such as invertebrates. - -```{r invert-filter} -galah_call() |> - filter( - taxonConceptID == search_taxa("Animalia")$taxon_concept_id, - taxonConceptID != search_taxa("Chordata")$taxon_concept_id - ) |> - group_by(class) |> - atlas_counts() -``` - -In addition to single filters, some atlases (currently Australia, Sweden & -Spain) also support 'data profiles'. These are effectively pre-formed sets of -filters that are designed to remove records that are suspect in some way. This -feature has its' own function, `apply_profile()`: - -```{r} -galah_call() |> - filter(year > 2000) |> - apply_profile(ALA) |> - atlas_counts() -``` - -To see a full list of data profiles, use `show_all(profiles)`. - -# group_by -Use `group_by()` to group and summarise record counts by specified fields. - -```{r} -# Get record counts since 2010, grouped by year and basis of record -galah_call() |> - filter(year > 2015 & year <= 2020) |> - group_by(year, basisOfRecord) |> - atlas_counts() -``` - -# select -Use `select()` to choose which columns are returned when downloading records. - -```{r include = FALSE} -galah_config(email = "ala4r@ala.org.au", - atlas = "Australia", - caching = FALSE, - verbose = FALSE) -galah_config(download_reason_id = "testing") -# fixme: bug preventing this section executing in a single call -# `download_reason_id = testing` is only valid _after_ atlas has been reset -``` - -```{r} -Return columns 'kingdom', 'eventDate' & `species` only -occurrences <- galah_call() |> - identify("reptilia") |> - filter(year == 1930) |> - select(kingdom, species, eventDate) |> - atlas_occurrences() - -occurrences |> head() -``` - -You can also use other `{dplyr}` functions that work *within* `dplyr::select()`. - -```{r} -occurrences <- galah_call() |> - identify("reptilia") |> - filter(year == 1930) |> - select(starts_with("accepted") | ends_with("record")) |> - atlas_occurrences() - -occurrences |> head() -``` - -# geolocate -Use `geolocate()` to specify a geographic area or region to limit your search. - -```{r} -# Get list of perameles species in area specified: -# (Note: This can also be specified by a shapefile) -wkt <- "POLYGON((131.36328125 -22.506468769126,135.23046875 -23.396716654542,134.17578125 -27.287832521411,127.40820312499 -26.661206402316,128.111328125 -21.037340349154,131.36328125 -22.506468769126))" - -galah_call() |> - identify("perameles") |> - geolocate(wkt) |> - atlas_species() -``` - -`geolocate()` also accepts shapefiles. More complex shapefiles may need to -be simplified first (e.g., using [`rmapshaper::ms_simplify()`](https://andyteucher.ca/rmapshaper/reference/ms_simplify.html)) \ No newline at end of file diff --git a/vignettes/object-oriented-programming.Rmd b/vignettes/object-oriented-programming.Rmd new file mode 100644 index 00000000..ee8b959f --- /dev/null +++ b/vignettes/object-oriented-programming.Rmd @@ -0,0 +1,215 @@ +--- +title: "Object-Oriented Programming" +author: "Martin Westgate & Dax Kellie" +date: '2026-02-11' +output: + rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Object-Oriented Programming} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + + +`galah` has some alot of functions that display object-oriented behaviour, +which are used for two purposes: + + - building piped queries via `request` objects + - handling the parsing of those objects into `query` objects + +Below we'll go through each in turn. + + +# `request` objects + +The default method for building queries in `galah` is to first use `galah_call()` +to create a query object called a "`data_request`". When a piped object is of +class `data_request`, galah triggers functions to use specific methods for +this object class, e.g. + + +``` r +galah_call() |> + filter(genus == "Crinia", year == 2020) |> + group_by(species) |> + count() |> + collect() +``` + +``` +## # A tibble: 16 × 2 +## species count +## +## 1 Crinia signifera 42477 +## 2 Crinia parinsignifera 8363 +## 3 Crinia glauerti 3111 +## 4 Crinia georgiana 1509 +## 5 Crinia remota 717 +## 6 Crinia sloanei 682 +## 7 Crinia insignifera 530 +## 8 Crinia tinnula 316 +## 9 Crinia deserticola 254 +## 10 Crinia pseudinsignifera 222 +## 11 Crinia tasmaniensis 182 +## 12 Crinia bilingua 75 +## 13 Crinia subinsignifera 46 +## 14 Crinia riparia 10 +## 15 Crinia flindersensis 3 +## 16 Crinia nimba 1 +``` + +Thanks to object-oriented programming, galah "masks" `filter()` and `group_by()` +functions to use methods defined for `data_request` objects instead. The full +list of masked functions is: + +- `arrange()` (`{dplyr}`) +- `count()` (`{dplyr}`) +- `glimpse()` (`{dplyr}`) +- `identify()` (`{graphics}`) +- `select()` (`{dplyr}`) +- `group_by()` (`{dplyr}`) +- `slice_head()` (`{dplyr}`) +- `st_crop()` (`{sf}`) + +Note that these functions are all evaluated lazily; they amend the underlying +object, but do not amend the nature of the data until the call is evaluated. + +# `query` objects + +A `request` object stores all the information needed to generate a query, +but does not build or enact that query. To achieve this, galah has a second +object-oriented workflow, consisting of the following stages + +- `capture()` identifies the url needed to execute the request. For complex + requests that require multiple API calls to evaluate, it returns a `prequery` + object. For simpler requests it returns a `query`. +- `compund()` identifies the full set of queries necessary to properly evaluate + the specified request, returning them as a `query_set`. +- `collapse()` converts a `query_set` to a `query`. This is the point in the + pipeline where the final url is generated. +- `compute()` is intended to send the query in question to the requested API + for processing. This is particularly important for occurrences, where + it can be useful to submit a query and retrieve it at a later time. If the + `compute()` stage is not required, however, `compute()` simply converts + the `query` to a new class (`computed_query`). +- `collect()` retrieves the requested data into your workspace, returning a + `tibble`. + +We can use these in sequence, or just leap ahead to the stage we want: + + +``` r +x <- request_data() |> + filter(genus == "Crinia", year == 2020) |> + group_by(species) |> + arrange(species) |> + count() + +capture(x) +``` + +``` +## Object of class prequery with type data/occurrences-count-groupby +``` + +``` +## • url: https://api.ala.org.au/occurrences/occurrences/facets?fq=%28genus%3A%2... +``` + +``` r +compound(x) +``` + +``` +## Object of class query_set containing 3 queries: +``` + +``` +## • metadata/fields data: galah:::retrieve_cache("fields") +``` + +``` +## • metadata/assertions data: galah:::retrieve_cache("assertions") +``` + +``` +## • data/occurrences-count-groupby url: https://api.ala.org.au/occurrences/occurr... +``` + +``` r +collapse(x) +``` + +``` +## Object of class query with type data/occurrences-count-groupby +``` + +``` +## • url: https://api.ala.org.au/occurrences/occurrences/facets?fq=%28genus%3A%2... +``` + +``` r +collect(x) |> head() +``` + +``` +## # A tibble: 6 × 2 +## species count +## +## 1 Crinia bilingua 75 +## 2 Crinia deserticola 254 +## 3 Crinia flindersensis 3 +## 4 Crinia georgiana 1509 +## 5 Crinia glauerti 3111 +## 6 Crinia insignifera 530 +``` + +The benefit of this workflow is that it is highly modular. This is critical +for debugging workflows that might have gone wrong for one reason or another, but it +is also useful for handling large data requests in galah. Users can send their query +using `compute()`, and download data once the query has finished — downloading +with `collect()` later — rather than waiting for the request to finish within R. + + +``` r +# Create and send query to be calculated server-side +request <- request_data() |> + identify("perameles") |> + filter(year > 1900) |> + compute() + +# Download data +request |> + collect() +``` + +# metadata requests + +For the above workflow to be achivable, it is neccessary for every API call +in `galah` to be written as a `request` object. This is because `compound()` +must collect a range of different requests to evaluate a single query. +To this end, `galah` supports metadata requests, in addition to the data +requests described above. + + + +``` r +request_metadata(type = "fields") |> + collect() +``` + +Or to show values for states and territories: + + +``` r +request_metadata() |> + filter(field == "cl22") |> + unnest() |> + collect() +``` + +While `request_metadata()` is more modular than `show_all()`, there is +little benefit to using it for most applications. However, in some cases, +larger databases like GBIF return huge `data.frame`s of metadata when called +via `show_all()`. Using `request_metdata()` allows users to specify a +`slice_head()` line within their pipe to get around this issue. diff --git a/vignettes/object-oriented-programming.Rmd.orig b/vignettes/object-oriented-programming.Rmd.orig new file mode 100644 index 00000000..104bfbc6 --- /dev/null +++ b/vignettes/object-oriented-programming.Rmd.orig @@ -0,0 +1,139 @@ +--- +title: "Object-Oriented Programming" +author: "Martin Westgate & Dax Kellie" +date: '`r Sys.Date()`' +output: + rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Object-Oriented Programming} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- +```{r include = FALSE} +galah_config(email = "ala4r@ala.org.au", + atlas = "Australia", + verbose = FALSE) +``` + +`galah` has some alot of functions that display object-oriented behaviour, +which are used for two purposes: + + - building piped queries via `request` objects + - handling the parsing of those objects into `query` objects + +Below we'll go through each in turn. + + +# `request` objects + +The default method for building queries in `galah` is to first use `galah_call()` +to create a query object called a "`data_request`". When a piped object is of +class `data_request`, galah triggers functions to use specific methods for +this object class, e.g. + +```{r} +galah_call() |> + filter(genus == "Crinia", year == 2020) |> + group_by(species) |> + count() |> + collect() +``` + +Thanks to object-oriented programming, galah "masks" `filter()` and `group_by()` +functions to use methods defined for `data_request` objects instead. The full +list of masked functions is: + +- `arrange()` (`{dplyr}`) +- `count()` (`{dplyr}`) +- `glimpse()` (`{dplyr}`) +- `identify()` (`{graphics}`) +- `select()` (`{dplyr}`) +- `group_by()` (`{dplyr}`) +- `slice_head()` (`{dplyr}`) +- `st_crop()` (`{sf}`) + +Note that these functions are all evaluated lazily; they amend the underlying +object, but do not amend the nature of the data until the call is evaluated. + +# `query` objects + +A `request` object stores all the information needed to generate a query, +but does not build or enact that query. To achieve this, galah has a second +object-oriented workflow, consisting of the following stages + +- `capture()` identifies the url needed to execute the request. For complex + requests that require multiple API calls to evaluate, it returns a `prequery` + object. For simpler requests it returns a `query`. +- `compund()` identifies the full set of queries necessary to properly evaluate + the specified request, returning them as a `query_set`. +- `collapse()` converts a `query_set` to a `query`. This is the point in the + pipeline where the final url is generated. +- `compute()` is intended to send the query in question to the requested API + for processing. This is particularly important for occurrences, where + it can be useful to submit a query and retrieve it at a later time. If the + `compute()` stage is not required, however, `compute()` simply converts + the `query` to a new class (`computed_query`). +- `collect()` retrieves the requested data into your workspace, returning a + `tibble`. + +We can use these in sequence, or just leap ahead to the stage we want: + +```{r} +x <- request_data() |> + filter(genus == "Crinia", year == 2020) |> + group_by(species) |> + arrange(species) |> + count() + +capture(x) +compound(x) +collapse(x) +collect(x) |> head() +``` + +The benefit of this workflow is that it is highly modular. This is critical +for debugging workflows that might have gone wrong for one reason or another, but it +is also useful for handling large data requests in galah. Users can send their query +using `compute()`, and download data once the query has finished — downloading +with `collect()` later — rather than waiting for the request to finish within R. + +```{r, eval = FALSE} +# Create and send query to be calculated server-side +request <- request_data() |> + identify("perameles") |> + filter(year > 1900) |> + compute() + +# Download data +request |> + collect() +``` + +# metadata requests + +For the above workflow to be achivable, it is neccessary for every API call +in `galah` to be written as a `request` object. This is because `compound()` +must collect a range of different requests to evaluate a single query. +To this end, `galah` supports metadata requests, in addition to the data +requests described above. + + +```{r, eval = FALSE} +request_metadata(type = "fields") |> + collect() +``` + +Or to show values for states and territories: + +```{r, eval = FALSE} +request_metadata() |> + filter(field == "cl22") |> + unnest() |> + collect() +``` + +While `request_metadata()` is more modular than `show_all()`, there is +little benefit to using it for most applications. However, in some cases, +larger databases like GBIF return huge `data.frame`s of metadata when called +via `show_all()`. Using `request_metdata()` allows users to specify a +`slice_head()` line within their pipe to get around this issue. \ No newline at end of file diff --git a/vignettes/object_oriented_programming.Rmd b/vignettes/object_oriented_programming.Rmd deleted file mode 100644 index f654f6ec..00000000 --- a/vignettes/object_oriented_programming.Rmd +++ /dev/null @@ -1,301 +0,0 @@ ---- -title: "Object-Oriented Programming" -author: "Martin Westgate & Dax Kellie" -date: '2024-11-19' -output: - rmarkdown::html_vignette -vignette: > - %\VignetteIndexEntry{Object-Oriented Programming} - %\VignetteEngine{knitr::rmarkdown} - %\VignetteEncoding{UTF-8} ---- - - -The default method for building queries in `galah` is to first use `galah_call()` -to create a query object called a "`data_request`". This object class is specific -to `galah`. - - -``` r -galah_call() |> - filter(genus == "Crinia") |> - class() -``` - -``` -## [1] "data_request" -``` - -When a piped object is of class `data_request`, galah can trigger functions to -use specific methods for this object class, even if a function name is used by -another package. For example, users can use `filter()` and `group_by()` functions -from [dplyr](https://dplyr.tidyverse.org/index.html) instead -of `galah_filter()` and `galah_group_by()` to construct a query. Consequently, -the following queries are synonymous: - - -``` r -galah_call() |> - galah_filter(genus == "Crinia", year == 2020) |> - galah_group_by(species) |> - atlas_counts() -``` - -``` r -galah_call() |> - filter(genus == "Crinia", year == 2020) |> - group_by(species) |> - atlas_counts() -``` - -``` -## # A tibble: 16 × 2 -## species count -## -## 1 Crinia signifera 42621 -## 2 Crinia parinsignifera 8664 -## 3 Crinia glauerti 3111 -## 4 Crinia georgiana 1509 -## 5 Crinia remota 718 -## 6 Crinia sloanei 682 -## 7 Crinia insignifera 530 -## 8 Crinia tinnula 291 -## 9 Crinia deserticola 253 -## 10 Crinia pseudinsignifera 223 -## 11 Crinia tasmaniensis 181 -## 12 Crinia bilingua 74 -## 13 Crinia subinsignifera 46 -## 14 Crinia riparia 10 -## 15 Crinia flindersensis 3 -## 16 Crinia nimba 1 -``` - -Thanks to object-oriented programming, galah "masks" `filter()` and `group_by()` -functions to use methods defined for `data_request` objects instead. The full -list of masked functions is: - -- `arrange()` (`{dplyr}`) -- `count()` (`{dplyr}`) -- `identify()` (`{graphics}`) as a synonym for `galah_identify()` -- `select()` (`{dplyr}`) as a synonym for `galah_select()` -- `group_by()` (`{dplyr}`) as a synonym for `galah_group_by()` -- `slice_head()` (`{dplyr}`) as a synonym for the `limit` argument in `atlas_counts()` -- `st_crop()` (`{sf}`) as a synonym for `galah_polygon()` - -Note that these functions are all evaluated lazily; they amend the underlying -object, but do not amend the nature of the data until the call is evaluated. To -actually build and run the query, we'll need to use one or more of a different -set of dplyr verbs: `collapse()`, `compute()` and `collect()`. - -## Advanced query building - -The usual way to begin a query to request data in galah is using `galah_call()`. -However, this function now calls one of three types of `request_` functions. -If you prefer, you can begin your pipe with one of these dedicated `request_` -functions (rather than `galah_call()`) depending on the type of data you -want to collect. - -For example, if you want to download occurrences, use `request_data()`: - - -``` r -x <- request_data("occurrences") |> # note that "occurrences" is the default `type` - filter(species == "Crinia tinnula", - year == 2010) |> - collect() -``` - -You'll notice that this query differs slightly from the query structure used in -earlier versions of `galah`. The desired data type, `"occurrences"`, -is specified at the beginning of the query within `request_data()` rather than -at the end using `atlas_occurrences()`. Specifying the data type at the start -allows users to make use of advanced query building using three newly -implemented stages of query building: `collapse()`, `compute()` and `collect()`. -These stages mirror existing [functions in dplyr for querying -databases](https://dplyr.tidyverse.org/reference/compute.html), and act in the -following way: - -- `collapse()` converts the object to a `query`. This allows users to inspect - their API calls before they are sent. Depending on the request, this function - may also call 'supplementary' APIs to collect required information, - such as Taxon Concept Identifiers or field names. -- `compute()` is intended to send the query in question to the requested API - for processing. This is particularly important for occurrences, where - it can be useful to submit a query and retrieve it at a later time. If the - `compute()` stage is not required, however, `compute()` simply converts - the `query` to a new class (`computed_query`). -- `collect()` retrieves the requested data into your workspace, returning a - `tibble`. - -We can use these in sequence, or just leap ahead to the stage we want: - - -``` r -x <- request_data() |> - filter(genus == "Crinia", year == 2020) |> - group_by(species) |> - arrange(species) |> - count() - -collapse(x) -``` - -``` -## Object of class query with type data/occurrences-count-groupby -## url: https://api.ala.org.au/occurrences/occurrences/facets?fq=%28genus%3A%2... -## arrange: species (ascending) -``` - -``` r -compute(x) -``` - -``` -## Object of class computed_query with type data/occurrences-count-groupby -## url: https://api.ala.org.au/occurrences/occurrences/facets?fq=%28genus%3A%2... -## arrange: species (ascending) -``` - -``` r -collect(x) |> head() -``` - -``` -## # A tibble: 6 × 2 -## species count -## -## 1 Crinia bilingua 74 -## 2 Crinia deserticola 253 -## 3 Crinia flindersensis 3 -## 4 Crinia georgiana 1509 -## 5 Crinia glauerti 3111 -## 6 Crinia insignifera 530 -``` - -The benefit of using `collapse()`, `compute()` and `collect()` is that queries -are more modular. This is particularly useful for large data requests in galah. -Users can send their query using `compute()`, and download data once the query -has finished — downloading with `collect()` later — rather than waiting for the -request to finish within R. - - -``` r -# Create and send query to be calculated server-side -request <- request_data() |> - identify("perameles") |> - filter(year > 1900) |> - compute() - -# Download data -request |> - collect() -``` - -Additionally, functions that are more modular are generally easier to -interrogate and debug. Previously some functions did several different things, -making it difficult to know which APIs were being called, when, and for what -purpose. Partitioning queries into three distinct stages is much more transparent, -and allows users to check their query construction prior to sending a request. -For example, the query above is constructed with the following information, -returned by `collapse()`. - - -``` r -request_data() |> - identify("perameles") |> - filter(year > 1900) |> - collapse() -``` - -``` -## Object of class query with type data/occurrences -## url: https://api.ala.org.au/occurrences/occurrences/offline/download?fq=%28... -``` - -The `collapse()` stage includes an additional argument (`.expand`) that, -when set to `TRUE`, shows all the APIs called to construct the user-requested -query. This is especially useful for debugging. - -## Object classes - -Under the hood, the different query-building verbs each amend the supplied -object to a new class: - -- `collapse()` returns class `query`, which is a list containing a `type` slot - and one or more `url`s -- `compute()` returns a single object of class `computed_query` -- `collect()` returns a `tibble` - -These can be called directly, or via the `method` and `type` arguments of -`galah_call()`, which specify which dedicated `request_` function and data type -to return. To demonstrate what we mean, take the following calls, which despite -using different syntax, all return the number of records available for the year -2020: - - -``` r -# new syntax -request_data() |> - filter(year == 2020) |> - count() |> - collect() - -# similar, but using `galah_call()` -galah_call(method = "data", - type = "occurrences-count") |> - filter(year == 2020) |> - collect() - -# original syntax -galah_call() |> - galah_filter(year == 2020) |> - atlas_counts() -``` - -Another example is to list available `fields` in the selected atlas: - - -``` r -request_metadata(type = "fields") |> - collect() - -galah_call(method = "metadata", - type = "fields") |> - collect() - -show_all(fields) -``` - -Or to show values for states and territories: - - -``` r -request_metadata() |> - filter(field == "cl22") |> - unnest() |> - collect() - -galah_call(method = "metadata", - type = "fields-unnest") |> - galah_filter(id == "cl22") |> - collect() - -search_all(fields, "cl22") |> - show_values() -``` - -While `request_metadata()` is more modular than `show_all()`, there is -little benefit to using it for most applications. However, in some cases, -larger databases like GBIF return huge `data.frame`s of metadata when called -via `show_all()`. Using `request_metdata()` allows users to specify a -`slice_head()` line within their pipe to get around this issue. - -## Which syntax should I prefer? - -Despite these benefits, we have no plans to _require_ users to call masked -functions. Functions prefixed with `galah_` or `atlas_` are not going away. -Indeed, while there is perfect redundancy between old and new syntax in some -cases, in others they serve different purposes. In `atlas_media()` for example, -several calls are made and joined in a way that reduces the number of steps -required by the user. Under the hood, however, all `atlas_` functions are now -entirely built using the above syntax. diff --git a/vignettes/object_oriented_programming.Rmd.orig b/vignettes/object_oriented_programming.Rmd.orig deleted file mode 100644 index bfd7bb05..00000000 --- a/vignettes/object_oriented_programming.Rmd.orig +++ /dev/null @@ -1,234 +0,0 @@ ---- -title: "Object-Oriented Programming" -author: "Martin Westgate & Dax Kellie" -date: '`r Sys.Date()`' -output: - rmarkdown::html_vignette -vignette: > - %\VignetteIndexEntry{Object-Oriented Programming} - %\VignetteEngine{knitr::rmarkdown} - %\VignetteEncoding{UTF-8} ---- -```{r include = FALSE} -galah_config(email = "ala4r@ala.org.au", - atlas = "Australia", - verbose = FALSE) -``` - -The default method for building queries in `galah` is to first use `galah_call()` -to create a query object called a "`data_request`". This object class is specific -to `galah`. - -```{r} -galah_call() |> - filter(genus == "Crinia") |> - class() -``` - -When a piped object is of class `data_request`, galah can trigger functions to -use specific methods for this object class, even if a function name is used by -another package. For example, users can use `filter()` and `group_by()` functions -from [dplyr](https://dplyr.tidyverse.org/index.html) instead -of `galah_filter()` and `galah_group_by()` to construct a query. Consequently, -the following queries are synonymous: - -```{r, eval = FALSE} -galah_call() |> - galah_filter(genus == "Crinia", year == 2020) |> - galah_group_by(species) |> - atlas_counts() -``` -```{r} -galah_call() |> - filter(genus == "Crinia", year == 2020) |> - group_by(species) |> - atlas_counts() -``` - -Thanks to object-oriented programming, galah "masks" `filter()` and `group_by()` -functions to use methods defined for `data_request` objects instead. The full -list of masked functions is: - -- `arrange()` (`{dplyr}`) -- `count()` (`{dplyr}`) -- `identify()` (`{graphics}`) as a synonym for `galah_identify()` -- `select()` (`{dplyr}`) as a synonym for `galah_select()` -- `group_by()` (`{dplyr}`) as a synonym for `galah_group_by()` -- `slice_head()` (`{dplyr}`) as a synonym for the `limit` argument in `atlas_counts()` -- `st_crop()` (`{sf}`) as a synonym for `galah_polygon()` - -Note that these functions are all evaluated lazily; they amend the underlying -object, but do not amend the nature of the data until the call is evaluated. To -actually build and run the query, we'll need to use one or more of a different -set of dplyr verbs: `collapse()`, `compute()` and `collect()`. - -## Advanced query building - -The usual way to begin a query to request data in galah is using `galah_call()`. -However, this function now calls one of three types of `request_` functions. -If you prefer, you can begin your pipe with one of these dedicated `request_` -functions (rather than `galah_call()`) depending on the type of data you -want to collect. - -For example, if you want to download occurrences, use `request_data()`: - -```{r, eval = FALSE} -x <- request_data("occurrences") |> # note that "occurrences" is the default `type` - filter(species == "Crinia tinnula", - year == 2010) |> - collect() -``` - -You'll notice that this query differs slightly from the query structure used in -earlier versions of `galah`. The desired data type, `"occurrences"`, -is specified at the beginning of the query within `request_data()` rather than -at the end using `atlas_occurrences()`. Specifying the data type at the start -allows users to make use of advanced query building using three newly -implemented stages of query building: `collapse()`, `compute()` and `collect()`. -These stages mirror existing [functions in dplyr for querying -databases](https://dplyr.tidyverse.org/reference/compute.html), and act in the -following way: - -- `collapse()` converts the object to a `query`. This allows users to inspect - their API calls before they are sent. Depending on the request, this function - may also call 'supplementary' APIs to collect required information, - such as Taxon Concept Identifiers or field names. -- `compute()` is intended to send the query in question to the requested API - for processing. This is particularly important for occurrences, where - it can be useful to submit a query and retrieve it at a later time. If the - `compute()` stage is not required, however, `compute()` simply converts - the `query` to a new class (`computed_query`). -- `collect()` retrieves the requested data into your workspace, returning a - `tibble`. - -We can use these in sequence, or just leap ahead to the stage we want: - -```{r} -x <- request_data() |> - filter(genus == "Crinia", year == 2020) |> - group_by(species) |> - arrange(species) |> - count() - -collapse(x) -compute(x) -collect(x) |> head() -``` - -The benefit of using `collapse()`, `compute()` and `collect()` is that queries -are more modular. This is particularly useful for large data requests in galah. -Users can send their query using `compute()`, and download data once the query -has finished — downloading with `collect()` later — rather than waiting for the -request to finish within R. - -```{r, eval = FALSE} -# Create and send query to be calculated server-side -request <- request_data() |> - identify("perameles") |> - filter(year > 1900) |> - compute() - -# Download data -request |> - collect() -``` - -Additionally, functions that are more modular are generally easier to -interrogate and debug. Previously some functions did several different things, -making it difficult to know which APIs were being called, when, and for what -purpose. Partitioning queries into three distinct stages is much more transparent, -and allows users to check their query construction prior to sending a request. -For example, the query above is constructed with the following information, -returned by `collapse()`. - -```{r} -request_data() |> - identify("perameles") |> - filter(year > 1900) |> - collapse() -``` - -The `collapse()` stage includes an additional argument (`.expand`) that, -when set to `TRUE`, shows all the APIs called to construct the user-requested -query. This is especially useful for debugging. - -## Object classes - -Under the hood, the different query-building verbs each amend the supplied -object to a new class: - -- `collapse()` returns class `query`, which is a list containing a `type` slot - and one or more `url`s -- `compute()` returns a single object of class `computed_query` -- `collect()` returns a `tibble` - -These can be called directly, or via the `method` and `type` arguments of -`galah_call()`, which specify which dedicated `request_` function and data type -to return. To demonstrate what we mean, take the following calls, which despite -using different syntax, all return the number of records available for the year -2020: - -```{r, eval = FALSE} -# new syntax -request_data() |> - filter(year == 2020) |> - count() |> - collect() - -# similar, but using `galah_call()` -galah_call(method = "data", - type = "occurrences-count") |> - filter(year == 2020) |> - collect() - -# original syntax -galah_call() |> - galah_filter(year == 2020) |> - atlas_counts() -``` - -Another example is to list available `fields` in the selected atlas: - -```{r, eval = FALSE} -request_metadata(type = "fields") |> - collect() - -galah_call(method = "metadata", - type = "fields") |> - collect() - -show_all(fields) -``` - -Or to show values for states and territories: - -```{r, eval = FALSE} -request_metadata() |> - filter(field == "cl22") |> - unnest() |> - collect() - -galah_call(method = "metadata", - type = "fields-unnest") |> - galah_filter(id == "cl22") |> - collect() - -search_all(fields, "cl22") |> - show_values() -``` - -While `request_metadata()` is more modular than `show_all()`, there is -little benefit to using it for most applications. However, in some cases, -larger databases like GBIF return huge `data.frame`s of metadata when called -via `show_all()`. Using `request_metdata()` allows users to specify a -`slice_head()` line within their pipe to get around this issue. - -## Which syntax should I prefer? - -Despite these benefits, we have no plans to _require_ users to call masked -functions. Functions prefixed with `galah_` or `atlas_` are not going away. -Indeed, while there is perfect redundancy between old and new syntax in some -cases, in others they serve different purposes. In `atlas_media()` for example, -several calls are made and joined in a way that reduces the number of steps -required by the user. Under the hood, however, all `atlas_` functions are now -entirely built using the above syntax. \ No newline at end of file diff --git a/vignettes/precompile.R b/vignettes/precompile.R index 394abe43..c8b53b06 100644 --- a/vignettes/precompile.R +++ b/vignettes/precompile.R @@ -6,46 +6,15 @@ library(knitr) library(dplyr) galah_config(email = "ala4r@ala.org.au") # add your email -# get data on atlases for the `choosing an atlas` vignette -atlases <- show_all(atlases) -counts <- map(atlases$region, - function(x){ - galah_config(atlas = x) - atlas_counts() - }) -services <- show_all(apis) |> - filter(type != "files/media") |> - bind_rows( # add cached gbif data - tibble( - atlas = "Global", - type = c("data/species", "metadata/fields", "metadata/assertions"), - url = NA), - tibble( - atlas = c("Austria", "Australia", "Brazil", "Guatemala", "Portugal", "Spain", "Sweden", "United Kingdom"), - type = "files/media", - url = NA)) |> - group_by(atlas) |> - summarize(n_services = n()) - - -atlases_csv <- atlases |> - select(region, institution) |> - bind_cols(bind_rows(counts)) |> - left_join(services, by = c("region" = "atlas")) |> - arrange(desc(count)) - -write.csv(atlases_csv, "./vignettes/atlas_stats.csv", row.names = FALSE) - - # workflow for automated detection and processing of vignettes folder <- "./vignettes/" all_files <- list.files(folder) selected_files <- paste0(folder, all_files[grepl(".orig$", all_files)]) out_files <- sub(".orig$", "", selected_files) -lapply( +purrr::map( seq_along(selected_files), - function(a){ + \(a){ knit(selected_files[[a]], out_files[[a]]) }) @@ -54,4 +23,4 @@ lapply( # # next steps devtools::build_vignettes() -pkgdown::build_site() +pkgdown::build_site() \ No newline at end of file diff --git a/vignettes/quick_start_guide.Rmd b/vignettes/quick_start_guide.Rmd index 0d735e0b..9cac39f4 100644 --- a/vignettes/quick_start_guide.Rmd +++ b/vignettes/quick_start_guide.Rmd @@ -1,7 +1,7 @@ --- title: "Quick start guide" author: "Martin Westgate & Dax Kellie" -date: '2024-11-19' +date: '2026-02-11' output: rmarkdown::html_vignette vignette: > @@ -9,7 +9,7 @@ vignette: > %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- -galah is an R interface to biodiversity data hosted by the Global Biodiversity +`galah` is an R interface to biodiversity data hosted by the Global Biodiversity Information Facility ([GBIF](https://www.gbif.org)) and its subsidiary node organisations. GBIF and its partner nodes collate and store observations of individual life forms using the ['Darwin Core'](https://dwc.tdwg.org) data @@ -37,189 +37,307 @@ library(galah) ``` # Configuration -By default, galah downloads information from the Atlas of Living Australia -(ALA). To show the full list of organisations currently supported by galah, -use `show_all(atlases)`. +Begin by choosing which organisation you would like `galah` to query, +and providing your registration information for that organisation. ``` r -show_all(atlases) +galah_config(atlas = "GBIF", + username = "user1", + email = "email@email.com", + password = "my_password") ``` -``` -## # A tibble: 10 × 4 -## region institution acronym url -## -## 1 Australia Atlas of Living Australia ALA https://www.ala.org.au -## 2 Austria Biodiversitäts-Atlas Österreich BAO https://biodiversityat… -## 3 Brazil Sistemas de Informações sobre a Biodiversidade Brasileira SiBBr https://sibbr.gov.br -## 4 France Portail français d'accès aux données d'observation sur les espèces OpenObs https://openobs.mnhn.fr -## 5 Global Global Biodiversity Information Facility GBIF https://gbif.org -## 6 Guatemala Sistema Nacional de Información sobre Diversidad Biológica de Guatemala SNIBgt https://snib.conap.gob… -## 7 Portugal GBIF Portugal GBIF.pt https://www.gbif.pt -## 8 Spain GBIF Spain GBIF.es https://gbif.es -## 9 Sweden Swedish Biodiversity Data Infrastructure SBDI https://biodiversityda… -## 10 United Kingdom National Biodiversity Network NBN https://nbn.org.uk -``` +The full list of supported queries by organisation is as follows: + +
+Fig 1: Organisations and APIs supported by galah +

Fig 1: Organisations and APIs supported by galah

+
-Use `galah_config()` to set the node organisation using its region, name, or -acronym. Once set, `galah` will automatically populate the server configuration for your -selected GBIF node. To download occurrence records from your chosen -GBIF node, you will need to register an account with them (using their website), -then provide your registration email to galah. -To download from GBIF, you will need to provide the email, username, and -password. +# Getting data +`galah` is a `dplyr` extension package; rather than using pipes to amend +a `tibble` in your workspace, you amend a query, which is then sent to your +chosen organisation. These pipes differ from traditional syntax in two ways: + +- they begin with a function - usually `galah_call()` - instead of a `tibble` +- they end with one of `dplyr`'s evaluation functions, usually `collect()` + +So an example query might be to find the number of records per year: ``` r -galah_config(atlas = "GBIF", - username = "user1", - email = "email@email.com", - password = "my_password") +galah_config(atlas = "Australia") + +galah_call() |> # open a pipe + filter(year >= 2020) |> # choose rows to keep + count(year) |> # count the number of rows + collect() # retrieve query from the server ``` -You can find a full list of configuration options by running `?galah_config`. -# Basic syntax -The standard method to construct queries in `{galah}` is via piped functions. -Pipes in `galah` start with the `galah_call()` function, and typically end with -`collect()`, though `collapse()` and `compute()` are also supported. The -development team use the base pipe by default (`|>`), but the `{magrittr}` pipe -(`%>%`) should work too. - +``` +## # A tibble: 7 × 2 +## year count +## +## 1 2024 11889930 +## 2 2023 11007491 +## 3 2022 9430065 +## 4 2025 9142677 +## 5 2021 8695248 +## 6 2020 7311836 +## 7 2026 309836 +``` + +Or to find the number of categories present in a dataset, for example how many +species are present: + ``` r -galah_config(atlas = "ALA", - verbose = FALSE) galah_call() |> + identify("Crinia") |> # filters by taxonomic names + distinct(speciesID) |> # keep only unique values count() |> collect() ``` ``` ## # A tibble: 1 × 1 -## count -## -## 1 146185520 +## count +## +## 1 17 ``` -To pass more complex queries, you can use additional `{dplyr}` functions such as -`filter()`, `select()`, and `group_by()`. +You can 'glimpse' a data download before you run it, to check all the data +you need is included: ``` r -galah_call() |> - filter(year >= 2020) |> - count() |> +galah_call() |> + identify("Eolophus roseicapilla") |> + filter(year == 2010) |> + glimpse() |> collect() ``` ``` -## # A tibble: 1 × 1 -## count -## -## 1 40200358 +## Rows: 21,984 +## Columns: 8 +## $ taxonConceptID "https://biodiversity.org.au/afd/taxa/9b4ad548-8bb3-486a-ab0a-905506c463ea", "https://biodiversity.org.au… +## $ eventDate 1.272672e+12, 1.289002e+12, 1.291014e+12 +## $ scientificName "Eolophus roseicapilla", "Eolophus roseicapilla", "Eolophus roseicapilla" +## $ decimalLatitude -25.98833, -37.83032, -35.41707 +## $ decimalLongitude 152.0442, 144.9812, 138.6868 +## $ basisOfRecord "HUMAN_OBSERVATION", "HUMAN_OBSERVATION", "HUMAN_OBSERVATION" +## $ dataResourceName "BirdLife Australia, Birdata", "eBird Australia", "eBird Australia" +## $ occurrenceStatus "PRESENT", "ABSENT", "ABSENT" ``` -Each GBIF node allows you to query using their own set of in-built fields. You -can investigate which fields are available using `show_all()` and `search_all()`: +And, once satisfied that your parameters are correct, download the records +themselves: + + ``` r -search_all(fields, "australian states") +galah_call() |> + identify("Eolophus roseicapilla") |> + filter(year == 2010) |> + select(eventDate, decimalLatitude, species) |> + collect() ``` ``` -## # A tibble: 2 × 3 -## id description type -## -## 1 cl2013 ASGS Australian States and Territories fields -## 2 cl22 Australian States and Territories fields +## # A tibble: 21,984 × 3 +## eventDate decimalLatitude species +## +## 1 NA -36.5 Eolophus roseicapilla +## 2 NA -38.2 Eolophus roseicapilla +## 3 NA -37.0 Eolophus roseicapilla +## 4 NA -37.7 Eolophus roseicapilla +## 5 NA -35.6 Eolophus roseicapilla +## 6 NA -31.1 Eolophus roseicapilla +## 7 NA -38.2 Eolophus roseicapilla +## 8 NA -38.2 Eolophus roseicapilla +## 9 NA -38.2 Eolophus roseicapilla +## 10 NA -38.2 Eolophus roseicapilla +## # ℹ 21,974 more rows ``` -# Taxonomic searches -To narrow your search to a particular taxonomic group, use `identify()`. Note -that this function only accepts scientific names and is not case sensitive. -It's good practice to first use `search_taxa()` to check that the taxa you -provide returns the correct taxonomic results. +This works because many of the functions in `dplyr` are "generic", meaning +it is possible to write extensions that apply them to new object classes. +In our case, `galah_call()` creates a new object class called a +`data_request` for which we have written new extensions. This means that galah +will not interfere with your use of `filter()` and friends on your tibbles. +Supported `dplyr` verbs that modify queries are as follows: + +- `arrange.data_request()` +- `count.data_request()` +- `distinct.data_request()` +- `filter.data_request()` +- `glimpse.data_request()` +- `group_by.data_request()` +- `select.data_request()` +- `slice_head.data_request()` + +Additional verbs are: + +- `apply_profile()` +- `geolocate()` or `st_crop.data_request()` +- `identify.data_request()` +- `unnest()` + +It is good practice to download your data in as few steps as possible, +to minimize impacts on the server, and to ensure you can get a single +DOI for your data. See the +[download data reproducibly](download-data-reproducibly.html) vignette +for details. + +# Finding information + +Building queries using `filter()` requires that you know two things: + +- what **fields** (columns) are present in the dataset you are searching +- what **values** exist for those fields + +Finding this information requires looking for metadata: ``` r -search_taxa("reptilia") # Check whether taxonomic info is correct +request_metadata(type = "fields") |> + collect() ``` ``` -## # A tibble: 1 × 9 -## search_term scientific_name taxon_concept_id rank match_type kingdom phylum class issues -## -## 1 reptilia REPTILIA https://biodiversity.org.au/afd/taxa/682e1228… class exactMatch Animal… Chord… Rept… noIss… +## # A tibble: 639 × 3 +## id description type +## +## 1 abcdTypeStatus fields +## 2 acceptedNameUsage Accepted name fields +## 3 acceptedNameUsageID Accepted name fields +## 4 accessRights Access rights fields +## 5 annotationsDoi fields +## 6 annotationsUid Referenced by publication fields +## 7 assertionUserId Assertions by user fields +## 8 assertions Record issues fields +## 9 assertionsCount fields +## 10 associatedMedia Associated Media fields +## # ℹ 629 more rows ``` +You can browser this tibble using `View()` or search it using `filter()`. +Once you have found a field that you want to include in your query, you +can find values for that field using `unnest()`: + + ``` r -galah_call() |> - identify("reptilia") |> - filter(year >= 2020) |> - count() |> +request_metadata() |> + filter(fields == "cl22") |> + unnest() |> collect() ``` ``` -## # A tibble: 1 × 1 -## count -## -## 1 338434 +## # A tibble: 11 × 1 +## cl22 +## +## 1 New South Wales +## 2 Victoria +## 3 Queensland +## 4 South Australia +## 5 Western Australia +## 6 Northern Territory +## 7 Tasmania +## 8 Australian Capital Territory +## 9 Macquarie Island +## 10 Coral Sea Islands +## 11 Ashmore and Cartier Islands ``` -If you want to query something other than the number of records, modify the -`type` argument in `galah_call()`. Here we'll query the number of species: +Different types of metadata are available; see `?request_metadata` for +a full list. + +# Wrapper functions + +While `dplyr` syntax is very flexible, there are cases where it is easier +to simply say the sort of data you want, rather than create a database +query to implement it. For this reason, several common use cases have +their own wrapper functions. + +The `atlas_` family of functions act like `collect()`, but enforce +a particular type of data to be returned, such as record counts: ``` r -galah_call(type = "species") |> - identify("reptilia") |> - filter(year >= 2020) |> - count() |> - collect() +galah_call() |> + filter(year == 2025) |> + atlas_counts() # note no need for a `count()` function ``` ``` ## # A tibble: 1 × 1 -## count -## -## 1 883 +## count +## +## 1 9142677 ``` -# Download -To download records---rather than find how many records are available---simply -remove the `count()` function from your pipe. +Or occurrences: ``` r -result <- galah_call() |> - identify("Litoria") |> - filter(year >= 2020, cl22 == "Tasmania") |> - select(basisOfRecord, group = "basic") |> - collect() +galah_call() |> + identify("Eolophus roseicapilla") |> + filter(year == 2000, + cl22 == "Australian Capital Territory") |> + atlas_occurrences() |> + print(n = 6) ``` ``` -## Retrying in 1 seconds. +## # A tibble: 2,032 × 9 +## recordID scientificName taxonConceptID decimalLatitude decimalLongitude eventDate basisOfRecord occurrenceStatus +## +## 1 0026d29f-b6ab-4… Eolophus rose… https://biodi… -35.4 149. 2000-08-07 00:00:00 HUMAN_OBSERV… PRESENT +## 2 0062d446-007b-4… Eolophus rose… https://biodi… -35.3 149. 2000-03-10 00:00:00 HUMAN_OBSERV… PRESENT +## 3 00a62ee0-1e08-4… Eolophus rose… https://biodi… -35.2 149. 2000-01-29 00:00:00 HUMAN_OBSERV… PRESENT +## 4 00ab2f4d-326f-4… Eolophus rose… https://biodi… -35.4 149. 2000-09-25 00:00:00 HUMAN_OBSERV… PRESENT +## 5 00ae4631-ea59-4… Eolophus rose… https://biodi… -35.3 149. 2000-02-12 00:00:00 HUMAN_OBSERV… PRESENT +## 6 00b6c8ec-e7b9-4… Eolophus rose… https://biodi… -35.2 149. 2000-02-05 00:00:00 HUMAN_OBSERV… PRESENT +## # ℹ 2,026 more rows +## # ℹ 1 more variable: dataResourceName ``` +`atlas_species()` replaces the need for `distinct()` call, while `atlas_media()` +is a shortcut to a complex workflow that incorporates both data and metadata +calls; see the [downloading images and sounds](downloading_images_and_sounds.html) +vignette for details. + +Finally, metadata calls can be made more efficiently using the `show_all()` +and `show_values()` functions. These take the same arguments as the `type` +argument in `request_metadata()`, but use non-standard evaluation, so they +don't require quotes. They are also evaluated immediately rather than lazily: + + ``` r -result |> head() +show_all(fields) ``` ``` -## # A tibble: 6 × 9 -## recordID scientificName taxonConceptID decimalLatitude decimalLongitude eventDate occurrenceStatus -## -## 1 00052544-d943-42e9… Litoria ewing… https://biodi… -42.9 147. 2022-09-19 00:00:00 PRESENT -## 2 00168ca6-84d0-4af1… Litoria ranif… https://biodi… -41.2 146. 2023-12-21 10:20:19 PRESENT -## 3 001a43fe-8586-4064… Litoria ewing… https://biodi… -43.0 147. 2021-08-07 00:00:00 PRESENT -## 4 00250163-ec50-4eda… Litoria ranif… https://biodi… -41.2 147. 2023-08-23 11:49:28 PRESENT -## 5 003e0f63-9f95-4af9… Litoria ewing… https://biodi… -42.9 148. 2022-12-24 06:27:00 PRESENT -## 6 0070521f-bb45-46fb… Litoria ewing… https://biodi… -43.1 147. 2023-12-20 14:29:23 PRESENT -## # ℹ 2 more variables: dataResourceName , basisOfRecord +## # A tibble: 639 × 3 +## id description type +## +## 1 abcdTypeStatus fields +## 2 acceptedNameUsage Accepted name fields +## 3 acceptedNameUsageID Accepted name fields +## 4 accessRights Access rights fields +## 5 annotationsDoi fields +## 6 annotationsUid Referenced by publication fields +## 7 assertionUserId Assertions by user fields +## 8 assertions Record issues fields +## 9 assertionsCount fields +## 10 associatedMedia Associated Media fields +## # ℹ 629 more rows ``` -Check out our other vignettes for more detail on how to use these functions. +You can check the [look up information](lookup_up_information.html) vignette +for further details. + diff --git a/vignettes/quick_start_guide.Rmd.orig b/vignettes/quick_start_guide.Rmd.orig index 427fbf9a..4a11e3fe 100644 --- a/vignettes/quick_start_guide.Rmd.orig +++ b/vignettes/quick_start_guide.Rmd.orig @@ -9,7 +9,7 @@ vignette: > %\VignetteEngine{knitr::rmarkdown} %\VignetteEncoding{UTF-8} --- -galah is an R interface to biodiversity data hosted by the Global Biodiversity +`galah` is an R interface to biodiversity data hosted by the Global Biodiversity Information Facility ([GBIF](https://www.gbif.org)) and its subsidiary node organisations. GBIF and its partner nodes collate and store observations of individual life forms using the ['Darwin Core'](https://dwc.tdwg.org) data @@ -18,118 +18,194 @@ standard. # Installation To install from CRAN: -```{r eval=FALSE} +```{r, cran-install, eval=FALSE} install.packages("galah") ``` Or install the development version from GitHub: -```{r eval=FALSE} +```{r, remotes-install, eval=FALSE} install.packages("remotes") remotes::install_github("AtlasOfLivingAustralia/galah") ``` Load the package -```{r eval=FALSE} +```{r, load-package, eval=FALSE} library(galah) ``` # Configuration -By default, galah downloads information from the Atlas of Living Australia -(ALA). To show the full list of organisations currently supported by galah, -use `show_all(atlases)`. +Begin by choosing which organisation you would like `galah` to query, +and providing your registration information for that organisation. -```{r} -show_all(atlases) -``` - -Use `galah_config()` to set the node organisation using its region, name, or -acronym. Once set, `galah` will automatically populate the server configuration for your -selected GBIF node. To download occurrence records from your chosen -GBIF node, you will need to register an account with them (using their website), -then provide your registration email to galah. -To download from GBIF, you will need to provide the email, username, and -password. - -```{r, eval=FALSE} +```{r, galah-config, eval=FALSE} galah_config(atlas = "GBIF", username = "user1", email = "email@email.com", password = "my_password") ``` -You can find a full list of configuration options by running `?galah_config`. - -# Basic syntax -The standard method to construct queries in `{galah}` is via piped functions. -Pipes in `galah` start with the `galah_call()` function, and typically end with -`collect()`, though `collapse()` and `compute()` are also supported. The -development team use the base pipe by default (`|>`), but the `{magrittr}` pipe -(`%>%`) should work too. - -```{r} -galah_config(atlas = "ALA", - verbose = FALSE) -galah_call() |> - count() |> - collect() + +The full list of supported queries by organisation is as follows: + +```{r, atlas-support, echo = FALSE, out.width = "100%", fig.cap="Fig 1: Organisations and APIs supported by galah"} +knitr::include_graphics('../man/figures/atlases_plot.png') ``` -To pass more complex queries, you can use additional `{dplyr}` functions such as -`filter()`, `select()`, and `group_by()`. +# Getting data +`galah` is a `dplyr` extension package; rather than using pipes to amend +a `tibble` in your workspace, you amend a query, which is then sent to your +chosen organisation. These pipes differ from traditional syntax in two ways: + +- they begin with a function - usually `galah_call()` - instead of a `tibble` +- they end with one of `dplyr`'s evaluation functions, usually `collect()` + +So an example query might be to find the number of records per year: + +```{r, count-example} +galah_config(atlas = "Australia") -```{r} -galah_call() |> - filter(year >= 2020) |> +galah_call() |> # open a pipe + filter(year >= 2020) |> # choose rows to keep + count(year) |> # count the number of rows + collect() # retrieve query from the server +``` + +Or to find the number of categories present in a dataset, for example how many +species are present: + +```{r, distinct-example} +galah_call() |> + identify("Crinia") |> # filters by taxonomic names + distinct(speciesID) |> # keep only unique values count() |> collect() ``` -Each GBIF node allows you to query using their own set of in-built fields. You -can investigate which fields are available using `show_all()` and `search_all()`: +You can 'glimpse' a data download before you run it, to check all the data +you need is included: -```{r} -search_all(fields, "australian states") +```{r, glimpse-example} +galah_call() |> + identify("Eolophus roseicapilla") |> + filter(year == 2010) |> + glimpse() |> + collect() ``` -# Taxonomic searches -To narrow your search to a particular taxonomic group, use `identify()`. Note -that this function only accepts scientific names and is not case sensitive. -It's good practice to first use `search_taxa()` to check that the taxa you -provide returns the correct taxonomic results. +And, once satisfied that your parameters are correct, download the records +themselves: -```{r} -search_taxa("reptilia") # Check whether taxonomic info is correct +```{r, cache-email, echo = FALSE} +galah_config(email = "ala4r@ala.org.au", + verbose = FALSE) +``` +```{r, occurrence-example, message = FALSE} galah_call() |> - identify("reptilia") |> - filter(year >= 2020) |> - count() |> + identify("Eolophus roseicapilla") |> + filter(year == 2010) |> + select(eventDate, decimalLatitude, species) |> collect() ``` -If you want to query something other than the number of records, modify the -`type` argument in `galah_call()`. Here we'll query the number of species: +This works because many of the functions in `dplyr` are "generic", meaning +it is possible to write extensions that apply them to new object classes. +In our case, `galah_call()` creates a new object class called a +`data_request` for which we have written new extensions. This means that galah +will not interfere with your use of `filter()` and friends on your tibbles. +Supported `dplyr` verbs that modify queries are as follows: -```{r} -galah_call(type = "species") |> - identify("reptilia") |> - filter(year >= 2020) |> - count() |> +- `arrange.data_request()` +- `count.data_request()` +- `distinct.data_request()` +- `filter.data_request()` +- `glimpse.data_request()` +- `group_by.data_request()` +- `select.data_request()` +- `slice_head.data_request()` + +Additional verbs are: + +- `apply_profile()` +- `geolocate()` or `st_crop.data_request()` +- `identify.data_request()` +- `unnest()` + +It is good practice to download your data in as few steps as possible, +to minimize impacts on the server, and to ensure you can get a single +DOI for your data. See the +[download data reproducibly](download-data-reproducibly.html) vignette +for details. + +# Finding information + +Building queries using `filter()` requires that you know two things: + +- what **fields** (columns) are present in the dataset you are searching +- what **values** exist for those fields + +Finding this information requires looking for metadata: + +```{r, metadata-fields} +request_metadata(type = "fields") |> collect() ``` -# Download -To download records---rather than find how many records are available---simply -remove the `count()` function from your pipe. +You can browser this tibble using `View()` or search it using `filter()`. +Once you have found a field that you want to include in your query, you +can find values for that field using `unnest()`: -```{r} -result <- galah_call() |> - identify("Litoria") |> - filter(year >= 2020, cl22 == "Tasmania") |> - select(basisOfRecord, group = "basic") |> +```{r, metadata-fields-unnest} +request_metadata() |> + filter(fields == "cl22") |> + unnest() |> collect() +``` + +Different types of metadata are available; see `?request_metadata` for +a full list. + +# Wrapper functions + +While `dplyr` syntax is very flexible, there are cases where it is easier +to simply say the sort of data you want, rather than create a database +query to implement it. For this reason, several common use cases have +their own wrapper functions. -result |> head() +The `atlas_` family of functions act like `collect()`, but enforce +a particular type of data to be returned, such as record counts: + +```{r, atlas-counts} +galah_call() |> + filter(year == 2025) |> + atlas_counts() # note no need for a `count()` function +``` + +Or occurrences: + +```{r, atlas-occurrences, message = FALSE} +galah_call() |> + identify("Eolophus roseicapilla") |> + filter(year == 2000, + cl22 == "Australian Capital Territory") |> + atlas_occurrences() |> + print(n = 6) ``` -Check out our other vignettes for more detail on how to use these functions. \ No newline at end of file +`atlas_species()` replaces the need for `distinct()` call, while `atlas_media()` +is a shortcut to a complex workflow that incorporates both data and metadata +calls; see the [downloading images and sounds](downloading_images_and_sounds.html) +vignette for details. + +Finally, metadata calls can be made more efficiently using the `show_all()` +and `show_values()` functions. These take the same arguments as the `type` +argument in `request_metadata()`, but use non-standard evaluation, so they +don't require quotes. They are also evaluated immediately rather than lazily: + +```{r, show-all-fields} +show_all(fields) +``` + +You can check the [look up information](lookup_up_information.html) vignette +for further details. +