diff --git a/R/get_bibliography.R b/R/get_bibliography.R index 8d64b7da..d0ecaab4 100644 --- a/R/get_bibliography.R +++ b/R/get_bibliography.R @@ -12,6 +12,7 @@ #' first row contains the citation for the ETN platform, the second row the #' citation for the etn R package, and subsequent rows contain citations for #' the animal and acoustic projects present in the input data.frame. +#' @family access functions #' @export #' #' @examplesIf interactive() && etn:::credentials_are_set() diff --git a/R/utils.R b/R/utils.R index f42e572f..40252910 100644 --- a/R/utils.R +++ b/R/utils.R @@ -2,16 +2,28 @@ #' Check input value against valid values #' +#' This function checks if the input value(s) `x` are present in the valid +#' values `y`. If any value in `x` is not found in `y`, an error is thrown. If +#' `lowercase` is set to `TRUE`, the case of the values will be ignored during +#' the comparison, and the returned values will be converted to lowercase. +#' +#' A suggestion will be offered when a value is not found, based on the +#' Levenshtein distance to the valid values. +#' +#' This function was inspired by `rlang:::stop_arg_match()`. +#' #' @param x Value(s) to test. #' `NULL` values will automatically pass. #' @param y Value(s) to test against. #' @param name Name of the parameter. #' @param lowercase If `TRUE`, the case of `x` and `y` values will ignored and #' `x` values will be returned lowercase. +#' @param max_dist Maximum Levenshtein distance to consider a value a typo. +#' This variable is used to offer suggestions when a typo is suspected. #' @returns Error or (lowercase) `x` values. #' @family helper functions #' @noRd -check_value <- function(x, y, name = "value", lowercase = FALSE) { +check_value <- function(x, y, name = "value", lowercase = FALSE, max_dist = 3) { # Remove NA from valid values y <- y[!is.na(y)] @@ -20,18 +32,54 @@ check_value <- function(x, y, name = "value", lowercase = FALSE) { x <- tolower(x) y <- tolower(y) } - # Check value(s) against valid values - assertthat::assert_that( - all(x %in% y), # Returns TRUE for x = NULL - msg = glue::glue( - "Can't find {name} `{x}` in: {y}", - x = glue::glue_collapse(x, sep = "`, `", last = "` and/or `"), - y = glue::glue_collapse(y, sep = ", ", width = 300) + if (all(x %in% y)) { + return(x) + } + missing_values <- x[!x %in% y] + # If the value is not found, check if it's a typo by calculating the + # Levenshtein distance. + distances <- utils::adist(missing_values, y) |> + # Transpose the matrix so we can get the minimum distance per candidate + t() |> + as.data.frame() |> + purrr::set_names(missing_values) + # If any candidate string is less 3 transformations away from the reference, + # we can assume it's a typo and suggest it to the user. + candidates_col <- cli::cli_vec(y, list("vec-trunc" = 5)) + if (any(purrr::map_lgl(distances, \(dist_for_value) { + any(dist_for_value <= max_dist) + }))) { + # We need to repeat the candidates so we can get the minimum distance + # for each missing value + closest_match <- + rep(y, length(missing_values))[purrr::map_int(distances, which.min)] + # If there are many candidates, truncate the list to 5 items for the error + # message. + cli::cli_abort( + "Can't find {.var {name}}: {.val {missing_values}} in: {.or {.str {candidates_col}}}. + Did you mean {.strong {.val {closest_match}}}?", + class = "etn_value_not_found_suggest", + call = rlang::caller_env() ) - ) - - return(x) + } else { + # Sort the references so the closest matches are mentioned. Only show 5 + # members. + candidates_col <- purrr::map(distances, \(dist_for_value){ + y[order(as.vector(dist_for_value))] + }) |> + # Convert into a vector and truncate for the error message + purrr::reduce(rbind) |> + c() |> + # Don't repeat yourself + unique() |> + cli::cli_vec(list("vec-trunc" = 5)) + cli::cli_abort( + "Can't find {.var {name}}: {.val {missing_values}} in: {.or {.str {candidates_col}}}.", + class = "etn_value_not_found", + call = rlang::caller_env() + ) + } } #' Get credentials from environment variables, or set them manually @@ -183,7 +231,8 @@ localdb_is_available <- function() { select_protocol <- function() { # ALlow overwriting of protocol logic by environmental variable user_selected_protocol <- Sys.getenv("ETN_PROTOCOL", - unset = "no_protocol_set") + unset = "no_protocol_set" + ) if (user_selected_protocol != "no_protocol_set") { return(user_selected_protocol) } @@ -239,8 +288,8 @@ remove_html_tags <- function(x) { #' environment variables. #' @family helper functions #' @noRd -credentials_are_set <- function(){ - nzchar(Sys.getenv("ETN_USER")) && nzchar(Sys.getenv("ETN_PWD")) +credentials_are_set <- function() { + nzchar(Sys.getenv("ETN_USER")) && nzchar(Sys.getenv("ETN_PWD")) } #' Get the citation for the etn package as plain text @@ -253,19 +302,19 @@ credentials_are_set <- function(){ #' #' @family helper functions #' @noRd -etn_citation <- function(){ - utils::citation("etn") |> - format(style = "text") |> - # Remove linebreaks that may have been introduced based on console width - stringr::str_squish() |> - # Remove markup: emphasis - stringr::str_remove_all(stringr::fixed("_")) |> - # Remove markup: links - stringr::str_remove_all("[<>]") |> - # Only mention doi once, so remove the doi: string - stringr::str_remove("doi:.*?(?= )") |> - # Finally, get rid of any superflous whitespace - stringr::str_squish() +etn_citation <- function() { + authors <- + "Huybrechts P, Desmet P, Govaert S, Oldoni D, Van Hoey S" + title <- + "etn: Access Data from the European Tracking Network" + + doi_url <- "https://doi.org/10.5281/zenodo.15235747" + + version_str <- paste("R package version", utils::packageVersion("etn")) + + docs_url <- "https://inbo.github.io/etn/" + + sprintf("%s. %s. %s, %s, %s.", authors, title, doi_url, version_str, docs_url) } # WRAPPER FUNCTIONS ---- @@ -318,13 +367,13 @@ NULL # Checking this on every call would slow down the package. get_etnservice_version <<- memoise::memoise(get_etnservice_version, - cache = cachem::cache_mem(max_age = 60 * 15) + cache = cachem::cache_mem(max_age = 60 * 15) ) # Memoisation: only validate the login credentials every 15 minutes. validate_login <<- memoise::memoise(validate_login, - cache = cachem::cache_mem(max_age = 60 * 15) - ) + cache = cachem::cache_mem(max_age = 60 * 15) + ) } #' Expand columns diff --git a/man/get_acoustic_deployments.Rd b/man/get_acoustic_deployments.Rd index 4087b38e..1841dc2a 100644 --- a/man/get_acoustic_deployments.Rd +++ b/man/get_acoustic_deployments.Rd @@ -67,6 +67,7 @@ Other access functions: \code{\link[=get_acoustic_receivers]{get_acoustic_receivers()}}, \code{\link[=get_animal_projects]{get_animal_projects()}}, \code{\link[=get_animals]{get_animals()}}, +\code{\link[=get_bibliography]{get_bibliography()}}, \code{\link[=get_cpod_projects]{get_cpod_projects()}}, \code{\link[=get_package]{get_package()}}, \code{\link[=get_tags]{get_tags()}} diff --git a/man/get_acoustic_detections.Rd b/man/get_acoustic_detections.Rd index 389cd724..ef58621d 100644 --- a/man/get_acoustic_detections.Rd +++ b/man/get_acoustic_detections.Rd @@ -112,6 +112,7 @@ Other access functions: \code{\link[=get_acoustic_receivers]{get_acoustic_receivers()}}, \code{\link[=get_animal_projects]{get_animal_projects()}}, \code{\link[=get_animals]{get_animals()}}, +\code{\link[=get_bibliography]{get_bibliography()}}, \code{\link[=get_cpod_projects]{get_cpod_projects()}}, \code{\link[=get_package]{get_package()}}, \code{\link[=get_tags]{get_tags()}} diff --git a/man/get_acoustic_projects.Rd b/man/get_acoustic_projects.Rd index 3c93e222..cbd560df 100644 --- a/man/get_acoustic_projects.Rd +++ b/man/get_acoustic_projects.Rd @@ -52,6 +52,7 @@ Other access functions: \code{\link[=get_acoustic_receivers]{get_acoustic_receivers()}}, \code{\link[=get_animal_projects]{get_animal_projects()}}, \code{\link[=get_animals]{get_animals()}}, +\code{\link[=get_bibliography]{get_bibliography()}}, \code{\link[=get_cpod_projects]{get_cpod_projects()}}, \code{\link[=get_package]{get_package()}}, \code{\link[=get_tags]{get_tags()}} diff --git a/man/get_acoustic_receivers.Rd b/man/get_acoustic_receivers.Rd index a77c10f6..a552e508 100644 --- a/man/get_acoustic_receivers.Rd +++ b/man/get_acoustic_receivers.Rd @@ -42,6 +42,7 @@ Other access functions: \code{\link[=get_acoustic_projects]{get_acoustic_projects()}}, \code{\link[=get_animal_projects]{get_animal_projects()}}, \code{\link[=get_animals]{get_animals()}}, +\code{\link[=get_bibliography]{get_bibliography()}}, \code{\link[=get_cpod_projects]{get_cpod_projects()}}, \code{\link[=get_package]{get_package()}}, \code{\link[=get_tags]{get_tags()}} diff --git a/man/get_animal_projects.Rd b/man/get_animal_projects.Rd index 93da18ba..3e45c8fa 100644 --- a/man/get_animal_projects.Rd +++ b/man/get_animal_projects.Rd @@ -48,6 +48,7 @@ Other access functions: \code{\link[=get_acoustic_projects]{get_acoustic_projects()}}, \code{\link[=get_acoustic_receivers]{get_acoustic_receivers()}}, \code{\link[=get_animals]{get_animals()}}, +\code{\link[=get_bibliography]{get_bibliography()}}, \code{\link[=get_cpod_projects]{get_cpod_projects()}}, \code{\link[=get_package]{get_package()}}, \code{\link[=get_tags]{get_tags()}} diff --git a/man/get_animals.Rd b/man/get_animals.Rd index ff10b09a..9863852c 100644 --- a/man/get_animals.Rd +++ b/man/get_animals.Rd @@ -66,6 +66,7 @@ Other access functions: \code{\link[=get_acoustic_projects]{get_acoustic_projects()}}, \code{\link[=get_acoustic_receivers]{get_acoustic_receivers()}}, \code{\link[=get_animal_projects]{get_animal_projects()}}, +\code{\link[=get_bibliography]{get_bibliography()}}, \code{\link[=get_cpod_projects]{get_cpod_projects()}}, \code{\link[=get_package]{get_package()}}, \code{\link[=get_tags]{get_tags()}} diff --git a/man/get_bibliography.Rd b/man/get_bibliography.Rd index 9dda095e..403ba7cc 100644 --- a/man/get_bibliography.Rd +++ b/man/get_bibliography.Rd @@ -39,3 +39,16 @@ data.frame( get_bibliography() \dontshow{\}) # examplesIf} } +\seealso{ +Other access functions: +\code{\link[=get_acoustic_deployments]{get_acoustic_deployments()}}, +\code{\link[=get_acoustic_detections]{get_acoustic_detections()}}, +\code{\link[=get_acoustic_projects]{get_acoustic_projects()}}, +\code{\link[=get_acoustic_receivers]{get_acoustic_receivers()}}, +\code{\link[=get_animal_projects]{get_animal_projects()}}, +\code{\link[=get_animals]{get_animals()}}, +\code{\link[=get_cpod_projects]{get_cpod_projects()}}, +\code{\link[=get_package]{get_package()}}, +\code{\link[=get_tags]{get_tags()}} +} +\concept{access functions} diff --git a/man/get_cpod_projects.Rd b/man/get_cpod_projects.Rd index 04382f0d..8106768f 100644 --- a/man/get_cpod_projects.Rd +++ b/man/get_cpod_projects.Rd @@ -49,6 +49,7 @@ Other access functions: \code{\link[=get_acoustic_receivers]{get_acoustic_receivers()}}, \code{\link[=get_animal_projects]{get_animal_projects()}}, \code{\link[=get_animals]{get_animals()}}, +\code{\link[=get_bibliography]{get_bibliography()}}, \code{\link[=get_package]{get_package()}}, \code{\link[=get_tags]{get_tags()}} } diff --git a/man/get_package.Rd b/man/get_package.Rd index cf9fb063..327f334f 100644 --- a/man/get_package.Rd +++ b/man/get_package.Rd @@ -69,6 +69,7 @@ Other access functions: \code{\link[=get_acoustic_receivers]{get_acoustic_receivers()}}, \code{\link[=get_animal_projects]{get_animal_projects()}}, \code{\link[=get_animals]{get_animals()}}, +\code{\link[=get_bibliography]{get_bibliography()}}, \code{\link[=get_cpod_projects]{get_cpod_projects()}}, \code{\link[=get_tags]{get_tags()}} } diff --git a/man/get_tags.Rd b/man/get_tags.Rd index 3d86dccd..cde03e8a 100644 --- a/man/get_tags.Rd +++ b/man/get_tags.Rd @@ -63,6 +63,7 @@ Other access functions: \code{\link[=get_acoustic_receivers]{get_acoustic_receivers()}}, \code{\link[=get_animal_projects]{get_animal_projects()}}, \code{\link[=get_animals]{get_animals()}}, +\code{\link[=get_bibliography]{get_bibliography()}}, \code{\link[=get_cpod_projects]{get_cpod_projects()}}, \code{\link[=get_package]{get_package()}} } diff --git a/tests/testthat/_snaps/get_package/bibliography.csv b/tests/testthat/_snaps/get_package/bibliography.csv index 3a1aa447..fb3fd230 100644 --- a/tests/testthat/_snaps/get_package/bibliography.csv +++ b/tests/testthat/_snaps/get_package/bibliography.csv @@ -1,6 +1,6 @@ item,type,citation ETN,data platform,"Reubens, J., Aarestrup, K., Abecasis, D. et al. The European tracking network through time: united efforts to advance aquatic conservation in Europe. Anim Biotelemetry (2026). https://doi.org/10.1186/s40317-026-00475-z" -etn,R package,"Huybrechts P, Desmet P, Govaert S, Oldoni D, Van Hoey S (2026). etn: Access Data from the European Tracking Network. https://doi.org/10.5281/zenodo.15235747, R package version 3.0.0.9000, https://inbo.github.io/etn/." +etn,R package,"Huybrechts P, Desmet P, Govaert S, Oldoni D, Van Hoey S. etn: Access Data from the European Tracking Network. https://doi.org/10.5281/zenodo.15235747, R package version 3.0.0.9000, https://inbo.github.io/etn/." 2014_demer,animal project,"Pauwels, I.; Baeyens, R.; De Maerteleire, N.; Desmet, P.; Gelaude, E.; Milotic, T.; Pieters, S.; Reyserhove, L.; Robberechts, K.; Verhelst, P.; Coeck, J.; (2020): 2014_DEMER - Acoustic telemetry data for four fish species in the Demer river (Belgium). Marine Data Archive. https://doi.org/10.14284/432" albert,acoustic project, demer,acoustic project, diff --git a/tests/testthat/test-check_value.R b/tests/testthat/test-check_value.R index 066b997f..e93e0f70 100644 --- a/tests/testthat/test-check_value.R +++ b/tests/testthat/test-check_value.R @@ -1,18 +1,19 @@ test_that("check_value() returns error for incorrect values", { expect_error( check_value("invalid", c("a", "b")), - "Can't find value `invalid` in: a, b", - fixed = TRUE + class = "etn_value_not_found" ) expect_error( check_value(c("a", "invalid"), c("a", "b")), - "Can't find value `a` and/or `invalid` in: a, b", - fixed = TRUE + class = "etn_value_not_found" ) expect_error( check_value("invalid", c("a", "b"), name = "param_name"), - "Can't find param_name `invalid` in: a, b", - fixed = TRUE + class = "etn_value_not_found" + ) + expect_error( + check_value(c("missing", "misval"), c("a", "b", "c")), + class = "etn_value_not_found" ) }) @@ -29,9 +30,8 @@ test_that("check_value() returns x for correct values", { test_that("check_value() can ignore case", { expect_error( - check_value("A", c("a", "B")), - "Can't find value `A` in: a, B", - fixed = TRUE + check_value("AAAA", c("aaaa", "BBBB")), + class = "etn_value_not_found" ) expect_identical( check_value("A", c("a", "B"), lowercase = TRUE), @@ -51,7 +51,22 @@ test_that("check_value() can handle NA in reference", { expect_error( check_value("invalid", c("A", NA, "C")), - "Can't find value `invalid` in: A, C", - fixed = TRUE + class = "etn_value_not_found" + ) +}) + +test_that("check_value() can offer a suggestion for typos", { + expect_error( + check_value("seeschelde", c("demer", "dijle", "zeeschelde")), + class = "etn_value_not_found_suggest" + ) +}) + +test_that("check_value() offers suggestions for multiple typos", { + expect_error( + check_value(x = c("2000_Loire", "seeschelde"), + y = c("2011_Loire", "zeeschelde") + ), + class = "etn_value_not_found_suggest" ) })