Add new function: get_bibliography()

DESCRIPTION

@@ -63,6 +63,7 @@ Suggests:
     leaflet,
     lubridate,
     pak,
+    qs2,
     rmarkdown,
     testthat (>= 3.0.0),
     tidyr,

NAMESPACE

@@ -9,6 +9,7 @@ export(get_acoustic_projects)
 export(get_acoustic_receivers)
 export(get_animal_projects)
 export(get_animals)
+export(get_bibliography)
 export(get_cpod_projects)
 export(get_package)
 export(get_tags)

NEWS.md

@@ -13,6 +13,8 @@
   * [`dwc:identificationVerificationStatus`](http://rs.tdwg.org/dwc/terms/identificationVerificationStatus) has been added and is set to `"verified by expert"` for all records, since the taxon is assumed to be well-known before the tag was attached.
   * The animal sex, life stage and weight are added to an Extended Measurement Or Facts extension file (`emof.csv`), for better support with OBIS (#555).
 * The [function reference](https://inbo.github.io/etn/reference/index.html) has been reorganized (#549)
+* New `get_bibliography()` creates a bibliography (ETN data platform, R package, animal projects and acoustic projects) for a data.frame of detections, e.g. as returned by `get_acoustic_detections()` or read from a Data Package (#587).
+* `get_package()` now includes a bibliography resource (replacing the previous references resource), built with `get_bibliography()` (#587).
 
 # etn 3.0.0
 

R/add_resource.R

@@ -15,7 +15,7 @@
 #' @noRd
 add_resource <- function(package, resource_name, data) {
   # Check resource names
-  allowed_names <- c("animals", "deployments", "detections", "receivers", "tags", "references")
+  allowed_names <- c("animals", "deployments", "detections", "receivers", "tags", "bibliography")
   if (!resource_name %in% allowed_names) {
     cli::cli_abort(
       c(

R/download_acoustic_dataset.R

@@ -4,10 +4,10 @@
 #' `r lifecycle::badge("deprecated")`
 #'
 #' `download_acoustic_dataset()` is deprecated. Please use [get_package()]
-#' instead, which is more versatile, adds field definition and references, and
-#' returns a Data Package object that can be passed to other functions.
-#' Note that [get_package()] does not support filtering on `scientific_name` or
-#' print summary statistics.
+#' instead, which is more versatile, adds field definition and a bibliography,
+#' and returns a Data Package object that can be passed to other functions. Note
+#' that [get_package()] does not support filtering on `scientific_name` or print
+#' summary statistics.
 #'
 #' This function allows you to download all acoustic data related to an
 #' **animal project** as a data package that can be deposited in a research data

R/get_bibliography.R

@@ -0,0 +1,123 @@
+#' Generate a bibliography for a data.frame of detections
+#'
+#' This function generates a bibliography for a data.frame containing
+#' detections, including citations for the ETN platform, the etn R package, and
+#' any animal and acoustic projects present in the input data.frame.
+#'
+#' @param x A data.frame containing at least the columns `animal_project_code`
+#'   and `acoustic_project_code`. For example a data.frame returned by
+#'   `get_detections()`.
+#'
+#' @returns A data.frame with three columns: `item`, `type`, and `citation`. The
+#'   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()
+#' # Create a bibliography for a data.frame created by get_detections()
+#' my_detections <-
+#'   get_acoustic_detections(scientific_name = "Mola mola")
+#'   get_bibliography(my_detections)
+#'
+#' # Or from a frictionless datapackage containing detections
+#' read_resource(example_dataset(), "detections") |> get_bibliography()
+#'
+#' # Altough mainly meant for the above use cases, you can also provide any
+#' # data.frame as long as the project code columns are present.
+#' data.frame(
+#'   animal_project_code = "2014_demer", acoustic_project_code = "demer" ) |>
+#'   get_bibliography()
+get_bibliography <- function(x) {
+  # Check inputs ------------------------------------------------------------
+
+  if(!is.data.frame(x)){
+    cli::cli_abort(
+      "x must be a data.frame",
+      class = "etn_error_invalid_input_type"
+    )
+  }
+
+  # Check if at least the required columns are present
+  required_columns <- c("animal_project_code", "acoustic_project_code")
+  if (!all(required_columns %in% colnames(x))) {
+    cli::cli_abort(
+      "x must contain the following columns: {.val {required_columns}}",
+      class = "etn_error_missing_columns"
+    )
+  }
+
+  # Check that all the provided project codes can be found in the database
+  provided_animal_project_codes <-
+    dplyr::pull(x, "animal_project_code") |>
+    unique()
+  # Check that all provided project codes are valid
+  provided_acoustic_project_codes <-
+    dplyr::pull(x, "acoustic_project_code") |>
+    unique()
+
+  animal_project_codes <-
+    check_value(
+      provided_animal_project_codes,
+      list_animal_project_codes(),
+      name = "animal_project_code"
+    )
+
+  acoustic_project_codes <-
+    check_value(
+      provided_acoustic_project_codes,
+      list_acoustic_project_codes(),
+      name = "acoustic_project_code"
+    )
+
+
+  # Fetch project citations -------------------------------------------------
+  animal_citations <- get_animal_projects(
+    animal_project_code = animal_project_codes,
+    citation = TRUE
+  ) |>
+    dplyr::select(dplyr::all_of(c("project_code", "citation")))
+
+  acoustic_citations <- get_acoustic_projects(
+    acoustic_project_code = acoustic_project_codes,
+    citation = TRUE
+  ) |>
+    dplyr::select(dplyr::all_of(c("project_code", "citation")))
+
+  # Format output -----------------------------------------------------------
+
+  etn_ref <- paste0(
+    "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"
+  )
+
+  list(
+    `animal project` = animal_citations,
+    `acoustic project` = acoustic_citations
+  ) |>
+    # Rename columns
+    purrr::map(\(df) {
+      dplyr::rename(df, item = "project_code")
+    }) |>
+    dplyr::bind_rows(.id = "type") |>
+    dplyr::add_row(
+      .before = 1L,
+      item = "ETN",
+      type = "data platform",
+      citation = etn_ref
+    ) |>
+    dplyr::add_row(
+      .after = 1L,
+      item = "etn",
+      type = "R package",
+      citation = etn_citation()
+    ) |>
+    # Set columns in correct order
+    dplyr::relocate(
+      dplyr::all_of(c("item", "type", "citation"))
+    )
+}

R/get_package.R

@@ -23,7 +23,7 @@
 #'   these did not detect the selected animals.
 #' - `receivers`: Acoustic receivers for the selected deployments, as returned
 #'   by [get_acoustic_receivers()].
-#' - `references`: References for ETN, the R package, the animal project and
+#' - `Bibliography`: A bibliography for ETN, the R package, the animal project and
 #'   acoustic projects that returned detections.
 #'   It is recommended to cite these when using the dataset.
 #'
@@ -135,29 +135,9 @@ get_package <- function(animal_project_code) {
     receiver_id = receiver_ids
   )
 
-  ## References ----
-  cli::cli_li("Getting {.val references}.")
-  etn_ref <- paste(
-    "European Tracking Network - Data Platform.",
-    "Flanders Marine Institute (VLIZ)"
-  )
-  animal_ref <-
-    get_animal_projects(
-      animal_project_code = animal_project_code,
-      citation = TRUE
-    ) |>
-    dplyr::pull("citation")
-  acoustic_refs <-
-    get_acoustic_projects(
-      acoustic_project_code = acoustic_project_codes,
-      citation = TRUE
-    ) |>
-    dplyr::pull("citation")
-  references <-
-    dplyr::tibble(
-      reference_for = c("ETN", animal_project_code, acoustic_project_codes),
-      reference = c(etn_ref, animal_ref, acoustic_refs)
-    )
+  ## Bibliography ----
+  cli::cli_li("Getting {.val bibliography}.")
+  bibliography <- get_bibliography(detections)
 
   cli::cli_end()
 
@@ -180,7 +160,7 @@ get_package <- function(animal_project_code) {
     add_resource("detections", detections) |>
     add_resource("deployments", deployments) |>
     add_resource("receivers", receivers) |>
-    add_resource("references", references) |>
+    add_resource("bibliography", bibliography) |>
     append(c(
       id = doi,
       name = tolower(animal_project_code)

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,33 @@ 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
+#'
+#' This function retrieves the citation information for the `etn` package and
+#' formats it as plain text.
+#'
+#' @returns A character vector containing the citation information for the `etn`
+#'   package in plain text format.
+#'
+#' @family helper functions
+#' @noRd
+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 ----
@@ -293,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

inst/extdata/field_definitions.tsv

@@ -252,5 +252,6 @@ tags	tag_type		Type of tag attached to animal. Fixed options: sensor-tag, id-tag
 tags	telemetry_type		Type of tag attached to animal. Fixed options: Id-tag or sensor-tag.	string		id-tag	
 tags	type		Type of the tag.	string		sensor-tag	
 tags	weight			number			
-references	reference_for			string			
-references	reference			string			
+bibliography	item			string		2014_demer	
+bibliography	type			string		animal project	
+bibliography	citation			string		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