From b14c8eff56dd3ddce0284d6094bf7909a8ecd96a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Pawe=C5=82=20Armatys?= Date: Fri, 24 Oct 2025 09:20:50 +0200 Subject: [PATCH 01/27] Updated OAuth2 authentication process and token management --- DESCRIPTION | 2 +- NAMESPACE | 1 + R/CONSTANTS.R | 26 ++- R/auth_service.R | 111 ++++++++++ R/auth_state.R | 74 +++++++ R/auth_utils.R | 134 ++++++++++++ R/login_db.R | 230 ++++++++------------- R/logout_db.R | 29 +-- R/make_default_request.R | 49 +++-- R/token_helpers.R | 61 ++++++ R/whoami.R | 57 +++++ README.Rmd | 17 +- man/login_db.Rd | 17 +- man/logout_db.Rd | 2 +- man/make_default_request.Rd | 22 +- man/whoami.Rd | 29 +++ tests/testthat/test-login_db.R | 44 ++-- tests/testthat/test-logout_db.R | 9 +- tests/testthat/test-make_default_request.R | 15 ++ tests/testthat/test-whoami.R | 29 +++ 20 files changed, 729 insertions(+), 229 deletions(-) create mode 100644 R/auth_service.R create mode 100644 R/auth_state.R create mode 100644 R/auth_utils.R create mode 100644 R/token_helpers.R create mode 100644 R/whoami.R create mode 100644 man/whoami.Rd create mode 100644 tests/testthat/test-whoami.R diff --git a/DESCRIPTION b/DESCRIPTION index a91bbb3d..dd58e65b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,4 +46,4 @@ Config/testthat/edition: 3 Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.1 +RoxygenNote: 7.3.3 diff --git a/NAMESPACE b/NAMESPACE index 0a4166b8..9b6da36c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -49,6 +49,7 @@ export(make_login_client) export(search_for_funder) export(search_for_keywords) export(search_for_tags) +export(whoami) importFrom(lifecycle,deprecated) importFrom(magrittr,"%>%") importFrom(methods,is) diff --git a/R/CONSTANTS.R b/R/CONSTANTS.R index 07b70d86..ebe26b03 100644 --- a/R/CONSTANTS.R +++ b/R/CONSTANTS.R @@ -2,6 +2,8 @@ #' #' +# Legacy endpoints (temporary until all functions migrated) ------------------- + API_CONSTANTS <- "https://nyu.databrary.org/api/constants" CREATE_SLOT <- @@ -47,8 +49,8 @@ GET_ASSET_BY_ID <- "https://nyu.databrary.org/api/asset/%s" GET_ASSET_BY_VOLUME_SESSION_ID <- "https://nyu.databrary.org/api/volume/%s/slot/%s/asset/%s" -LOGIN <- "https://nyu.databrary.org/api/user/login" -LOGOUT <- "https://nyu.databrary.org/api/user/logout" +# LOGIN <- "https://nyu.databrary.org/api/user/login" +# LOGOUT <- "https://nyu.databrary.org/api/user/logout" QUERY_SLOT <- "https://nyu.databrary.org/api/slot/%s/-?records&assets&excerpts&tags&comments" @@ -62,9 +64,9 @@ UPLOAD_CHUNK <- "https://nyu.databrary.org/api/upload" UPDATE_SLOT <- "https://nyu.databrary.org/api/slot/%s" # Authentication parameters -USER_AGENT <- - "databraryr (https://cran.r-project.org/package=databraryr)" -KEYRING_SERVICE <- 'org.databrary.databraryr' +# USER_AGENT <- +# "databraryr (https://cran.r-project.org/package=databraryr)" +# KEYRING_SERVICE <- 'org.databrary.databraryr' # httr2 request parameters RETRY_LIMIT <- 3 @@ -72,3 +74,17 @@ RETRY_WAIT_TIME <- 1 # seconds RETRY_BACKOFF <- 2 # exponential backoff REQUEST_TIMEOUT <- 5 # seconds REQUEST_TIMEOUT_VERY_LONG <- 600 + +# Base host ----------------------------------------------------------------- + +DATABRARY_BASE_URL <- Sys.getenv("DATABRARY_BASE_URL", "https://api.stg-databrary.its.nyu.edu") + +# OAuth endpoints ------------------------------------------------------------- + +OAUTH_TOKEN_URL <- sprintf("%s/o/token/", DATABRARY_BASE_URL) +OAUTH_TEST_URL <- sprintf("%s/oauth2/test/", DATABRARY_BASE_URL) + +# Authentication parameters --------------------------------------------------- + +USER_AGENT <- Sys.getenv("USER_AGENT", "SRW$*Kxy2nYdyo4LozoGV#i6LvH/") +KEYRING_SERVICE <- 'org.databrary.databraryr' diff --git a/R/auth_service.R b/R/auth_service.R new file mode 100644 index 00000000..b747ca8e --- /dev/null +++ b/R/auth_service.R @@ -0,0 +1,111 @@ +# OAuth2 network operations --------------------------------------------------- + +httr2_error_message <- function(resp) { + if (is.null(resp)) { + return("Request failed before receiving a response.") + } + status <- httr2::resp_status(resp) + if (status < 400) { + return(NULL) + } + body <- try(httr2::resp_body_json(resp), silent = TRUE) + if (!inherits(body, "try-error") && is.list(body)) { + fields <- c(body$error_description, body$error, body$detail) + fields <- fields[!vapply(fields, is_missing_string, logical(1))] + if (length(fields)) { + return(paste0("HTTP ", status, ": ", fields[[1]])) + } + } + sprintf("HTTP %s returned with empty error body.", status) +} + +#' @noRd +oauth_password_grant <- function(username, + password, + client_id, + client_secret, + vb = FALSE) { + assertthat::assert_that(assertthat::is.string(username)) + assertthat::assert_that(assertthat::is.string(password)) + assertthat::assert_that(assertthat::is.string(client_id)) + assertthat::assert_that(assertthat::is.string(client_secret)) + + req <- make_default_request(with_token = FALSE) |> + httr2::req_url(OAUTH_TOKEN_URL) + + resp <- tryCatch( + req |> + httr2::req_body_form( + grant_type = "password", + username = username, + password = password, + client_id = client_id, + client_secret = client_secret + ) |> + httr2::req_perform(), + error = function(err) { + if (vb) message("OAuth token request failed: ", conditionMessage(err)) + NULL + } + ) + + if (is.null(resp)) { + return(NULL) + } + + if (httr2::resp_status(resp) >= 400) { + if (vb) message(httr2_error_message(resp)) + return(NULL) + } + + payload <- httr2::resp_body_json(resp) + list( + access_token = payload$access_token, + refresh_token = if (is.null(payload$refresh_token)) NULL else payload$refresh_token, + expires_in = if (is.null(payload$expires_in)) 3600 else payload$expires_in + ) +} + +#' @noRd +oauth_refresh_grant <- function(refresh_token, + client_id, + client_secret, + vb = FALSE) { + assertthat::assert_that(assertthat::is.string(refresh_token)) + assertthat::assert_that(assertthat::is.string(client_id)) + assertthat::assert_that(assertthat::is.string(client_secret)) + + req <- make_default_request() |> + httr2::req_url(OAUTH_TOKEN_URL) + + resp <- tryCatch( + req |> + httr2::req_body_form( + grant_type = "refresh_token", + refresh_token = refresh_token, + client_id = client_id, + client_secret = client_secret + ) |> + httr2::req_perform(), + error = function(err) { + if (vb) message("OAuth refresh request failed: ", conditionMessage(err)) + NULL + } + ) + + if (is.null(resp)) { + return(NULL) + } + + if (httr2::resp_status(resp) >= 400) { + if (vb) message(httr2_error_message(resp)) + return(NULL) + } + + payload <- httr2::resp_body_json(resp) + list( + access_token = payload$access_token, + refresh_token = if (is.null(payload$refresh_token)) refresh_token else payload$refresh_token, + expires_in = if (is.null(payload$expires_in)) 3600 else payload$expires_in + ) +} diff --git a/R/auth_state.R b/R/auth_state.R new file mode 100644 index 00000000..899b8ff4 --- /dev/null +++ b/R/auth_state.R @@ -0,0 +1,74 @@ +# Token state management ------------------------------------------------------- + +.databrary_token_env <- new.env(parent = emptyenv()) + +#' @noRd +set_token_bundle <- function(access_token, + refresh_token = NULL, + expires_in = NULL, + issued_at = Sys.time(), + client_id = NULL, + client_secret = NULL, + username = NULL) { + assertthat::assert_that(assertthat::is.string(access_token)) + .databrary_token_env$access_token <- access_token + .databrary_token_env$refresh_token <- if (is_missing_string(refresh_token)) NULL else refresh_token + .databrary_token_env$issued_at <- issued_at + if (is.null(expires_in)) { + .databrary_token_env$expires_at <- NULL + } else { + assertthat::assert_that(is.numeric(expires_in), length(expires_in) == 1) + .databrary_token_env$expires_at <- issued_at + as.difftime(as.numeric(expires_in), units = "secs") + } + .databrary_token_env$client_id <- if (is_missing_string(client_id)) NULL else client_id + .databrary_token_env$client_secret <- if (is_missing_string(client_secret)) NULL else client_secret + .databrary_token_env$username <- if (is_missing_string(username)) NULL else username + invisible(.databrary_token_env) +} + +#' @noRd +get_token_bundle <- function() { + if (!is.null(.databrary_token_env$access_token)) { + return(list( + access_token = .databrary_token_env$access_token, + refresh_token = .databrary_token_env$refresh_token, + expires_at = .databrary_token_env$expires_at, + issued_at = .databrary_token_env$issued_at, + client_id = .databrary_token_env$client_id, + client_secret = .databrary_token_env$client_secret, + username = .databrary_token_env$username + )) + } + NULL +} + +#' @noRd +clear_token_bundle <- function() { + rm(list = ls(.databrary_token_env), envir = .databrary_token_env) + invisible(NULL) +} + +#' @noRd +token_should_refresh <- function() { + bundle <- get_token_bundle() + if (is.null(bundle)) { + return(FALSE) + } + expires_at <- bundle$expires_at + if (is.null(expires_at)) { + return(FALSE) + } + now <- Sys.time() + now >= (expires_at - as.difftime(30, units = "secs")) +} + +#' @noRd +require_access_token <- function() { + bundle <- get_token_bundle() + if (is.null(bundle) || is_missing_string(bundle$access_token)) { + stop("No access token available. Please call login_db() first.", call. = FALSE) + } + bundle$access_token +} + + diff --git a/R/auth_utils.R b/R/auth_utils.R new file mode 100644 index 00000000..46230bac --- /dev/null +++ b/R/auth_utils.R @@ -0,0 +1,134 @@ +# Internal helpers for authentication and credential management + +#' @noRd +CREDENTIAL_ENV_VARS <- c( + email = "DATABRARY_LOGIN", + password = "DATABRARY_PASSWORD", + client_id = "DATABRARY_CLIENT_ID", + client_secret = "DATABRARY_CLIENT_SECRET" +) + +#' @noRd +is_missing_string <- function(x) { + if (is.null(x) || length(x) == 0) { + return(TRUE) + } + value <- x[[1]] + if (is.na(value)) { + return(TRUE) + } + if (!is.character(value)) { + return(FALSE) + } + trimmed <- trimws(value) + identical(trimmed, "") +} + +#' @noRd +try_keyring_get <- function(service, username, vb = FALSE) { + if (!keyring::has_keyring_support()) { + return(NULL) + } + if (is_missing_string(username)) { + return(NULL) + } + result <- try(keyring::key_get(service = service, username = username), silent = TRUE) + if (inherits(result, "try-error")) { + if (vb) { + message("No keyring entry for service='", service, "' and username='", username, "'.") + } + return(NULL) + } + if (is_missing_string(result)) { + return(NULL) + } + result +} + +#' @noRd +store_keyring_value <- function(service, username, value, vb = FALSE) { + if (!keyring::has_keyring_support()) { + return(FALSE) + } + if (is_missing_string(value) || is_missing_string(username)) { + return(FALSE) + } + outcome <- try(keyring::key_set_with_value( + service = service, + username = username, + password = value + ), silent = TRUE) + if (inherits(outcome, "try-error")) { + if (vb) { + message("Unable to store keyring entry for service='", service, "' and username='", username, "'.") + } + return(FALSE) + } + if (vb) { + message("Stored credentials in keyring service='", service, "'.") + } + TRUE +} + +#' @noRd +resolve_credential_value <- function(label, + value, + prompt_label, + service, + username = NULL, + overwrite, + vb) { + if (!is_missing_string(value)) { + assertthat::assert_that(assertthat::is.string(value)) + return(value) + } + + # Check environment variable using the static map + env_var_name <- CREDENTIAL_ENV_VARS[[label]] + env_value <- Sys.getenv(env_var_name, NA_character_) + if (!is.na(env_value) && nzchar(env_value)) { + return(env_value) + } + + # For email, skip keyring lookup since email is the identifier used for other keyring lookups + # Only do keyring lookup for client_id and other credentials that are actually stored + if (!is_missing_string(username) && !overwrite && label != "email") { + stored <- try_keyring_get(service = service, username = username, vb = vb) + if (!is.null(stored)) { + return(stored) + } + } + + message("Please enter your ", prompt_label, ".") + readline(prompt = paste0(prompt_label, ": ")) +} + +#' @noRd +resolve_secret_value <- function(label, + value, + prompt_label, + service, + username, + overwrite, + vb) { + if (!is_missing_string(value)) { + assertthat::assert_that(assertthat::is.string(value)) + return(value) + } + + # Check environment variable using the static map + env_var_name <- CREDENTIAL_ENV_VARS[[label]] + env_value <- Sys.getenv(env_var_name, NA_character_) + if (!is.na(env_value) && nzchar(env_value)) { + return(env_value) + } + + if (!overwrite) { + recovered <- try_keyring_get(service = service, username = username, vb = vb) + if (!is.null(recovered)) { + return(recovered) + } + } + + getPass::getPass(paste0("Please enter your ", prompt_label, " ")) +} diff --git a/R/login_db.R b/R/login_db.R index 75c47d82..67b0251b 100644 --- a/R/login_db.R +++ b/R/login_db.R @@ -1,25 +1,20 @@ -#' @eval options::as_params() -#' @name options_params -#' -NULL - #' Log In To Databrary.org. #' #' @param email Databrary account email address. #' @param password Databrary password (not recommended as it will displayed #' as you type) -#' @param store A boolean value. If TRUE store/retrieve credentials from the -#' system keyring/keychain. -#' @param overwrite A boolean value. If TRUE and store is TRUE, overwrite/ -#' update stored credentials in keyring/keychain. -#' @param SERVICE A character label for stored credentials in the keyring. -#' Default is "databrary" -#' @param rq An `http` request object. Defaults to NULL. -#' +#' @param client_id OAuth2 client identifier. +#' @param client_secret OAuth2 client secret. +#' @param store A boolean value. If TRUE store/retrieve credentials from the +#' system keyring/keychain. +#' @param overwrite A boolean value. If TRUE and store is TRUE, overwrite/ +#' update stored credentials in keyring/keychain. +#' @param SERVICE A character label for stored credentials in the keyring. +#' Default is `org.databrary.databraryr`. +#' @param vb Show verbose messages. +#' #' @returns Logical value indicating whether log in is successful or not. -#' -#' @inheritParams options_params -#' +#' #' @examplesIf interactive() #' login_db() # Queries user for email and password interactively. #' @examples @@ -34,145 +29,92 @@ NULL #' @export login_db <- function(email = NULL, password = NULL, + client_id = NULL, + client_secret = NULL, store = FALSE, overwrite = FALSE, - vb = options::opt("vb"), SERVICE = KEYRING_SERVICE, - rq = NULL) { - # Check parameters - assertthat::assert_that(length(store) == 1) - assertthat::assert_that(is.logical(store)) - - assertthat::assert_that(length(overwrite) == 1) - assertthat::assert_that(is.logical(overwrite)) - - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(length(SERVICE) == 1) - assertthat::assert_that(is.character(SERVICE)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - # Handle NULL request - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - } - rq <- databraryr::make_default_request() - } - + vb = options::opt("vb")) { + assertthat::assert_that(length(store) == 1, is.logical(store)) + assertthat::assert_that(length(overwrite) == 1, is.logical(overwrite)) + assertthat::assert_that(length(vb) == 1, is.logical(vb)) + assertthat::assert_that(length(SERVICE) == 1, is.character(SERVICE)) + # If the user wants to store or use their stored credentials, # check for keyring support if (store) { assertthat::assert_that(keyring::has_keyring_support(), msg = "No keyring support; please use store=FALSE") } - - # Check or get email - if (!is.null(email)) { - assertthat::assert_that(assertthat::is.string(email)) - } else { - message("Please enter your Databrary user ID (email).") - email <- readline(prompt = "Email: ") - } - - do_collect_password <- TRUE - - if (!is.null(password)) { - assertthat::assert_that(assertthat::is.string(password)) - do_collect_password <- FALSE - } - - # If the user wants to store or use their stored credentials and - # doesn't provide a password - if (store && is.null(password) && !overwrite) { - if (vb) - message("Retrieving password for service='", - SERVICE, - "' from keyring.") - kl <- keyring::key_list(service = SERVICE) - # Make sure our service is in the keyring - if (exists('kl') && is.data.frame(kl)) { - # If it is under the email entered, keep it to try later and not - # collect it here - password <- - try(keyring::key_get(service = SERVICE, username = email), - silent = TRUE) - if ("try-error" %in% class(password)) { - do_collect_password <- TRUE - if (vb) - message("No password found in keyring for service='", SERVICE, ".") - } else { - do_collect_password <- FALSE - if (vb) - message("Password retrieved from keyring.") - } - } else { - if (vb) - message("Error retrieving keyring data for service='", - SERVICE, - "'.") - } - } - - # If we need to, securely collect the password - if (do_collect_password) { - password <- - getPass::getPass("Please enter your Databrary password ") - } - - is_login_successful <- FALSE - - if (is.null(rq)) - rq <- make_default_request() - - rq <- rq %>% - httr2::req_url(LOGIN) %>% - httr2::req_body_json(list(email = email, password = password)) - - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) - NULL + + email_value <- resolve_credential_value( + label = "email", + value = email, + prompt_label = "Databrary user ID (email)", + service = SERVICE, + overwrite = overwrite, + vb = vb ) - - if (!is.null(resp) & httr2::resp_status(resp) == 200) { - is_login_successful <- TRUE - } - - # If the username/password was successful and the user wanted to - # store their credentials - - # Store them in the keyring - if (is_login_successful) { - if (store && (do_collect_password || overwrite)) { - keyring::key_set_with_value(service = SERVICE, - username = email, - password = password) - if (vb) - message(paste0("Login successful; password stored in keyring/keychain")) - } else { - if (vb) - message(paste("Login successful.")) - } - return(TRUE) + + password_value <- resolve_secret_value( + label = "password", + value = password, + prompt_label = "Databrary password", + service = SERVICE, + username = paste0(email_value, "::password"), + overwrite = overwrite, + vb = vb + ) + + client_id_value <- resolve_credential_value( + label = "client_id", + value = client_id, + prompt_label = "OAuth client ID", + service = SERVICE, + username = paste0(email_value, "::client_id"), + overwrite = overwrite, + vb = vb + ) + + client_secret_value <- resolve_secret_value( + label = "client_secret", + value = client_secret, + prompt_label = "OAuth client secret", + service = SERVICE, + username = paste0(email_value, "::client_secret"), + overwrite = overwrite, + vb = vb + ) + + token <- oauth_password_grant( + username = email_value, + password = password_value, + client_id = client_id_value, + client_secret = client_secret_value, + vb = vb + ) + + if (is.null(token)) { + if (vb) message("Login failed; see previous messages for details.") + return(FALSE) } - + + set_token_bundle( + access_token = token$access_token, + refresh_token = token$refresh_token, + expires_in = token$expires_in, + issued_at = Sys.time(), + client_id = client_id_value, + client_secret = client_secret_value, + username = email_value + ) + if (store) { - if (vb) - message( - paste0( - 'Login failed; nothing stored in keyring; HTTP status ', - httr2::resp_status(resp), - '\n' - ) - ) - } else { - if (vb) - message(paste0('Login failed; HTTP status ', - httr2::resp_status(resp), '\n')) + store_keyring_value(service = SERVICE, username = paste0(email_value, "::password"), value = password_value, vb = vb) + store_keyring_value(service = SERVICE, username = paste0(email_value, "::client_id"), value = client_id_value, vb = vb) + store_keyring_value(service = SERVICE, username = paste0(email_value, "::client_secret"), value = client_secret_value, vb = vb) } - - return(FALSE) + + if (vb) message("Login successful.") + TRUE } diff --git a/R/logout_db.R b/R/logout_db.R index 6c15304a..4cf1ea11 100644 --- a/R/logout_db.R +++ b/R/logout_db.R @@ -16,26 +16,17 @@ NULL #' logout_db() #' } #' @export -logout_db <- function(vb = options::opt("vb"), rq = NULL){ +logout_db <- function(vb = options::opt("vb")) { + assertthat::assert_that(is.logical(vb), length(vb) == 1) - assertthat::assert_that(is.logical(vb)) - - if (is.null(rq)) { - if (vb) message("Empty request. Generating new one.") - rq <- databraryr::make_default_request() + bundle <- get_token_bundle() + if (is.null(bundle)) { + if (vb) message("No active session; nothing to log out from.") + return(TRUE) } - rq <- rq %>% - httr2::req_url(LOGOUT) - - r <- httr2::req_perform(rq) - delete_cookie <- file.remove(rq$options$cookiefile) - if (httr2::resp_status(r) == 200 & delete_cookie) { - if (vb) message('Logout Successful.') - TRUE - } else { - if (vb) message(paste0('Logout Failed, HTTP status: ', - httr2::resp_status(r), '.\n')) - FALSE - } + clear_token_bundle() + + if (vb) message("Logout successful.") + TRUE } diff --git a/R/make_default_request.R b/R/make_default_request.R index 290de5c8..aab67b5d 100644 --- a/R/make_default_request.R +++ b/R/make_default_request.R @@ -1,17 +1,42 @@ -#' Set default httr request parameters. +#' Set base request defaults for Databrary API. +#' +#' Creates an `httr2` request with the package's default options, including +#' base URL, user agent, Accept header, and timeout tuned for the Django API. +#' +#' @inheritParams options_params +#' @param with_token Should the request include an OAuth2 `Authorization` header? +#' Defaults to `TRUE` since all API calls now require authentication. +#' @param refresh When `with_token = TRUE`, determines whether to refresh the +#' cached token if it is near expiry. Defaults to `TRUE`. +#' +#' @returns An `httr2_request` object configured for the Databrary API. #' -#' `make_default_request` sets default parameters for httr requests. -#' @returns An `httr2` request object. -#' #' @examples #' make_default_request() #' @export -make_default_request <- function() { - path <- tempfile() - rq <- httr2::request(DATABRARY_API) %>% - httr2::req_user_agent(USER_AGENT) %>% - httr2::req_retry(max_tries = RETRY_LIMIT) %>% - httr2::req_timeout(REQUEST_TIMEOUT) %>% - httr2::req_cookie_preserve(path) - rq +make_default_request <- function(with_token = TRUE, + refresh = TRUE, + vb = options::opt("vb")) { + assertthat::assert_that(is.logical(with_token), length(with_token) == 1) + assertthat::assert_that(is.logical(refresh), length(refresh) == 1) + assertthat::assert_that(is.logical(vb), length(vb) == 1) + + req <- httr2::request(DATABRARY_BASE_URL) |> + httr2::req_user_agent(USER_AGENT) |> + httr2::req_retry(max_tries = RETRY_LIMIT) |> + httr2::req_headers("Accept" = "application/json") |> + httr2::req_timeout(REQUEST_TIMEOUT) + + if (!isTRUE(with_token)) { + return(req) + } + + token <- if (isTRUE(refresh)) { + bundle <- ensure_valid_token(refresh = TRUE, vb = vb) + bundle$access_token + } else { + require_access_token() + } + + httr2::req_headers(req, Authorization = paste("Bearer", token)) } \ No newline at end of file diff --git a/R/token_helpers.R b/R/token_helpers.R new file mode 100644 index 00000000..f901f375 --- /dev/null +++ b/R/token_helpers.R @@ -0,0 +1,61 @@ +# Token-aware request helpers ------------------------------------------------- + +#' @noRd +add_bearer_token <- function(rq) { + assertthat::assert_that(inherits(rq, "httr2_request")) + access_token <- require_access_token() + httr2::req_headers(rq, Authorization = paste("Bearer", access_token)) +} + +#' @noRd +ensure_valid_token <- function(refresh = TRUE, + client_id = NULL, + client_secret = NULL, + vb = FALSE) { + bundle <- get_token_bundle() + if (is.null(bundle)) { + stop("No OAuth token available; call login_db() first.", call. = FALSE) + } + + if (!token_should_refresh()) { + return(bundle) + } + + if (!refresh) { + stop("Access token expired and refresh disabled.", call. = FALSE) + } + + refresh_token <- bundle$refresh_token + if (is_missing_string(refresh_token)) { + stop("Access token expired and no refresh token available.", call. = FALSE) + } + + refresh_client_id <- if (is_missing_string(client_id)) bundle$client_id else client_id + refresh_client_secret <- if (is_missing_string(client_secret)) bundle$client_secret else client_secret + + refreshed <- oauth_refresh_grant( + refresh_token = refresh_token, + client_id = refresh_client_id, + client_secret = refresh_client_secret, + vb = vb + ) + + if (is.null(refreshed)) { + clear_token_bundle() + stop("Token refresh failed; please re-authenticate with login_db().", call. = FALSE) + } + + set_token_bundle( + access_token = refreshed$access_token, + refresh_token = refreshed$refresh_token, + expires_in = refreshed$expires_in, + issued_at = Sys.time(), + client_id = refresh_client_id, + client_secret = refresh_client_secret, + username = bundle$username + ) + + get_token_bundle() +} + + diff --git a/R/whoami.R b/R/whoami.R new file mode 100644 index 00000000..5c39c3c6 --- /dev/null +++ b/R/whoami.R @@ -0,0 +1,57 @@ +#' Retrieve metadata about the authenticated Databrary user. +#' +#' Calls the Django `/oauth2/test/` endpoint to report the current authentication +#' method and user profile. Requires a valid OAuth2 access token acquired via +#' `login_db()`. +#' +#' @inheritParams options_params +#' @param refresh Whether to attempt automatic token refresh when the current +#' access token is expired. Defaults to `TRUE`. +#' +#' @returns A list containing `auth_method` and `user` fields (both lists) or +#' `NULL` if the request fails due to lack of authentication. +#' +#' @examples +#' \\dontrun{ +#' login_db() +#' whoami() +#' } +#' @export +whoami <- function(refresh = TRUE, vb = options::opt("vb")) { + assertthat::assert_that(is.logical(refresh), length(refresh) == 1) + assertthat::assert_that(is.logical(vb), length(vb) == 1) + + req <- tryCatch( + make_default_request(refresh = refresh, vb = vb), + error = function(err) { + if (vb) message("Authentication required: ", conditionMessage(err)) + NULL + } + ) + + if (is.null(req)) { + return(NULL) + } + + resp <- tryCatch( + httr2::req_url(req, OAUTH_TEST_URL) |> + httr2::req_perform(), + error = function(err) { + if (vb) message("whoami request failed: ", conditionMessage(err)) + NULL + } + ) + + if (is.null(resp)) { + return(NULL) + } + + status <- httr2::resp_status(resp) + if (status >= 400) { + if (vb) message(httr2_error_message(resp)) + return(NULL) + } + + httr2::resp_body_json(resp, simplifyVector = TRUE) +} + diff --git a/README.Rmd b/README.Rmd index ce23e410..204dd364 100644 --- a/README.Rmd +++ b/README.Rmd @@ -48,16 +48,23 @@ The registration process involves the creation of an (email-account-based) user Once institutional authorization has been granted, a user may gain access to shared video, audio, and other data. See for more information about gaining access to restricted data. -However, many commands in the `databraryr` package return meaningful results *without* or *prior to* formal authorization. -These commands access public data or metadata. +All API calls now require OAuth2 authentication. Before +running the examples below, ensure you have set the following environment variables +or stored values with `login_db(store = TRUE)`: + +- `DATABRARY_CLIENT_ID` +- `DATABRARY_CLIENT_SECRET` +- `DATABRARY_LOGIN` (your Databrary account email) +- `DATABRARY_PASSWORD` (optional; prompted securely if missing) + +You can configure these via `usethis::edit_r_environ()`. ```{r example} library(databraryr) -get_db_stats() +login_db() -list_volume_assets() |> - head() +whoami() ``` ## Lifecycle diff --git a/man/login_db.Rd b/man/login_db.Rd index e10d0ea1..98be6bd7 100644 --- a/man/login_db.Rd +++ b/man/login_db.Rd @@ -7,11 +7,12 @@ login_db( email = NULL, password = NULL, + client_id = NULL, + client_secret = NULL, store = FALSE, overwrite = FALSE, - vb = options::opt("vb"), SERVICE = KEYRING_SERVICE, - rq = NULL + vb = options::opt("vb") ) } \arguments{ @@ -20,18 +21,20 @@ login_db( \item{password}{Databrary password (not recommended as it will displayed as you type)} +\item{client_id}{OAuth2 client identifier.} + +\item{client_secret}{OAuth2 client secret.} + \item{store}{A boolean value. If TRUE store/retrieve credentials from the system keyring/keychain.} \item{overwrite}{A boolean value. If TRUE and store is TRUE, overwrite/ update stored credentials in keyring/keychain.} -\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - \item{SERVICE}{A character label for stored credentials in the keyring. -Default is "databrary"} +Default is \code{org.databrary.databraryr}.} -\item{rq}{An \code{http} request object. Defaults to NULL.} +\item{vb}{Show verbose messages.} } \value{ Logical value indicating whether log in is successful or not. @@ -40,7 +43,7 @@ Logical value indicating whether log in is successful or not. Log In To Databrary.org. } \examples{ -\dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (interactive()) withAutoprint(\{ # examplesIf} login_db() # Queries user for email and password interactively. \dontshow{\}) # examplesIf} \donttest{ diff --git a/man/logout_db.Rd b/man/logout_db.Rd index 49e55875..2ea6c141 100644 --- a/man/logout_db.Rd +++ b/man/logout_db.Rd @@ -4,7 +4,7 @@ \alias{logout_db} \title{Log Out of Databrary.org.} \usage{ -logout_db(vb = options::opt("vb"), rq = NULL) +logout_db(vb = options::opt("vb")) } \arguments{ \item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} diff --git a/man/make_default_request.Rd b/man/make_default_request.Rd index ddb0d76b..17f17644 100644 --- a/man/make_default_request.Rd +++ b/man/make_default_request.Rd @@ -2,15 +2,29 @@ % Please edit documentation in R/make_default_request.R \name{make_default_request} \alias{make_default_request} -\title{Set default httr request parameters.} +\title{Set base request defaults for Databrary API.} \usage{ -make_default_request() +make_default_request( + with_token = TRUE, + refresh = TRUE, + vb = options::opt("vb") +) +} +\arguments{ +\item{with_token}{Should the request include an OAuth2 \code{Authorization} header? +Defaults to \code{TRUE} since all API calls now require authentication.} + +\item{refresh}{When \code{with_token = TRUE}, determines whether to refresh the +cached token if it is near expiry. Defaults to \code{TRUE}.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} } \value{ -An \code{httr2} request object. +An \code{httr2_request} object configured for the Databrary API. } \description{ -\code{make_default_request} sets default parameters for httr requests. +Creates an \code{httr2} request with the package's default options, including +base URL, user agent, Accept header, and timeout tuned for the Django API. } \examples{ make_default_request() diff --git a/man/whoami.Rd b/man/whoami.Rd new file mode 100644 index 00000000..08932656 --- /dev/null +++ b/man/whoami.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/whoami.R +\name{whoami} +\alias{whoami} +\title{Retrieve metadata about the authenticated Databrary user.} +\usage{ +whoami(refresh = TRUE, vb = options::opt("vb")) +} +\arguments{ +\item{refresh}{Whether to attempt automatic token refresh when the current +access token is expired. Defaults to \code{TRUE}.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} +} +\value{ +A list containing \code{auth_method} and \code{user} fields (both lists) or +\code{NULL} if the request fails due to lack of authentication. +} +\description{ +Calls the Django \verb{/oauth2/test/} endpoint to report the current authentication +method and user profile. Requires a valid OAuth2 access token acquired via +\code{login_db()}. +} +\examples{ +\\dontrun{ +login_db() +whoami() +} +} diff --git a/tests/testthat/test-login_db.R b/tests/testthat/test-login_db.R index 1a69237c..0787a463 100644 --- a/tests/testthat/test-login_db.R +++ b/tests/testthat/test-login_db.R @@ -1,31 +1,23 @@ test_that("login_db rejects bad input parameters", { - # expect_error(login_db(email = -1)) - # expect_error(login_db(email = c("a", "b"))) - # expect_error(login_db(email = list("a", "b"))) - # expect_error(login_db(email = TRUE)) - # - # expect_error(login_db(password = -1)) - # expect_error(login_db(password = 3)) - # expect_error(login_db(password = list("a", "b"))) - # expect_error(login_db(password = TRUE)) - # - # expect_error(login_db(store = -1)) - # expect_error(login_db(store = 'a')) - # expect_error(login_db(store = list("a", "b"))) - # - # expect_error(login_db(overwrite = -1)) - # expect_error(login_db(overwrite = 'a')) - # expect_error(login_db(overwrite = list("a", "b"))) - expect_error(login_db(vb = -1)) expect_error(login_db(vb = 3)) expect_error(login_db(vb = "a")) - - # expect_error(login_db(SERVICE = -1)) - # expect_error(login_db(SERVICE = TRUE)) - # expect_error(login_db(SERVICE = list("a", "b"))) - # - # expect_error(login_db(rq = 3)) - # expect_error(login_db(rq = "a")) - # expect_error(login_db(rq = TRUE)) }) + +test_that("login_db stores token bundle on success", { + orig <- get("oauth_password_grant", envir = asNamespace("databraryr")) + assignInNamespace("oauth_password_grant", function(username, password, client_id, client_secret, vb = FALSE) list(access_token = "abc", refresh_token = "def", expires_in = 3600), ns = "databraryr") + on.exit(assignInNamespace("oauth_password_grant", orig, ns = "databraryr"), add = TRUE) + clear_token_bundle() + expect_true(login_db(email = "user@example.com", + password = "pw", + client_id = "cid", + client_secret = "sec", + store = FALSE, + vb = FALSE)) + bundle <- get_token_bundle() + expect_equal(bundle$access_token, "abc") + expect_equal(bundle$refresh_token, "def") + clear_token_bundle() +}) + diff --git a/tests/testthat/test-logout_db.R b/tests/testthat/test-logout_db.R index 334337e9..30b16c2d 100644 --- a/tests/testthat/test-logout_db.R +++ b/tests/testthat/test-logout_db.R @@ -5,9 +5,8 @@ test_that("logout_db rejects bad input parameters", { expect_error(logout_db(vb = c(TRUE, FALSE))) }) -test_that("logout_db returns logical", { - expect_true(is.logical(logout_db())) +test_that("logout_db clears token state", { + set_token_bundle(access_token = "abc", refresh_token = "def", expires_in = 3600) + expect_true(logout_db(vb = FALSE)) + expect_null(get_token_bundle()) }) - -# Actually log out -logout_db() diff --git a/tests/testthat/test-make_default_request.R b/tests/testthat/test-make_default_request.R index 03573f4f..b418044b 100644 --- a/tests/testthat/test-make_default_request.R +++ b/tests/testthat/test-make_default_request.R @@ -3,3 +3,18 @@ test_that("make_default_request returns httr2_request", { expect_true("httr2_request" %in% class(make_default_request())) }) +test_that("make_default_request optionally attaches bearer token", { + clear_token_bundle() + set_token_bundle(access_token = "xyz", refresh_token = NULL) + req <- make_default_request(with_token = TRUE, refresh = FALSE, vb = FALSE) + headers <- req$headers + expect_equal(headers$Authorization, "Bearer xyz") + clear_token_bundle() +}) + +test_that("make_default_request errors when token missing", { + clear_token_bundle() + expect_error(make_default_request(with_token = TRUE, refresh = FALSE, vb = FALSE), + "No OAuth token available") +}) + diff --git a/tests/testthat/test-whoami.R b/tests/testthat/test-whoami.R new file mode 100644 index 00000000..21053784 --- /dev/null +++ b/tests/testthat/test-whoami.R @@ -0,0 +1,29 @@ +test_that("whoami returns NULL when unauthenticated", { + clear_token_bundle() + expect_null(whoami(refresh = FALSE, vb = FALSE)) +}) + +test_that("whoami fetches user info", { + clear_token_bundle() + set_token_bundle(access_token = "abc", refresh_token = NULL) + + local_mocked_bindings( + req_perform = function(...) { + httr2::response( + method = "GET", + url = OAUTH_TEST_URL, + status_code = 200, + headers = list("Content-Type" = "application/json"), + body = charToRaw('{"auth_method":"password","user":{"id":1}}') + ) + }, + .package = "httr2" + ) + + result <- whoami(refresh = FALSE, vb = FALSE) + + expect_equal(result$auth_method, "password") + expect_equal(result$user$id, 1) + clear_token_bundle() +}) + From 7ac22e09d6dab0cf25f4f5f5f2ec6b22a684de55 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Pawe=C5=82=20Armatys?= Date: Fri, 31 Oct 2025 12:07:54 +0100 Subject: [PATCH 02/27] Refactor API interaction: add new helper functions, remove deprecated functions, and update documentation. Adjust tests for consistency and add new tests for recent changes. --- NAMESPACE | 28 +- R/CONSTANTS.R | 109 +++---- R/api_utils.R | 176 +++++++++++ R/assign_constants.R | 56 ++-- R/download_party_avatar.R | 136 --------- R/get_db_stats.R | 85 ++---- R/get_folder_by_id.R | 56 ++++ R/get_institution_by_id.R | 46 +++ R/get_party_by_id.R | 76 ----- R/get_session_by_id.R | 74 ++--- R/get_session_by_name.R | 62 +--- R/get_user_by_id.R | 46 +++ R/get_volume_by_id.R | 53 ++-- R/list_authorized_investigators.R | 73 ++--- R/list_folder_assets.R | 102 +++++++ R/list_institution_affiliates.R | 45 +++ R/list_party_affiliates.R | 77 ----- R/list_party_sponsors.R | 99 ------- R/list_party_volumes.R | 104 ------- R/list_session_activity.R | 159 +++++++--- R/list_session_assets.R | 145 ++++----- R/list_sponsors.R | 72 ----- R/list_user_affiliates.R | 39 +++ R/list_user_history.R | 65 +++++ R/list_user_sponsors.R | 50 ++++ R/list_user_volumes.R | 52 ++++ R/list_users.R | 115 ++++++++ R/list_volume_activity.R | 90 ++++-- R/list_volume_assets.R | 139 ++++----- R/list_volume_collaborators.R | 80 +++++ R/list_volume_excerpts.R | 60 ---- R/list_volume_folders.R | 69 +++++ R/list_volume_funding.R | 85 ++---- R/list_volume_info.R | 115 +++----- R/list_volume_links.R | 45 ++- R/list_volume_owners.R | 73 ----- R/list_volume_session_assets.R | 133 ++++----- R/list_volume_sessions.R | 99 +++---- R/list_volume_tags.R | 36 +-- R/list_volumes.R | 86 ++++++ R/misc_enums.R | 43 +++ R/search_for_funder.R | 68 +++-- R/search_for_keywords.R | 69 ----- R/search_for_tags.R | 42 ++- R/search_institutions.R | 60 ++++ R/search_users.R | 64 ++++ R/search_volumes.R | 82 ++++++ R/token_helpers.R | 9 - R/utils.R | 276 ++++-------------- R/whoami.R | 10 +- README.Rmd | 23 ++ README.md | 45 ++- ...API_CONSTANTS.Rd => DATABRARY_BASE_URL.Rd} | 6 +- man/download_party_avatar.Rd | 44 --- man/get_asset_segment_range.Rd | 46 --- man/get_assets_from_session.Rd | 16 - man/get_file_duration.Rd | 12 +- man/get_folder_by_id.Rd | 31 ++ man/get_info_from_session.Rd | 26 -- man/get_institution_by_id.Rd | 19 ++ man/get_party_by_id.Rd | 39 --- man/get_user_by_id.Rd | 19 ++ man/is_institution.Rd | 27 -- man/is_person.Rd | 27 -- man/list_authorized_investigators.Rd | 21 +- man/list_folder_assets.Rd | 36 +++ man/list_institution_affiliates.Rd | 23 ++ man/list_party_affiliates.Rd | 26 -- man/list_party_sponsors.Rd | 30 -- man/list_party_volumes.Rd | 29 -- man/list_session_activity.Rd | 34 ++- man/list_session_assets.Rd | 11 +- man/list_sponsors.Rd | 29 -- man/list_user_affiliates.Rd | 19 ++ man/list_user_history.Rd | 31 ++ man/list_user_sponsors.Rd | 19 ++ man/list_user_volumes.Rd | 19 ++ man/list_users.Rd | 52 ++++ man/list_volume_activity.Rd | 4 +- man/list_volume_collaborators.Rd | 30 ++ man/list_volume_excerpts.Rd | 27 -- man/list_volume_folders.Rd | 29 ++ man/list_volume_owners.Rd | 28 -- man/list_volume_session_assets.Rd | 6 +- man/list_volumes.Rd | 39 +++ man/make_login_client.Rd | 2 +- man/search_for_funder.Rd | 6 +- man/search_for_keywords.Rd | 34 --- man/search_institutions.Rd | 31 ++ man/search_users.Rd | 30 ++ man/search_volumes.Rd | 30 ++ tests/testthat/helper-auth.R | 52 ++++ tests/testthat/test-assign_constants.R | 20 +- tests/testthat/test-auth_service.R | 57 ++++ tests/testthat/test-download_party_avatar.R | 20 -- tests/testthat/test-download_session_zip.R | 1 + tests/testthat/test-download_volume_zip.R | 1 + tests/testthat/test-get_db_stats.R | 43 ++- tests/testthat/test-get_folder_by_id.R | 38 +++ tests/testthat/test-get_institution_by_id.R | 11 + tests/testthat/test-get_party_by_id.R | 25 -- tests/testthat/test-get_session_by_id.R | 7 +- tests/testthat/test-get_session_by_name.R | 17 +- tests/testthat/test-get_user_by_id.R | 9 + tests/testthat/test-get_volume_by_id.R | 7 +- tests/testthat/test-list_asset_formats.R | 15 + .../test-list_authorized_investigators.R | 31 +- tests/testthat/test-list_folder_assets.R | 40 +++ .../test-list_institution_affiliates.R | 10 + tests/testthat/test-list_party_affiliates.R | 25 -- tests/testthat/test-list_party_sponsors.R | 25 -- tests/testthat/test-list_party_volumes.R | 25 -- tests/testthat/test-list_session_activity.R | 10 +- tests/testthat/test-list_session_assets.R | 49 ++-- tests/testthat/test-list_sponsors.R | 23 -- tests/testthat/test-list_user_affiliates.R | 27 ++ tests/testthat/test-list_user_history.R | 18 ++ tests/testthat/test-list_user_sponsors.R | 26 ++ tests/testthat/test-list_user_volumes.R | 22 ++ tests/testthat/test-list_users.R | 21 ++ tests/testthat/test-list_volume_activity.R | 6 +- tests/testthat/test-list_volume_assets.R | 19 +- .../testthat/test-list_volume_collaborators.R | 19 ++ tests/testthat/test-list_volume_excerpts.R | 23 -- tests/testthat/test-list_volume_folders.R | 26 ++ tests/testthat/test-list_volume_funding.R | 7 +- tests/testthat/test-list_volume_info.R | 22 +- tests/testthat/test-list_volume_links.R | 8 +- tests/testthat/test-list_volume_owners.R | 26 -- .../test-list_volume_session_assets.R | 17 +- tests/testthat/test-list_volume_sessions.R | 21 +- tests/testthat/test-list_volume_tags.R | 11 +- tests/testthat/test-list_volumes.R | 18 ++ tests/testthat/test-make_default_request.R | 20 +- tests/testthat/test-make_login_client.R | 52 ++-- tests/testthat/test-search_for_funder.R | 12 +- tests/testthat/test-search_for_keywords.R | 21 -- tests/testthat/test-search_for_tags.R | 6 +- tests/testthat/test-search_institutions.R | 17 ++ tests/testthat/test-search_users.R | 17 ++ tests/testthat/test-search_volumes.R | 17 ++ tests/testthat/test-token_helpers.R | 29 ++ tests/testthat/test-utils.R | 95 ++---- tests/testthat/test-whoami.R | 25 +- vignettes/accessing-data.Rmd | 30 +- vignettes/databrary.Rmd | 27 +- 146 files changed, 3417 insertions(+), 2937 deletions(-) create mode 100644 R/api_utils.R delete mode 100644 R/download_party_avatar.R create mode 100644 R/get_folder_by_id.R create mode 100644 R/get_institution_by_id.R delete mode 100644 R/get_party_by_id.R create mode 100644 R/get_user_by_id.R create mode 100644 R/list_folder_assets.R create mode 100644 R/list_institution_affiliates.R delete mode 100644 R/list_party_affiliates.R delete mode 100644 R/list_party_sponsors.R delete mode 100644 R/list_party_volumes.R delete mode 100644 R/list_sponsors.R create mode 100644 R/list_user_affiliates.R create mode 100644 R/list_user_history.R create mode 100644 R/list_user_sponsors.R create mode 100644 R/list_user_volumes.R create mode 100644 R/list_users.R create mode 100644 R/list_volume_collaborators.R delete mode 100644 R/list_volume_excerpts.R create mode 100644 R/list_volume_folders.R delete mode 100644 R/list_volume_owners.R create mode 100644 R/list_volumes.R create mode 100644 R/misc_enums.R delete mode 100644 R/search_for_keywords.R create mode 100644 R/search_institutions.R create mode 100644 R/search_users.R create mode 100644 R/search_volumes.R rename man/{API_CONSTANTS.Rd => DATABRARY_BASE_URL.Rd} (81%) delete mode 100644 man/download_party_avatar.Rd delete mode 100644 man/get_asset_segment_range.Rd delete mode 100644 man/get_assets_from_session.Rd create mode 100644 man/get_folder_by_id.Rd delete mode 100644 man/get_info_from_session.Rd create mode 100644 man/get_institution_by_id.Rd delete mode 100644 man/get_party_by_id.Rd create mode 100644 man/get_user_by_id.Rd delete mode 100644 man/is_institution.Rd delete mode 100644 man/is_person.Rd create mode 100644 man/list_folder_assets.Rd create mode 100644 man/list_institution_affiliates.Rd delete mode 100644 man/list_party_affiliates.Rd delete mode 100644 man/list_party_sponsors.Rd delete mode 100644 man/list_party_volumes.Rd delete mode 100644 man/list_sponsors.Rd create mode 100644 man/list_user_affiliates.Rd create mode 100644 man/list_user_history.Rd create mode 100644 man/list_user_sponsors.Rd create mode 100644 man/list_user_volumes.Rd create mode 100644 man/list_users.Rd create mode 100644 man/list_volume_collaborators.Rd delete mode 100644 man/list_volume_excerpts.Rd create mode 100644 man/list_volume_folders.Rd delete mode 100644 man/list_volume_owners.Rd create mode 100644 man/list_volumes.Rd delete mode 100644 man/search_for_keywords.Rd create mode 100644 man/search_institutions.Rd create mode 100644 man/search_users.Rd create mode 100644 man/search_volumes.Rd create mode 100644 tests/testthat/helper-auth.R create mode 100644 tests/testthat/test-auth_service.R delete mode 100644 tests/testthat/test-download_party_avatar.R create mode 100644 tests/testthat/test-get_folder_by_id.R create mode 100644 tests/testthat/test-get_institution_by_id.R delete mode 100644 tests/testthat/test-get_party_by_id.R create mode 100644 tests/testthat/test-get_user_by_id.R create mode 100644 tests/testthat/test-list_asset_formats.R create mode 100644 tests/testthat/test-list_folder_assets.R create mode 100644 tests/testthat/test-list_institution_affiliates.R delete mode 100644 tests/testthat/test-list_party_affiliates.R delete mode 100644 tests/testthat/test-list_party_sponsors.R delete mode 100644 tests/testthat/test-list_party_volumes.R delete mode 100644 tests/testthat/test-list_sponsors.R create mode 100644 tests/testthat/test-list_user_affiliates.R create mode 100644 tests/testthat/test-list_user_history.R create mode 100644 tests/testthat/test-list_user_sponsors.R create mode 100644 tests/testthat/test-list_user_volumes.R create mode 100644 tests/testthat/test-list_users.R create mode 100644 tests/testthat/test-list_volume_collaborators.R delete mode 100644 tests/testthat/test-list_volume_excerpts.R create mode 100644 tests/testthat/test-list_volume_folders.R delete mode 100644 tests/testthat/test-list_volume_owners.R create mode 100644 tests/testthat/test-list_volumes.R delete mode 100644 tests/testthat/test-search_for_keywords.R create mode 100644 tests/testthat/test-search_institutions.R create mode 100644 tests/testthat/test-search_users.R create mode 100644 tests/testthat/test-search_volumes.R create mode 100644 tests/testthat/test-token_helpers.R diff --git a/NAMESPACE b/NAMESPACE index 9b6da36c..613ec1a0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,7 +4,6 @@ export("%>%") export(HHMMSSmmm_to_ms) export(assign_constants) export(check_ssl_certs) -export(download_party_avatar) export(download_session_asset) export(download_session_assets_fr_df) export(download_session_csv) @@ -12,43 +11,48 @@ export(download_session_zip) export(download_single_session_asset_fr_df) export(download_video) export(download_volume_zip) -export(get_asset_segment_range) export(get_db_stats) export(get_file_duration) -export(get_party_by_id) +export(get_folder_by_id) +export(get_institution_by_id) export(get_permission_levels) export(get_release_levels) export(get_session_by_id) export(get_session_by_name) export(get_supported_file_types) +export(get_user_by_id) export(get_volume_by_id) -export(is_institution) -export(is_person) export(list_asset_formats) export(list_authorized_investigators) -export(list_party_affiliates) -export(list_party_sponsors) -export(list_party_volumes) +export(list_folder_assets) +export(list_institution_affiliates) export(list_session_activity) export(list_session_assets) -export(list_sponsors) +export(list_user_affiliates) +export(list_user_history) +export(list_user_sponsors) +export(list_user_volumes) +export(list_users) export(list_volume_activity) export(list_volume_assets) -export(list_volume_excerpts) +export(list_volume_collaborators) +export(list_volume_folders) export(list_volume_funding) export(list_volume_info) export(list_volume_links) -export(list_volume_owners) export(list_volume_session_assets) export(list_volume_sessions) export(list_volume_tags) +export(list_volumes) export(login_db) export(logout_db) export(make_default_request) export(make_login_client) export(search_for_funder) -export(search_for_keywords) export(search_for_tags) +export(search_institutions) +export(search_users) +export(search_volumes) export(whoami) importFrom(lifecycle,deprecated) importFrom(magrittr,"%>%") diff --git a/R/CONSTANTS.R b/R/CONSTANTS.R index ebe26b03..000da2ed 100644 --- a/R/CONSTANTS.R +++ b/R/CONSTANTS.R @@ -1,90 +1,53 @@ #' Load Package-wide Constants into Local Environment #' #' +DATABRARY_BASE_URL <- Sys.getenv("DATABRARY_BASE_URL", "https://api.stg-databrary.its.nyu.edu") -# Legacy endpoints (temporary until all functions migrated) ------------------- - -API_CONSTANTS <- "https://nyu.databrary.org/api/constants" - -CREATE_SLOT <- - "https://nyu.databrary.org/api/volume/%s/slot" -CREATE_UPLOAD_FLOW <- - "https://nyu.databrary.org/api/volume/%s/upload" -CREATE_FILE_FROM_FLOW <- - "https://nyu.databrary.org/api/volume/%s/asset" - -DATABRARY_API <- "https://nyu.databrary.org/api" -DOWNLOAD_FILE <- - "https://nyu.databrary.org/slot/%s/-/asset/%s/download" -DOWNLOAD_SESSION_ZIP <- - "https://nyu.databrary.org/volume/%s/slot/%s/zip/%s" -DOWNLOAD_VOLUME_ZIP <- - "https://nyu.databrary.org/volume/%s/zip/false" - -GET_SESSIONS_IN_VOL <- - "https://nyu.databrary.org/api/volume/%s?records&containers=all" -GET_ACTIVITY_DATA <- - "https://nyu.databrary.org/api/activity" -GET_PARTY_BY_ID <- - "https://nyu.databrary.org/api/party/%s?parents&children&access" -GET_PARTY_NO_PARENTS_CHILDREN <- "https://nyu.databrary.org/api/party/%s" -GET_CONSTANTS <- "https://nyu.databrary.org/api/constants" -GET_PARTY_AVATAR <- "https://nyu.databrary.org/party/%s/avatar" - -GET_SESSION_CSV <- "https://nyu.databrary.org/volume/%s/csv" -GET_SESSION_ACTIVITY <- "https://nyu.databrary.org/api/slot/%s/activity" -GET_SESSION_ZIP <- "https://nyu.databrary.org/volume/%s/slot/%s/zip/false" - -GET_VOL_BY_ID <- - "https://nyu.databrary.org/api/volume/%s?access&citation&links&funding&top&tags&excerpts&comments&records&containers=all&metrics&state" -GET_VOLUME_FUNDING <- "https://nyu.databrary.org/api/volume/%s?funding=all" -GET_VOLUME_MINIMUM <- "https://nyu.databrary.org/api/volume/%s" -GET_VOLUME_LINKS <- "https://nyu.databrary.org/api/volume/%s?links=all" -GET_VOLUME_TAGS <- "https://nyu.databrary.org/api/volume/%s?tags=all" -GET_VOLUME_ACTIVITY <- "https://nyu.databrary.org/api/volume/%s/activity" -GET_VOLUME_ZIP <- "https://nyu.databrary.org/volume/%s/zip/false" -GET_VOLUME_EXCERPTS <- "https://nyu.databrary.org/api/volume/%s?excerpts=all" - -GET_ASSET_BY_ID <- "https://nyu.databrary.org/api/asset/%s" -GET_ASSET_BY_VOLUME_SESSION_ID <- - "https://nyu.databrary.org/api/volume/%s/slot/%s/asset/%s" - -# LOGIN <- "https://nyu.databrary.org/api/user/login" -# LOGOUT <- "https://nyu.databrary.org/api/user/logout" - -QUERY_SLOT <- - "https://nyu.databrary.org/api/slot/%s/-?records&assets&excerpts&tags&comments" -QUERY_VOLUME_FUNDER <- "https://nyu.databrary.org/api/funder?query=%s" -QUERY_KEYWORDS <- "https://nyu.databrary.org/api/search?q=%s" -QUERY_TAGS <- "https://nyu.databrary.org/api/tags/%s" - -SESSION_CSV <- "https://nyu.databrary.org/volume/%s/csv" - -UPLOAD_CHUNK <- "https://nyu.databrary.org/api/upload" -UPDATE_SLOT <- "https://nyu.databrary.org/api/slot/%s" - -# Authentication parameters -# USER_AGENT <- -# "databraryr (https://cran.r-project.org/package=databraryr)" -# KEYRING_SERVICE <- 'org.databrary.databraryr' +API_ACTIVITY_SUMMARY <- "/statistics/summary/" +API_GROUPED_FORMATS <- "/grouped-formats/" +API_USERS <- "/users/" +API_USER_DETAIL <- "/users/%s/" +API_USER_VOLUMES <- "/users/%s/volumes/" +API_USER_SPONSORSHIPS <- "/users/%s/sponsorships/" +API_USER_AFFILIATES <- "/users/%s/affiliates/" +API_USER_AVATAR <- "/users/%s/avatar/" +API_USERS_HISTORY <- "/users/%s/history/" +API_INSTITUTIONS <- "/institutions/%s/" +API_INSTITUTION_AFFILIATES <- "/institutions/%s/affiliates/" +API_INSTITUTION_AVATAR <- "/institutions/%s/avatar/" +API_VOLUMES <- "/volumes/" +API_VOLUME_DETAIL <- "/volumes/%s/" +API_VOLUME_TAGS <- "/volumes/%s/tags/" +API_VOLUME_LINKS <- "/volumes/%s/links/" +API_VOLUME_FUNDINGS <- "/volumes/%s/fundings/" +API_VOLUME_COLLABORATORS <- "/volumes/%s/collaborators/" +API_VOLUME_HISTORY <- "/volumes/%s/history/" +API_VOLUME_SESSIONS <- "/volumes/%s/sessions/" +API_VOLUME_FOLDERS <- "/volumes/%s/folders/" +API_SESSION_DETAIL <- "/volumes/%s/sessions/%s/" +API_SESSION_FILES <- "/volumes/%s/sessions/%s/files/" +API_SESSION_FILE_DETAIL <- "/volumes/%s/sessions/%s/files/%s/" +API_FILES_DOWNLOAD_LINK <- "/volumes/%s/sessions/%s/files/%s/download-link/" +API_SESSION_DOWNLOAD_LINK <- "/volumes/%s/sessions/%s/download-link/" +API_SESSION_CSV_DOWNLOAD_LINK <- "/volumes/%s/sessions/%s/csv-download-link/" +API_FOLDER_DETAIL <- "/volumes/%s/folders/%s/" +API_FOLDER_FILES <- "/volumes/%s/folders/%s/files/" +API_VOLUME_DOWNLOAD_LINK <- "/volumes/%s/download-link/" +API_VOLUME_CSV_DOWNLOAD_LINK <- "/volumes/%s/csv-download-link/" +API_SEARCH_VOLUMES <- "/search/volumes/" +API_SEARCH_USERS <- "/search/users/" +API_SEARCH_INSTITUTIONS <- "/search/institutions/" +API_FUNDERS <- "/funders/" -# httr2 request parameters RETRY_LIMIT <- 3 RETRY_WAIT_TIME <- 1 # seconds RETRY_BACKOFF <- 2 # exponential backoff REQUEST_TIMEOUT <- 5 # seconds REQUEST_TIMEOUT_VERY_LONG <- 600 -# Base host ----------------------------------------------------------------- - -DATABRARY_BASE_URL <- Sys.getenv("DATABRARY_BASE_URL", "https://api.stg-databrary.its.nyu.edu") - -# OAuth endpoints ------------------------------------------------------------- OAUTH_TOKEN_URL <- sprintf("%s/o/token/", DATABRARY_BASE_URL) OAUTH_TEST_URL <- sprintf("%s/oauth2/test/", DATABRARY_BASE_URL) -# Authentication parameters --------------------------------------------------- - USER_AGENT <- Sys.getenv("USER_AGENT", "SRW$*Kxy2nYdyo4LozoGV#i6LvH/") KEYRING_SERVICE <- 'org.databrary.databraryr' diff --git a/R/api_utils.R b/R/api_utils.R new file mode 100644 index 00000000..7c5787b5 --- /dev/null +++ b/R/api_utils.R @@ -0,0 +1,176 @@ +# Internal helpers for interacting with the Databrary Django API. + +#' @noRd +ensure_leading_slash <- function(path) { + assertthat::assert_that(assertthat::is.string(path)) + if (startsWith(path, "/")) { + path + } else { + paste0("/", path) + } +} + +#' @noRd +build_query_params <- function(params) { + if (length(params) == 0) { + return(NULL) + } + + keep <- !vapply(params, is.null, logical(1)) + params <- params[keep] + lapply(params, function(value) { + if (is.logical(value)) { + # API expects lowercase true/false + tolower(as.character(value)) + } else { + value + } + }) +} + +#' @noRd +perform_api_get <- function(path, + params = list(), + rq = NULL, + vb = FALSE, + parser = NULL, + normalize = TRUE, + response_type = c("json", "raw", "text")) { + response_type <- match.arg(response_type) + + request <- rq + if (is.null(request)) { + request <- databraryr::make_default_request() + } + + url <- paste0(DATABRARY_BASE_URL, ensure_leading_slash(path)) + request <- httr2::req_url(request, url) + + query <- build_query_params(params) + if (!is.null(query) && length(query) > 0) { + request <- do.call(httr2::req_url_query, c(list(request), query)) + } + + response <- tryCatch( + httr2::req_perform(request), + httr2_error = function(cnd) { + if (vb) { + message("Request failed for ", url, ": ", conditionMessage(cnd)) + } + NULL + } + ) + + if (is.null(response)) { + return(NULL) + } + + body <- switch( + response_type, + json = { + payload <- httr2::resp_body_json(response) + if (isTRUE(normalize)) { + payload <- snake_case_list(payload) + } + payload + }, + raw = httr2::resp_body_raw(response), + text = httr2::resp_body_string(response) + ) + + if (!is.null(parser) && is.function(parser)) { + body <- parser(body) + } + body +} + +#' @noRd +collect_paginated_get <- function(path, + params = list(), + rq = NULL, + vb = FALSE, + normalize = TRUE) { + next_url <- paste0(DATABRARY_BASE_URL, ensure_leading_slash(path)) + first_iter <- TRUE + query <- build_query_params(params) + + aggregated <- list() + + while (!is.null(next_url)) { + request <- rq + if (is.null(request)) { + request <- databraryr::make_default_request(refresh = first_iter) + } + + request <- httr2::req_url(request, next_url) + if (first_iter && !is.null(query) && length(query) > 0) { + request <- do.call(httr2::req_url_query, c(list(request), query)) + } + + resp <- tryCatch( + httr2::req_perform(request), + httr2_error = function(cnd) { + if (vb) { + message("Request failed for ", next_url, ": ", conditionMessage(cnd)) + } + NULL + } + ) + + if (is.null(resp)) { + return(NULL) + } + + body <- httr2::resp_body_json(resp) + if (isTRUE(normalize)) { + body <- snake_case_list(body) + } + + page_results <- body$results + if (is.null(page_results)) { + if (is.list(body) && length(body) > 0 && (is.null(names(body)) || all(names(body) == ""))) { + page_results <- body + } else { + page_results <- list() + } + } + + aggregated <- c(aggregated, page_results) + + next_url <- body[["next"]] + if (!is.null(next_url) && !startsWith(next_url, "http")) { + next_url <- paste0(DATABRARY_BASE_URL, ensure_leading_slash(next_url)) + } + if (!is.null(next_url)) { + next_url <- sub("^http://", "https://", next_url) + } + + first_iter <- FALSE + } + + aggregated +} + +#' @noRd +camel_to_snake <- function(x) { + x <- gsub("(.)([A-Z][a-z]+)", "\\1_\\2", x) + tolower(gsub("([a-z0-9])([A-Z])", "\\1_\\2", x)) +} + +#' @noRd +snake_case_list <- function(obj) { + if (is.list(obj)) { + names_list <- names(obj) + if (!is.null(names_list)) { + names(obj) <- vapply(names_list, camel_to_snake, character(1)) + } + obj <- lapply(obj, snake_case_list) + obj + } else if (is.vector(obj) && !is.null(names(obj))) { + names(obj) <- vapply(names(obj), camel_to_snake, character(1)) + obj + } else { + obj + } +} + diff --git a/R/assign_constants.R b/R/assign_constants.R index bcc64bd3..3ebb5c6e 100644 --- a/R/assign_constants.R +++ b/R/assign_constants.R @@ -17,27 +17,43 @@ NULL #' } #' @export assign_constants <- function(vb = options::opt("vb"), rq = NULL) { - # Check parameter assertthat::assert_that(is.logical(vb)) - - if (is.null(rq)) - rq <- databraryr::make_default_request() - arq <- rq %>% - httr2::req_url(GET_CONSTANTS) - - if (vb) message("Retrieving constants.") - resp <- tryCatch( - httr2::req_perform(arq), - httr2_error = function(cnd) { - if (vb) message("Error loading Databrary constants.") - NULL - } + if (vb) { + message("Retrieving grouped formats and static enums.") + } + + grouped <- perform_api_get( + path = API_GROUPED_FORMATS, + rq = rq, + vb = vb, + normalize = TRUE ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - resp - } else { - httr2::resp_body_json(resp) + + if (is.null(grouped)) { + message("Unable to load grouped format metadata from Databrary.") + return(NULL) + } + + lists <- grouped$root + if (is.null(lists)) { + lists <- grouped } + + format_entries <- purrr::imap(lists, function(items, category) { + purrr::map(items, function(item) { + item$category <- category + item + }) + }) |> + purrr::list_c() + + formats_df <- purrr::map(format_entries, tibble::as_tibble) |> + purrr::list_rbind() + + list( + format = format_entries, + format_df = formats_df, + permission = databraryr:::get_permission_levels_enums(), + release = databraryr:::get_release_levels_enums() + ) } diff --git a/R/download_party_avatar.R b/R/download_party_avatar.R deleted file mode 100644 index 7a6b55af..00000000 --- a/R/download_party_avatar.R +++ /dev/null @@ -1,136 +0,0 @@ -#' @eval options::as_params() -#' @name options_params -#' -NULL - -#' Returns the Avatar(s) (images) for Authorized User(s). -#' -#' @param party_id A number or range of numbers. Party number or numbers to retrieve information about. Default is 6 -#' (Rick Gilmore). -#' @param show_party_info A logical value. Show the person's name and affiliation in the output. -#' Default is TRUE. -#' @param rq An `httr2` request object. If not provided, a new request is -#' generated via `make_default_request()`. -#' -#' @returns An list with the avatar (image) file and a name_affil string. -#' -#' @inheritParams options_params -#' -#' @examples -#' \donttest{ -#' \dontrun{ -#' download_party_avatar() # Show Rick Gilmore's (party 6) avatar. -#' -#' # Download avatars from Databrary's founders (without name/affiliations) -#' download_party_avatar(5:7, show_party_info = FALSE) -#' -#' # Download NYU logo -#' download_party_avatar(party = 8) -#' } -#' } -#' @export -download_party_avatar <- function(party_id = 6, - show_party_info = TRUE, - vb = options::opt("vb"), - rq = NULL) { - - # Check parameters - assertthat::is.number(party_id) - assertthat::assert_that(!is.character(party_id)) - assertthat::assert_that(!is.logical(party_id)) - assertthat::assert_that(sum(party_id >= 1) == length(party_id)) - - assertthat::assert_that(length(show_party_info) == 1) - assertthat::assert_that(is.logical(show_party_info)) - - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - # Handle NULL request - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - - if (vb) - message("Attempting to retrieve avatars for parties: ", - min(party_id), - ":", - max(party_id)) - - purrr::map( - party_id, - get_single_avatar, - show_party_info = show_party_info, - vb = vb, - rq = rq, - .progress = TRUE - ) -} - -#------------------------------------------------------------------------------ -# Helper function for handling multiple queries -get_single_avatar <- function(party_id = 6, - show_party_info = TRUE, - vb = FALSE, - rq = NULL) { - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - - arq <- rq %>% - httr2::req_url(sprintf(GET_PARTY_AVATAR, party_id)) - - resp <- tryCatch( - httr2::req_perform(arq), - httr2_error = function(cnd) { - if (vb) - message("Error retrieving avatar for party_id ", party_id) - NULL - } - ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } - - # Download avatar - party_avatar <- httr2::resp_body_raw(resp) %>% - magick::image_read() - - if (show_party_info) { - party_str <- paste0("Data for Databrary party ", party_id, ":") - - party_info <- databraryr::get_party_by_id(party_id) - if (is.list(party_info)) { - if ("affiliation" %in% names(party_info)) { - if (vb) - message(party_str) - party_str <- - paste0(party_info$prename, - " ", - party_info$sortname, - ", ", - party_info$affiliation) - } else { - party_str <- - paste0(party_info$sortname) - } - } else { - message("Unable to extract info for party '", party_id, "'.") - } - } - - list(avatar = party_avatar, name_affil = party_str) -} diff --git a/R/get_db_stats.R b/R/get_db_stats.R index 4036cd34..c42b7c14 100644 --- a/R/get_db_stats.R +++ b/R/get_db_stats.R @@ -58,77 +58,28 @@ get_db_stats <- function(type = "stats", } rq <- databraryr::make_default_request() } - rq <- rq %>% - httr2::req_url(GET_ACTIVITY_DATA) - - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) { - if (vb) - message("Error retrieving Databrary '", type, "' stats.") - NULL - } + stats <- perform_api_get( + path = API_ACTIVITY_SUMMARY, + rq = rq, + vb = vb ) - if (is.null(resp)) { + if (is.null(stats)) { message("Cannot access requested resource on Databrary. Exiting.") - return(resp) + return(NULL) } - if (httr2::resp_status(resp) == 200) { - r <- httr2::resp_body_json(resp) - - if (type %in% c("stats", "numbers")) { - tibble::tibble( - date = Sys.time(), - investigators = unlist(r$stats$authorized[5]), - affiliates = unlist(r$stats$authorized[4]), - institutions = unlist(r$stats$authorized[6]), - datasets_total = r$stats$volumes, - datasets_shared = r$stats$shared, - n_files = r$stats$assets, - hours = r$stats$duration / (1000 * 60 * 60), - TB = r$stats$bytes / (1e12) - ) # seems incorrect - } else { - purrr::map(r$activity, process_db_activity_blob_item, type) |> - purrr::list_rbind() - } - } -} - -#------------------------------------------------------------------------------ -process_db_activity_blob_item <- function(activity_blob, type) { - df <- activity_blob |> - purrr::flatten() |> - tibble::as_tibble() - - if (!is.null(df)) { - if (type %in% c("datasets", "volumes", "data")) { - if ("owners" %in% names(df)) { - df <- dplyr::filter(df, !is.na(df$id)) - } else { - return(NULL) - } - } else if (type %in% c("institutions", "places")) { - if ("institution" %in% names(df)) { - df <- dplyr::filter(df, !is.na(df$id), !is.na(df$institution)) - } else { - return(NULL) - } - } else if (type %in% c("people", "researchers", "investigators")) { - if ("affiliation" %in% names(df)) { - df <- dplyr::filter( - df, - !is.na(df$id), - !is.na(df$affiliation), - !is.na(df$sortname), - !is.na(df$prename) - ) - } else { - return(NULL) - } - } - df + if (type %in% c("stats", "numbers")) { + tibble::tibble( + date = Sys.time(), + investors = stats$authorized_users, + datasets_total = stats$total_volumes, + datasets_shared = stats$public_volumes, + n_files = stats$total_files, + hours = stats$total_duration_hours, + TB = stats$total_storage_tb + ) + } else { + tibble::as_tibble(stats$recent_activity) } } diff --git a/R/get_folder_by_id.R b/R/get_folder_by_id.R new file mode 100644 index 00000000..025b85c8 --- /dev/null +++ b/R/get_folder_by_id.R @@ -0,0 +1,56 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Get Folder Metadata From a Databrary Volume. +#' +#' @param folder_id Folder identifier within the specified volume. +#' @param vol_id Volume identifier containing the folder. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @returns A list representing the folder metadata, or `NULL` when the folder +#' cannot be accessed. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' get_folder_by_id() # Default folder in volume 1 +#' } +#' } +#' @export +get_folder_by_id <- function(folder_id = 1, + vol_id = 1, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(length(folder_id) == 1) + assertthat::assert_that(is.numeric(folder_id)) + assertthat::assert_that(folder_id >= 1) + + assertthat::assert_that(length(vol_id) == 1) + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(vol_id >= 1) + + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + folder <- perform_api_get( + path = sprintf(API_FOLDER_DETAIL, vol_id, folder_id), + rq = rq, + vb = vb + ) + + if (is.null(folder)) { + if (vb) { + message("Cannot access requested folder ", folder_id, " in volume ", vol_id) + } + return(NULL) + } + + folder +} + diff --git a/R/get_institution_by_id.R b/R/get_institution_by_id.R new file mode 100644 index 00000000..267717c3 --- /dev/null +++ b/R/get_institution_by_id.R @@ -0,0 +1,46 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Get institution metadata +#' +#' @param institution_id Institution identifier. +#' @inheritParams options_params +#' +#' @return List of institution metadata or NULL when inaccessible. +#' @export +get_institution_by_id <- function(institution_id = 12, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(is.numeric(institution_id), length(institution_id) == 1, institution_id > 0) + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + institution <- perform_api_get( + path = sprintf(API_INSTITUTIONS, institution_id), + rq = rq, + vb = vb + ) + + if (is.null(institution)) { + if (vb) message("Institution ", institution_id, " not found or inaccessible.") + return(NULL) + } + + tibble::tibble( + id = institution$id, + name = institution$name, + url = institution$url, + date_signed = institution$date_signed, + source = institution$source, + created_at = institution$created_at, + updated_at = institution$updated_at, + has_avatar = institution$has_avatar, + has_administrators = institution$has_administrators, + latitude = institution$latitude, + longitude = institution$longitude, + manual_coordinates = institution$manual_coordinates + ) %>% + as.list() +} + diff --git a/R/get_party_by_id.R b/R/get_party_by_id.R deleted file mode 100644 index a68a32ae..00000000 --- a/R/get_party_by_id.R +++ /dev/null @@ -1,76 +0,0 @@ -#' @eval options::as_params() -#' @name options_params -#' -NULL - -#' Download Information About a Party on Databrary as JSON -#' -#' @param party_id An integer. The party number to retrieve information about. -#' @param parents_children_access A logical value. If TRUE (the default), -#' returns _all_ of the data about the party. If FALSE, only a minimum amount -#' of information about the party is returned. -#' @param rq An `httr2`-style request object. If NULL, then a new request will -#' be generated using `make_default_request()`. -#' -#' @returns A nested list with information about the party. -#' This can be readily parsed by other functions. -#' -#' @inheritParams options_params -#' -#' @examples -#' \donttest{ -#' \dontrun{ -#' get_party_by_id() -#' } -#' } -#' @export -get_party_by_id <- function(party_id = 6, - parents_children_access = TRUE, - vb = options::opt("vb"), - rq = NULL) { - # Check parameters - assertthat::assert_that(is.numeric(party_id)) - assertthat::assert_that(party_id >= 1) - - assertthat::assert_that(length(parents_children_access) == 1) - assertthat::assert_that(is.logical(parents_children_access)) - - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - if (is.null(rq)) { - if (vb) { - message("\nNULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - - if (parents_children_access) { - endpoint <- GET_PARTY_BY_ID - } else { - endpoint <- GET_PARTY_NO_PARENTS_CHILDREN - } - prq <- rq %>% - httr2::req_url(sprintf(endpoint, party_id)) - - if (vb) message("Querying API for party id ", party_id, ".") - resp <- tryCatch( - httr2::req_perform(prq), - httr2_error = function(cnd) { - if (vb) - message("Error retrieving information for party_id ", party_id) - NULL - } - ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - httr2::resp_body_json(resp) - } -} diff --git a/R/get_session_by_id.R b/R/get_session_by_id.R index 55df7ab0..8f1d561b 100644 --- a/R/get_session_by_id.R +++ b/R/get_session_by_id.R @@ -28,72 +28,32 @@ get_session_by_id <- vol_id = 1, vb = options::opt("vb"), rq = NULL) { - + assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id > 0) assertthat::assert_that(length(session_id) == 1) - + assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id > 0) assertthat::assert_that(length(vol_id) == 1) - + assertthat::assert_that(is.logical(vb)) assertthat::assert_that(length(vb) == 1) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - # Handle NULL rq - if (is.null(rq)) { + + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + session <- perform_api_get( + path = sprintf(API_SESSION_DETAIL, vol_id, session_id), + rq = rq, + vb = vb + ) + + if (is.null(session)) { if (vb) { - message("\nNULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") + message("Cannot access requested session ", session_id, " in volume ", vol_id) } - rq <- databraryr::make_default_request() - } - - #-------------------------------------------------------------------------- - extract_session_metadata <- function(volume_json) { - - assertthat::assert_that(is.list(volume_json)) - - extract_single_session <- function(i, sessions) { - this_session <- sessions$value[[i]] - tibble::tibble(id = this_session$id, top = this_session$top, name = this_session$name) - } - - these_sessions <- tibble::enframe(volume_json$containers) - n_sessions <- dim(these_sessions)[1] - purrr::map(1:n_sessions, extract_single_session, these_sessions) %>% - purrr::list_rbind() - } - #-------------------------------------------------------------------------- - - volume_json <- NULL - volume_json <- get_volume_by_id(vol_id, vb, rq) - - if (!is.null(volume_json)) { - session_metadata <- extract_session_metadata(volume_json) - if (!(session_id %in% session_metadata$id)) { - if (vb) message("Session ", session_id, " not found.") - return(NULL) - } else { - rq <- rq %>% - httr2::req_url(sprintf(QUERY_SLOT, session_id)) - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) - NULL - ) - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - httr2::resp_body_json(resp) - } - } - } else { - if (vb) message("No data returned from volume ", vol_id) - NULL + return(NULL) } + + session } diff --git a/R/get_session_by_name.R b/R/get_session_by_name.R index 4f912b0e..83defef3 100644 --- a/R/get_session_by_name.R +++ b/R/get_session_by_name.R @@ -30,8 +30,9 @@ get_session_by_name <- vol_id = 1, vb = options::opt("vb"), rq = NULL) { - assertthat::is.string(session_name) + assertthat::assert_that(assertthat::is.string(session_name)) assertthat::assert_that(length(session_name) == 1) + assertthat::assert_that(!is.na(session_name)) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id > 0) @@ -40,52 +41,21 @@ get_session_by_name <- assertthat::assert_that(is.logical(vb)) assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - if (is.null(rq)) { - if (vb) { - message("\nNULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - - #-------------------------------------------------------------------------- - extract_session_metadata <- function(volume_json) { - assertthat::assert_that(is.list(volume_json)) - - extract_single_session <- function(i, sessions) { - this_session <- sessions$value[[i]] - tibble::tibble(id = this_session$id, - top = this_session$top, - name = this_session$name) - } - - these_sessions <- tibble::enframe(volume_json$containers) - n_sessions <- dim(these_sessions)[1] - purrr::map(1:n_sessions, extract_single_session, these_sessions) %>% - purrr::list_rbind() - } - #-------------------------------------------------------------------------- - - volume_json <- NULL - volume_json <- get_volume_by_id(vol_id, vb, rq) - session_metadata <- extract_session_metadata(volume_json) - - name <- NULL - name_matches <- dplyr::filter(session_metadata, name == session_name) - - if (is.null(name_matches)) { - message("No matches") - return(NULL) - } - if (dim(name_matches)[1] == 0) { - message("Empty array") + sessions <- collect_paginated_get( + path = sprintf(API_VOLUME_SESSIONS, vol_id), + params = list(search = session_name), + rq = rq, + vb = vb + ) + + if (is.null(sessions) || length(sessions) == 0) { + if (vb) message("No sessions named '", session_name, "' in volume ", vol_id) return(NULL) } - if (dim(name_matches)[1] > 1) { - message("\nMultiple sessions with name '", session_name, "'.") - } - purrr::map(name_matches$id, get_session_by_id, vol_id, rq = rq) + + purrr::map(sessions, function(session) { + databraryr::get_session_by_id(session_id = session$id, vol_id = vol_id, vb = vb, rq = rq) + }) } \ No newline at end of file diff --git a/R/get_user_by_id.R b/R/get_user_by_id.R new file mode 100644 index 00000000..52bc3ae0 --- /dev/null +++ b/R/get_user_by_id.R @@ -0,0 +1,46 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Get public profile information for a Databrary user +#' +#' @param user_id User identifier. +#' @inheritParams options_params +#' +#' @return A list with the user's public metadata. +#' @export +get_user_by_id <- function(user_id = 6, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(is.numeric(user_id), length(user_id) == 1, user_id > 0) + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + user <- perform_api_get( + path = sprintf(API_USER_DETAIL, user_id), + rq = rq, + vb = vb + ) + + if (is.null(user)) { + if (vb) message("User ", user_id, " not found or inaccessible.") + return(NULL) + } + + affiliation <- user$affiliation + institution_name <- affiliation$name + institution_id <- affiliation$id + + tibble::tibble( + id = user$id, + prename = user$first_name, + sortname = user$last_name, + email = user$email, + affiliation = institution_name, + affiliation_id = institution_id, + is_authorized_investigator = user$is_authorized_investigator, + has_avatar = user$has_avatar + ) %>% + as.list() +} + diff --git a/R/get_volume_by_id.R b/R/get_volume_by_id.R index b9a8167b..9480730e 100644 --- a/R/get_volume_by_id.R +++ b/R/get_volume_by_id.R @@ -33,28 +33,43 @@ get_volume_by_id <- function(vol_id = 1, assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) - # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("\nNULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - rq <- rq %>% - httr2::req_url(sprintf(GET_VOL_BY_ID, vol_id)) - if (vb) message("Retrieving data for vol_id ", vol_id, ".") - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) - NULL + + volume <- perform_api_get( + path = sprintf(API_VOLUME_DETAIL, vol_id), + rq = rq, + vb = vb ) - if (is.null(resp)) { + + if (is.null(volume)) { message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - httr2::resp_body_json(resp) + return(NULL) } + + tibble::tibble( + id = volume$id, + updated_at = volume$updated_at, + created_at = volume$created_at, + title = volume$title, + description = purrr::pluck(volume, "description", .default = NA_character_), + short_name = purrr::pluck(volume, "short_name", .default = NA_character_), + owner_connection = list(purrr::pluck(volume, "owner_connection", .default = NULL)), + owner_institution = list(volume$owner_institution), + sharing_level = volume$sharing_level, + access_level = volume$access_level, + has_admin_access = purrr::pluck(volume, "has_admin_access", .default = NA), + fundings = list(purrr::pluck(volume, "fundings", .default = NULL)), + coauthors = list(purrr::pluck(volume, "coauthors", .default = NULL)), + links = list(purrr::pluck(volume, "links", .default = NULL)), + enabled_categories = list(purrr::pluck(volume, "enabled_categories", .default = NULL)), + enabled_metrics = list(purrr::pluck(volume, "enabled_metrics", .default = NULL)), + citation = list(purrr::pluck(volume, "citation", .default = NULL)), + session_count = volume$session_count, + session_count_shared = volume$session_count_shared, + participant_count = purrr::pluck(volume, "participant_count", .default = NA_integer_), + participant_gender_counts = list(purrr::pluck(volume, "participant_gender_counts", .default = NULL)), + file_counts = list(volume$file_counts), + thumbnail = list(purrr::pluck(volume, "thumbnail", .default = NULL)) + ) } \ No newline at end of file diff --git a/R/list_authorized_investigators.R b/R/list_authorized_investigators.R index 43b1a73d..e6419454 100644 --- a/R/list_authorized_investigators.R +++ b/R/list_authorized_investigators.R @@ -1,69 +1,30 @@ #' @eval options::as_params() #' @name options_params -#' +#' NULL -#' List Authorized Investigators at Institution -#' -#' @param party_id Target party ID. -#' @param rq An `httr2`-style request object. If NULL, then a new request will -#' be generated using `make_default_request()`. -#' -#' @returns A data frame with information the institution's authorized -#' investigators. +#' List authorized investigators for an institution #' -#' @inheritParams options_params +#' @inheritParams list_institution_affiliates #' -#' @examples -#' \donttest{ -#' \dontrun{ -#' list_institutional_affiliates() # Default is Penn State (party 12) -#' } -#' } +#' @return Tibble of investigators; NULL if none. #' @export -list_authorized_investigators <- function(party_id = 12, +list_authorized_investigators <- function(institution_id = 12, vb = options::opt("vb"), rq = NULL) { - assertthat::is.number(party_id) - assertthat::assert_that(is.numeric(party_id)) - assertthat::assert_that(party_id >= 1) - assertthat::assert_that(length(party_id) == 1) - - assertthat::assert_that(is.logical(vb)) - assertthat::assert_that(length(vb) == 1) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - - this_party <- databraryr::get_party_by_id(party_id, vb = vb, rq = rq) - - if (is.null(this_party)) { - if (vb) - message("No data for party ", party_id) - return(NULL) - } - - if (!("institution" %in% names(this_party))) { - if (vb) - message("Party ", party_id, " not an institution.") + assertthat::assert_that(is.numeric(institution_id), length(institution_id) == 1, institution_id > 0) + assertthat::assert_that(is.logical(vb), length(vb) == 1) + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + affiliates <- list_institution_affiliates(institution_id, vb = vb, rq = rq) + if (is.null(affiliates)) { return(NULL) } - - if (dim(as.data.frame(this_party$children))[1] == 0) { - if (vb) - message("Party ", party_id, " has no affiliates.") + + investigators <- affiliates |> dplyr::filter(.data$role == "investigator") + if (nrow(investigators) == 0) { return(NULL) } - - purrr::map(this_party$children, as.data.frame, .progress = TRUE) %>% - purrr::list_rbind() -} \ No newline at end of file + investigators +} + diff --git a/R/list_folder_assets.R b/R/list_folder_assets.R new file mode 100644 index 00000000..b701f33c --- /dev/null +++ b/R/list_folder_assets.R @@ -0,0 +1,102 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' List Assets Within a Databrary Folder. +#' +#' @param folder_id Folder identifier scoped to the given volume. +#' @param vol_id Volume containing the folder. Required for Django API calls. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @returns A tibble with metadata for files contained in the folder, or +#' `NULL` when the folder has no accessible assets. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' list_folder_assets(folder_id = 1, vol_id = 1) +#' } +#' } +#' @export +list_folder_assets <- function(folder_id = 1, + vol_id = NULL, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(length(folder_id) == 1) + assertthat::assert_that(is.numeric(folder_id)) + assertthat::assert_that(folder_id >= 1) + + if (is.null(vol_id)) { + stop("vol_id must be supplied for list_folder_assets(); folder identifiers are scoped to volumes.", + call. = FALSE) + } + + assertthat::assert_that(length(vol_id) == 1) + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(vol_id >= 1) + + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + folder <- databraryr::get_folder_by_id( + folder_id = folder_id, + vol_id = vol_id, + vb = vb, + rq = rq + ) + + if (is.null(folder)) { + return(NULL) + } + + files <- collect_paginated_get( + path = sprintf(API_FOLDER_FILES, vol_id, folder_id), + rq = rq, + vb = vb + ) + + if (is.null(files) || length(files) == 0) { + if (vb) { + message("No assets for folder_id ", folder_id) + } + return(NULL) + } + + file_rows <- purrr::map_dfr(files, function(file) { + format <- file$format + uploader <- file$uploader + + tibble::tibble( + asset_id = file$id, + asset_name = file$name, + asset_permission = file$release_level, + asset_size = file$size, + asset_mime_type = format$mimetype, + asset_format_id = format$id, + asset_format_name = format$name, + asset_duration = file$duration, + asset_created_at = file$created_at, + asset_updated_at = file$updated_at, + asset_uploader_id = uploader$id, + asset_uploader_first_name = uploader$first_name, + asset_uploader_last_name = uploader$last_name, + asset_sha1 = file$sha1, + asset_thumbnail_url = file$thumbnail_url + ) + }) + + file_rows %>% + dplyr::mutate( + folder_id = folder_id, + vol_id = vol_id, + folder_name = folder$name, + folder_release = folder$release_level, + folder_source_date = folder$source_date + ) +} + diff --git a/R/list_institution_affiliates.R b/R/list_institution_affiliates.R new file mode 100644 index 00000000..127c1a1a --- /dev/null +++ b/R/list_institution_affiliates.R @@ -0,0 +1,45 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' List affiliates for an institution +#' +#' @param institution_id Institution identifier. +#' @inheritParams options_params +#' +#' @return Tibble of affiliates with roles and expiration dates. +#' @export +list_institution_affiliates <- function(institution_id = 12, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(is.numeric(institution_id), length(institution_id) == 1, institution_id > 0) + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + affiliates <- collect_paginated_get( + path = sprintf(API_INSTITUTION_AFFILIATES, institution_id), + rq = rq, + vb = vb + ) + + if (is.null(affiliates) || length(affiliates) == 0) { + if (vb) message("No affiliates for institution ", institution_id) + return(NULL) + } + + purrr::map_dfr(affiliates, function(entry) { + user <- entry$user + tibble::tibble( + institution_id = institution_id, + role = entry$role, + access_level = entry$access_level, + user_id = user$id, + user_prename = user$first_name, + user_sortname = user$last_name, + user_affiliation = user$affiliation$name, + user_affiliation_id = user$affiliation$id, + expiration_date = entry$expiration_date + ) + }) +} + diff --git a/R/list_party_affiliates.R b/R/list_party_affiliates.R deleted file mode 100644 index 0e564b1f..00000000 --- a/R/list_party_affiliates.R +++ /dev/null @@ -1,77 +0,0 @@ -#' @eval options::as_params() -#' @name options_params -#' -NULL - -#' List Affiliates For A Party -#' -#' @param party_id Target party ID. -#' @param rq An `httr2` request object. Defaults to NULL. -#' -#' @returns A data frame with information about a party's affiliates. -#' -#' @inheritParams options_params -#' -#' @examples -#' \donttest{ -#' list_party_affiliates() # Default is Rick Gilmore (party 6) -#' } -#' @export -list_party_affiliates <- function(party_id = 6, - vb = options::opt("vb"), - rq = NULL) { - # Check parameters - assertthat::assert_that(length(party_id) == 1) - assertthat::assert_that(is.numeric(party_id)) - assertthat::assert_that(party_id > 0) - - assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - - if (vb) - message(paste0("Getting affiliates for party ", party_id, ".")) - - g <- databraryr::get_party_by_id(party_id = party_id, vb = vb, rq = rq) - - party.id <- NULL - party.prename <- NULL - party.sortname <- NULL - party.affiliation <- NULL - affiliate_id <- NULL - affiliate_sortname <- NULL - affiliate_prename <- NULL - affiliate_affiliation <- NULL - - if (!is.null(g)) { - if (vb) - message(paste0("Retrieving data for party ", party_id, ".")) - purrr::map(g$children, as.data.frame) %>% - purrr::list_rbind() %>% - dplyr::rename( - affiliate_id = party.id, - affiliate_sortname = party.sortname, - affiliate_prename = party.prename, - affiliate_affiliation = party.affiliation - ) %>% - dplyr::select( - affiliate_id, - affiliate_sortname, - affiliate_prename, - affiliate_affiliation - ) - } else { - if (vb) - message(paste0("No data for party ", party_id, ".")) - NULL - } -} diff --git a/R/list_party_sponsors.R b/R/list_party_sponsors.R deleted file mode 100644 index e98802b3..00000000 --- a/R/list_party_sponsors.R +++ /dev/null @@ -1,99 +0,0 @@ -#' @eval options::as_params() -#' @name options_params -#' -NULL - -#' List Sponsors For A Party -#' -#' @param party_id Target party ID. -#' @param rq An `httr2`-style request object. If NULL, then a new request will -#' be generated using `make_default_request()`. -#' -#' @returns A data frame with information about a party's sponsors. -#' -#' @inheritParams options_params -#' -#' @examples -#' \donttest{ -#' \dontrun{ -#' list_party_sponsors() # Default is Rick Gilmore (party 6) -#' } -#' } -#' -#' @export -list_party_sponsors <- function(party_id = 6, - vb = options::opt("vb"), - rq = NULL) { - # Check parameters - assertthat::assert_that(length(party_id) == 1) - assertthat::assert_that(is.numeric(party_id)) - assertthat::assert_that(party_id > 0) - - assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - - if (vb) - message(paste0("Getting sponsors for party ", party_id, ".")) - - g <- databraryr::get_party_by_id(party_id = party_id, - vb = vb, - rq = rq) - - if (!is.null(g)) { - if (vb) - message(paste0("Retrieving data for party ", party_id, ".")) - - party.id <- NULL - party.sortname <- NULL - party.affiliation <- NULL - party_sortname <- NULL - party_prename <- NULL - party_affiliation <- NULL - party_url <- NULL - sponsor_id <- NULL - sponsor_sortname <- NULL - sponsor_affiliation <- NULL - - purrr::map(g$parents, as.data.frame) %>% - purrr::list_rbind() %>% - # TODO(ROG): Handle cases when other variables exist - dplyr::select(party.id, party.sortname, party.affiliation) %>% - dplyr::rename( - sponsor_id = party.id, - sponsor_sortname = party.sortname, - sponsor_affiliation = party.affiliation - ) %>% - dplyr::mutate( - party_id = party_id, - party_sortname = g$sortname, - party_prename = g$prename, - party_affiliation = g$affiliation, - party_url = g$url - ) %>% - dplyr::select( - party_id, - party_sortname, - party_prename, - party_affiliation, - party_url, - sponsor_id, - sponsor_sortname, - sponsor_affiliation - ) - } else { - if (vb) - message(paste0("No data for party ", party_id, ".")) - NULL - } -} diff --git a/R/list_party_volumes.R b/R/list_party_volumes.R deleted file mode 100644 index 6c61c0c9..00000000 --- a/R/list_party_volumes.R +++ /dev/null @@ -1,104 +0,0 @@ -#' @eval options::as_params() -#' @name options_params -#' -NULL - -#' List Volumes A Party Has Access To -#' -#' @param party_id Target party ID. -#' @param rq An `httr2`-style request object. If NULL, then a new request will -#' be generated using `make_default_request()`. -#' -#' @returns A data frame with information about a party's sponsors. -#' -#' @inheritParams options_params -#' -#' @examples -#' \donttest{ -#' \dontrun{ -#' list_party_volumes() # Default is Rick Gilmore (party 6) -#' } -#' } -#' @export -list_party_volumes <- function(party_id = 6, - vb = options::opt("vb"), - rq = NULL) { - # Check parameters - assertthat::assert_that(length(party_id) == 1) - assertthat::assert_that(is.numeric(party_id)) - assertthat::assert_that(party_id > 0) - - assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - - vol_id <- NULL - - if (vb) - message(paste0("Retrieving data for party ", party_id, ".")) - party_info <- databraryr::get_party_by_id(party_id = party_id, vb = vb, - rq = rq) - - if (!is.null(party_info)) { - if (vb) - message(paste0("Info retrieved. Filtering.")) - purrr::map(party_info$access, extract_vol_fr_party) %>% - purrr::list_rbind() %>% - dplyr::mutate( - party_id = party_id, - party_prename = party_info$prename, - party_sortname = party_info$sortname, - party_affiliation = party_info$affiliation - ) %>% - dplyr::arrange(vol_id) - } else { - if (vb) - message(paste0("No data for party ", party_id, ".")) - party_info - } -} - -#--------------------------------------------------------------------------- -# This is a private, not exported, -# helper function for list_party_volumes() -# -extract_vol_fr_party <- function(p_info) { - assertthat::assert_that(is.list(p_info)) - - this_vol <- p_info$volume - - vol_names <- names(this_vol) - assertthat::assert_that("id" %in% vol_names) - assertthat::assert_that("name" %in% vol_names) - assertthat::assert_that("body" %in% vol_names) - assertthat::assert_that("creation" %in% vol_names) - assertthat::assert_that("permission" %in% vol_names) - - vol_id <- this_vol$id - vol_name <- this_vol$name - vol_body <- this_vol$body - if (!("alias" %in% vol_names)) { - vol_alias <- NA - } else { - vol_alias <- this_vol$alias - } - vol_creation <- this_vol$creation - vol_permission <- this_vol$permission - - tibble::tibble(vol_id, - vol_name, - vol_body, - vol_alias, - vol_creation, - vol_permission) -} \ No newline at end of file diff --git a/R/list_session_activity.R b/R/list_session_activity.R index abdf35a7..915906e4 100644 --- a/R/list_session_activity.R +++ b/R/list_session_activity.R @@ -1,71 +1,144 @@ #' @eval options::as_params() #' @name options_params -#' +#' NULL #' List Activity History in Databrary Session. #' -#' If a user has access to a volume and session, this function returns the -#' history of modifications to that session. +#' For an accessible session, returns the logged history events associated with +#' the session. Requires authenticated access with sufficient permissions. #' -#' @param session_id Selected session/slot number. -#' @param rq An `httr2` request object. Defaults to NULL. To access the activity -#' history on a volume a user has privileges on. Create a request -#' (`rq <- make_default_request()`); login using `make_login_client(rq = rq)`; -#' then run `list_session_activity(session_id = , rq = rq)` - -#' @returns A list with the activity history on a session/slot. -#' -#' @inheritParams options_params +#' @param vol_id Volume identifier (required by the Django API). +#' @param session_id Session identifier. +#' @param rq An `httr2` request object. Defaults to `NULL`. When `NULL`, a +#' default request is generated, but this will only permit public information +#' to be returned. #' -#' @examples -#' \donttest{ -#' \dontrun{ -#' # The following will only return output if the user has write privileges -#' # on the session. +#' @returns A tibble with the activity history for a session, or `NULL` when +#' no data is available. +#' +#' @inheritParams options_params #' -#' list_session_activity(session_id = 6256, vb = FALSE) +#' @examples +#' \\donttest{ +#' \\dontrun{ +#' list_session_activity(vol_id = 1892, session_id = 76113) #' } #' } #' @export list_session_activity <- - function(session_id = 6256, + function(vol_id = 1892, + session_id = 76113, vb = options::opt("vb"), rq = NULL) { # Check parameters + assertthat::assert_that(length(vol_id) == 1) + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(vol_id > 0) + assertthat::assert_that(length(session_id) == 1) assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id > 0) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - + + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } rq <- databraryr::make_default_request() } - rq <- rq %>% - httr2::req_url(sprintf(GET_SESSION_ACTIVITY, session_id)) - - if (vb) message("Retrieving activity for session id, ", session_id, ".") - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) { - NULL + rq <- httr2::req_timeout(rq, REQUEST_TIMEOUT_VERY_LONG) + + activities <- collect_paginated_get( + path = sprintf(API_VOLUME_HISTORY, vol_id), + rq = rq, + vb = vb + ) + + if (is.null(activities) || length(activities) == 0) { + if (vb) { + message("No activity history available for volume ", vol_id) } + return(NULL) + } + + session_details <- databraryr::get_session_by_id( + session_id = session_id, + vol_id = vol_id, + vb = vb, + rq = rq ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - httr2::resp_body_json(resp) + session_name <- NULL + if (!is.null(session_details)) { + session_name <- session_details$name + } + + session_entries <- purrr::keep(activities, function(entry) { + session_identifier <- entry$session_id + if (is.null(session_identifier) && !is.null(entry$session)) { + session_value <- entry$session + if (is.list(session_value) && !is.null(session_value$id)) { + session_identifier <- session_value$id + } else { + session_identifier <- session_value + } + } + + if (!is.null(session_identifier)) { + return(isTRUE(session_identifier == session_id)) + } + + if (!is.null(session_name) && !is.null(entry$name)) { + return(isTRUE(entry$name == session_name)) + } + + FALSE + }) + + if (length(session_entries) == 0) { + if (vb) { + message("No activity history for session ", session_id, " within volume ", vol_id) + } + return(NULL) } - #TODO: Reformat response. + + purrr::map_dfr(session_entries, function(entry) { + history_user <- entry$history_user + folder_id <- entry$folder_id + if (is.null(folder_id) && !is.null(entry$folder)) { + folder <- entry$folder + if (is.list(folder) && !is.null(folder$id)) { + folder_id <- folder$id + } else { + folder_id <- folder + } + } + + safe_int <- function(value) { + if (is.null(value)) NA_integer_ else value + } + + safe_chr <- function(value) { + if (is.null(value)) NA_character_ else value + } + + tibble::tibble( + event_type = entry$type, + event_timestamp = entry$timestamp, + history_id = safe_int(entry$history_id), + history_user_id = safe_int(history_user$id), + history_user_email = safe_chr(history_user$email), + history_user_first_name = safe_chr(history_user$first_name), + history_user_last_name = safe_chr(history_user$last_name), + ip_address = entry$ip_address, + changed_fields = list(entry$changed_fields), + changed_data = list(entry$changed_data), + volume_id = vol_id, + session_id = session_id, + session_name = safe_chr(entry$name), + folder_id = safe_int(folder_id), + deleted_at = entry$deleted_at + ) + }) } diff --git a/R/list_session_assets.R b/R/list_session_assets.R index c7e0a0e0..dc24c69a 100644 --- a/R/list_session_assets.R +++ b/R/list_session_assets.R @@ -14,6 +14,9 @@ NULL #' #' @param session_id An integer. A Databrary session number. Default is 9807, #' the "materials" folder from Databrary volume 1. +#' @param vol_id Optional integer. The volume containing the session. Recent +#' versions of the Databrary API require this value to be supplied because +#' session identifiers are scoped to volumes. #' @param rq An `httr2` request object. If NULL, a default request is generated #' from databraryr::make_default_request(). #' @@ -29,99 +32,75 @@ NULL #' } #' @export list_session_assets <- function(session_id = 9807, + vol_id = NULL, vb = options::opt("vb"), rq = NULL) { assertthat::assert_that(length(session_id) == 1) assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id >= 1) + if (is.null(vol_id)) { + stop("vol_id must be supplied for list_session_assets(); session identifiers are scoped to volumes.", + call. = FALSE) + } + assertthat::assert_that(length(vol_id) == 1) + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(vol_id >= 1) assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) - # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() + session <- databraryr::get_session_by_id( + session_id = session_id, + vol_id = vol_id, + vb = vb, + rq = rq + ) + + if (is.null(session)) { + return(NULL) } - - this_rq <- rq %>% - httr2::req_url(sprintf(QUERY_SLOT, session_id)) %>% - httr2::req_progress() - - if (vb) - message("Retrieving assets from session id ", session_id, ".") - resp <- tryCatch( - httr2::req_perform(this_rq), - httr2_error = function(cnd) - NULL + + files <- collect_paginated_get( + path = sprintf(API_SESSION_FILES, vol_id, session_id), + rq = rq, + vb = vb ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - session_list <- httr2::resp_body_json(resp) - if ("assets" %in% names(session_list)) { - assets_df <- purrr::map(session_list$assets, as.data.frame) %>% - purrr::list_rbind() - - # ignore empty sessions - if (dim(assets_df)[1] == 0) - return(NULL) - - if (!('size' %in% names(assets_df))) - assets_df$size <- NA - if (!('duration' %in% names(assets_df))) - assets_df$duration <- NA - if (!('name' %in% names(assets_df))) - assets_df$name <- NA - - id <- NULL - format <- NULL - name <- NULL - duration <- NULL - permission <- NULL - size <- NULL - asset_format_id <- NULL - - assets_df <- assets_df %>% - dplyr::select(id, format, duration, name, permission, size) %>% - dplyr::rename( - asset_id = id, - asset_format_id = format, - asset_name = name, - asset_duration = duration, - asset_permission = permission, - asset_size = size - ) - - format_id <- NULL - format_mimetype <- NULL - format_extension <- NULL - format_name <- NULL - - # Gather asset format info - asset_formats_df <- list_asset_formats(vb = vb) %>% - dplyr::select(format_id, - format_mimetype, - format_extension, - format_name) - - # Join assets with asset format info - out_df <- dplyr::left_join(assets_df, - asset_formats_df, - by = dplyr::join_by(asset_format_id == - format_id)) %>% - dplyr::mutate(session_id = session_id) - - out_df - } else { - if (vb) - message("No assets for session_id ", session_id) - session_list - } + + if (is.null(files) || length(files) == 0) { + if (vb) + message("No assets for session_id ", session_id) + return(NULL) } + + asset_rows <- purrr::map_dfr(files, function(file) { + format <- file$format + uploader <- file$uploader + + tibble::tibble( + asset_id = file$id, + asset_name = file$name, + asset_permission = file$release_level, + asset_size = file$size, + asset_mime_type = format$mimetype, + asset_format_id = format$id, + asset_format_name = format$name, + asset_duration = file$duration, + asset_created_at = file$created_at, + asset_updated_at = file$updated_at, + asset_uploader_id = uploader$id, + asset_uploader_first_name = uploader$first_name, + asset_uploader_last_name = uploader$last_name, + asset_sha1 = file$sha1, + asset_thumbnail_url = file$thumbnail_url + ) + }) + + asset_rows %>% + dplyr::mutate( + session_id = session_id, + vol_id = vol_id, + session_name = session$name, + session_release = session$release_level, + session_date = session$source_date + ) } \ No newline at end of file diff --git a/R/list_sponsors.R b/R/list_sponsors.R deleted file mode 100644 index b10c7a1d..00000000 --- a/R/list_sponsors.R +++ /dev/null @@ -1,72 +0,0 @@ -#' @eval options::as_params() -#' @name options_params -#' -NULL - -#' List Sponsors For A Party -#' -#' @param party_id Target party ID. -#' @param rq An `httr2`-style request object. If NULL, then a new request will -#' be generated using `make_default_request()`. -#' -#' @returns A data frame with information about a party's sponsors. -#' -#' @inheritParams options_params -#' -#' @examples -#' \donttest{ -#' \dontrun{ -#' list_sponsors() # Default is Rick Gilmore (party 6) -#' } -#' } -#' @export -list_sponsors <- function(party_id = 6, - vb = options::opt("vb"), - rq = NULL) { - - # Check parameters - assertthat::assert_that(length(party_id) == 1) - assertthat::assert_that(is.numeric(party_id)) - assertthat::assert_that(party_id > 0) - assertthat::assert_that(is.logical(vb)) - - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - } - message("\nNot logged in. Only public information will be returned.") - rq <- databraryr::make_default_request() - } - - if (vb) - message(paste0("Getting sponsors for party ", party_id, ".")) - - g <- databraryr::get_party_by_id(party_id = party_id, vb = vb, rq = rq) - - party.id <- NULL - party.sortname <- NULL - party.affiliation <- NULL - party.institution <- NULL - party.url <- NULL - - if (!is.null(g)) { - if (vb) - message(paste0("Retrieving data for party ", party_id, ".")) - purrr::map(g$parents, as.data.frame) %>% - purrr::list_rbind() %>% - dplyr::rename(sponsor_id = party.id, - sponsor_sortname = party.sortname, - sponsor_affiliation = party.affiliation, - sponsor_institution = party.institution, - sponsor_url = party.url) %>% - dplyr::mutate(party_id = party_id, - party_sortname = g$sortname, - party_prename = g$prename, - party_affiliation = g$affiliation, - party_url = g$url) - } else { - if (vb) - message(paste0("No data for party ", party_id, ".")) - NULL - } -} diff --git a/R/list_user_affiliates.R b/R/list_user_affiliates.R new file mode 100644 index 00000000..28876019 --- /dev/null +++ b/R/list_user_affiliates.R @@ -0,0 +1,39 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' List affiliates for a user +#' +#' @param user_id User identifier. +#' @inheritParams options_params +#' +#' @return Tibble of affiliates for the user. +#' @export +list_user_affiliates <- function(user_id = 6, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(is.numeric(user_id), length(user_id) == 1, user_id > 0) + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + affiliates <- collect_paginated_get( + path = sprintf(API_USER_AFFILIATES, user_id), + rq = rq, + vb = vb + ) + + if (is.null(affiliates) || length(affiliates) == 0) { + if (vb) message("No affiliates for user ", user_id) + return(NULL) + } + + purrr::map_dfr(affiliates, function(entry) { + tibble::tibble( + affiliate_user = entry$user, + access_level = entry$access_level, + role = entry$role, + expiration_date = entry$expiration_date + ) + }) +} + diff --git a/R/list_user_history.R b/R/list_user_history.R new file mode 100644 index 00000000..baa70ce5 --- /dev/null +++ b/R/list_user_history.R @@ -0,0 +1,65 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' List Account Activity For A Databrary User. +#' +#' @description Retrieve the OAuth and login activity history for a specific +#' user. Access is restricted to administrators and authorized investigators +#' with sufficient privileges. +#' +#' @param user_id Target user identifier. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A tibble containing authentication and activity events for the +#' selected user, or `NULL` when no entries are available. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' list_user_history(user_id = 22582) +#' } +#' } +#' @export +list_user_history <- function(user_id = 22582, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(is.numeric(user_id)) + assertthat::assert_that(length(user_id) == 1) + assertthat::assert_that(user_id > 0) + + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + history <- collect_paginated_get( + path = sprintf(API_USERS_HISTORY, user_id), + rq = rq, + vb = vb + ) + + if (is.null(history) || length(history) == 0) { + if (vb) { + message("No activity history available for user ", user_id) + } + return(NULL) + } + + purrr::map_dfr(history, function(entry) { + tibble::tibble( + user_id = user_id, + history_id = entry$id, + history_email = entry$email, + history_ip_address = entry$ip_address, + history_successful = entry$successful, + history_type = entry$type, + history_timestamp = entry$timestamp + ) + }) +} + + diff --git a/R/list_user_sponsors.R b/R/list_user_sponsors.R new file mode 100644 index 00000000..880e3d58 --- /dev/null +++ b/R/list_user_sponsors.R @@ -0,0 +1,50 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' List sponsorships for a user +#' +#' @param user_id User identifier. +#' @inheritParams options_params +#' +#' @return Tibble of sponsors for the user. +#' @export +list_user_sponsors <- function(user_id = 6, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(is.numeric(user_id), length(user_id) == 1, user_id > 0) + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + sponsorships <- collect_paginated_get( + path = sprintf(API_USER_SPONSORSHIPS, user_id), + rq = rq, + vb = vb + ) + + if (is.null(sponsorships) || length(sponsorships) == 0) { + if (vb) message("No sponsorships for user ", user_id) + return(NULL) + } + + user <- get_user_by_id(user_id, vb = vb, rq = rq) + + purrr::map_dfr(sponsorships, function(entry) { + sponsor <- entry$user + tibble::tibble( + user_id = user$id, + user_prename = user$prename, + user_sortname = user$sortname, + user_affiliation = user$affiliation, + sponsor_id = sponsor$id, + sponsor_prename = sponsor$first_name, + sponsor_sortname = sponsor$last_name, + sponsor_affiliation = sponsor$affiliation$name, + sponsor_affiliation_id = sponsor$affiliation$id, + access_level = entry$access_level, + role = entry$role, + expiration_date = entry$expiration_date + ) + }) +} + diff --git a/R/list_user_volumes.R b/R/list_user_volumes.R new file mode 100644 index 00000000..5ed63a00 --- /dev/null +++ b/R/list_user_volumes.R @@ -0,0 +1,52 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' List volumes associated with a user +#' +#' @param user_id User identifier. +#' @inheritParams options_params +#' +#' @return Tibble of volumes the user owns or collaborates on. +#' @export +list_user_volumes <- function(user_id = 6, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(is.numeric(user_id), length(user_id) == 1, user_id > 0) + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + volumes <- collect_paginated_get( + path = sprintf(API_USER_VOLUMES, user_id), + rq = rq, + vb = vb + ) + + if (is.null(volumes) || length(volumes) == 0) { + if (vb) message("No volume data for user ", user_id) + return(NULL) + } + + user <- get_user_by_id(user_id, vb = vb, rq = rq) + user_df <- tibble::as_tibble(user) + + purrr::map(volumes, function(entry) { + tibble::tibble( + vol_id = entry$id, + vol_name = entry$title, + vol_description = entry$description, + vol_short_name = entry$short_name, + vol_created_at = entry$created_at, + vol_updated_at = entry$updated_at, + vol_access_level = entry$access_level, + vol_sharing_level = entry$sharing_level + ) + }) %>% + purrr::list_rbind() %>% + dplyr::mutate(user_id = user_df$id, + user_prename = user_df$prename, + user_sortname = user_df$sortname, + user_affiliation = user_df$affiliation) %>% + dplyr::arrange(vol_id) +} + diff --git a/R/list_users.R b/R/list_users.R new file mode 100644 index 00000000..745916a5 --- /dev/null +++ b/R/list_users.R @@ -0,0 +1,115 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' List Databrary Users. +#' +#' @description Retrieve directory metadata for Databrary users. Results can be +#' filtered by name or restricted to specific account types using optional +#' parameters. +#' +#' @param search Optional character string used to filter results by name or +#' email address. +#' @param include_suspended Optional logical value. When `TRUE`, suspended +#' accounts are included in the response. +#' @param exclude_self Optional logical value. When `TRUE`, the authenticated +#' user is omitted from the results. +#' @param is_authorized_investigator Optional logical value restricting the +#' response to authorized investigators. +#' @param has_api_access Optional logical value restricting the response to +#' accounts with API access enabled. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A tibble containing directory metadata for each user, or `NULL` when +#' no results are available for the supplied filters. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' list_users(search = "gilmore") +#' } +#' } +#' @export +list_users <- function(search = NULL, + include_suspended = NULL, + exclude_self = NULL, + is_authorized_investigator = NULL, + has_api_access = NULL, + vb = options::opt("vb"), + rq = NULL) { + if (!is.null(search)) { + assertthat::assert_that(assertthat::is.string(search)) + } + + validate_flag <- function(value, name) { + if (!is.null(value)) { + assertthat::assert_that(length(value) == 1) + assertthat::assert_that(is.logical(value), msg = paste0(name, " must be logical.")) + } + } + + validate_flag(include_suspended, "include_suspended") + validate_flag(exclude_self, "exclude_self") + validate_flag(is_authorized_investigator, "is_authorized_investigator") + validate_flag(has_api_access, "has_api_access") + + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + users <- collect_paginated_get( + path = API_USERS, + params = list( + search = search, + include_suspended = include_suspended, + exclude_self = exclude_self, + is_authorized_investigator = is_authorized_investigator, + has_api_access = has_api_access + ), + rq = rq, + vb = vb + ) + + if (is.null(users) || length(users) == 0) { + if (vb) { + message("No users matched the supplied filters.") + } + return(NULL) + } + + purrr::map_dfr(users, function(user) { + affiliation <- user$affiliation + + affiliation_id <- if (!is.null(affiliation)) affiliation$id else NA_integer_ + affiliation_name <- if (!is.null(affiliation)) affiliation$name else NA_character_ + + suspended_by <- user$suspended_by + suspended_by_id <- if (!is.null(suspended_by)) suspended_by$id else NA_integer_ + suspended_by_email <- if (!is.null(suspended_by)) suspended_by$email else NA_character_ + + tibble::tibble( + user_id = user$id, + user_first_name = user$first_name, + user_last_name = user$last_name, + user_email = user$email, + user_orcid = if (is.null(user$orcid)) NA_character_ else user$orcid, + user_url = if (is.null(user$url)) NA_character_ else user$url, + user_affiliation_id = affiliation_id, + user_affiliation_name = affiliation_name, + user_is_authorized_investigator = user$is_authorized_investigator, + user_has_avatar = user$has_avatar, + user_is_suspended = if (is.null(user$is_suspended)) NA else user$is_suspended, + user_suspended_by_id = suspended_by_id, + user_suspended_by_email = suspended_by_email, + user_institution_sponsorships = list(user$institution_sponsorships), + user_current_affiliates = list(user$current_affiliates), + user_current_sponsors = list(user$current_sponsors) + ) + }) +} + + diff --git a/R/list_volume_activity.R b/R/list_volume_activity.R index 4c42ba5f..cbef27f8 100644 --- a/R/list_volume_activity.R +++ b/R/list_volume_activity.R @@ -21,12 +21,12 @@ NULL #' # The following will only return output if the user has write privileges #' # on the volume. #' -#' list_volume_activity(vol_id = 1) # Activity on volume 1. +#' list_volume_activity(vol_id = 1892) # Activity on volume 1892. #' } #' } #' @export list_volume_activity <- - function(vol_id = 1, + function(vol_id = 1892, vb = options::opt("vb"), rq = NULL) { # Check parameters @@ -38,34 +38,70 @@ list_volume_activity <- assertthat::assert_that(is.logical(vb)) if (vb) message('list_volume_activity()...') - + if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } rq <- databraryr::make_default_request() } - rq <- rq %>% - httr2::req_url(sprintf(GET_VOLUME_ACTIVITY, vol_id)) - - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) { - NULL - } + rq <- httr2::req_timeout(rq, REQUEST_TIMEOUT_VERY_LONG) + + activities <- collect_paginated_get( + path = sprintf(API_VOLUME_HISTORY, vol_id), + rq = rq, + vb = vb ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - res <- httr2::resp_body_json(resp) - if (!(is.null(res))) { - res - } else { - if (vb) message("Unable to convert from JSON.") - return(NULL) - } + + if (is.null(activities)) { + if (vb) + message("Cannot access requested resource on Databrary. Exiting.") + return(NULL) } + + purrr::map_dfr(activities, function(entry) { + history_user <- entry$history_user + folder_id <- entry$folder_id + if (is.null(folder_id) && !is.null(entry$folder)) { + folder <- entry$folder + if (is.list(folder) && !is.null(folder$id)) { + folder_id <- folder$id + } else { + folder_id <- folder + } + } + + session_id <- entry$session_id + if (is.null(session_id) && !is.null(entry$session)) { + session <- entry$session + if (is.list(session) && !is.null(session$id)) { + session_id <- session$id + } else { + session_id <- session + } + } + + safe_int <- function(value) { + if (is.null(value)) NA_integer_ else value + } + + safe_chr <- function(value) { + if (is.null(value)) NA_character_ else value + } + + tibble::tibble( + event_type = entry$type, + event_timestamp = entry$timestamp, + history_id = safe_int(entry$history_id), + history_user_id = safe_int(history_user$id), + history_user_email = safe_chr(history_user$email), + history_user_first_name = safe_chr(history_user$first_name), + history_user_last_name = safe_chr(history_user$last_name), + ip_address = entry$ip_address, + changed_fields = list(entry$changed_fields), + changed_data = list(entry$changed_data), + volume_id = vol_id, + session_id = safe_int(session_id), + session_name = safe_chr(entry$name), + folder_id = safe_int(folder_id), + deleted_at = entry$deleted_at + ) + }) } diff --git a/R/list_volume_assets.R b/R/list_volume_assets.R index 4d5bb35a..d9c038ca 100644 --- a/R/list_volume_assets.R +++ b/R/list_volume_assets.R @@ -39,99 +39,62 @@ list_volume_assets <- function(vol_id = 1, rq <- databraryr::make_default_request() } - vol_list <- databraryr::get_volume_by_id(vol_id, vb, rq) - if (!("containers" %in% names(vol_list))) { + sessions <- collect_paginated_get( + path = sprintf(API_VOLUME_SESSIONS, vol_id), + rq = rq, + vb = vb + ) + + if (is.null(sessions) || length(sessions) == 0) { if (vb) - message("No session/containers data from volume ", vol_id) + message("No sessions found for volume ", vol_id) return(NULL) } - - if (vb) - message("Extracting asset info...") - this_volume_assets_df <- - purrr::map( - vol_list$containers, - get_assets_from_session, - ignore_materials = FALSE, - .progress = TRUE - ) %>% - purrr::list_rbind() - - if (dim(this_volume_assets_df)[1] == 0) { + + files <- purrr::map(sessions, function(session) { + session_files <- collect_paginated_get( + path = sprintf(API_SESSION_FILES, vol_id, session$id), + rq = rq, + vb = vb + ) + + if (is.null(session_files) || length(session_files) == 0) { + return(NULL) + } + + purrr::map(session_files, function(file) { + format <- file$format + uploader <- file$uploader + tibble::tibble( + asset_id = file$id, + asset_name = file$name, + asset_permission = file$release_level, + asset_size = file$size, + asset_mime_type = format$mimetype, + asset_format_id = format$id, + asset_format_name = format$name, + asset_duration = file$duration, + asset_created_at = file$created_at, + asset_updated_at = file$updated_at, + asset_uploader_id = uploader$id, + asset_uploader_first_name = uploader$first_name, + asset_uploader_last_name = uploader$last_name, + asset_sha1 = file$sha1, + asset_thumbnail_url = file$thumbnail_url, + session_id = session$id, + session_name = session$name, + session_date = session$source_date, + session_release = session$release_level + ) + }) %>% + purrr::list_rbind() + }) %>% purrr::list_rbind() + + if (is.null(files) || nrow(files) == 0) { if (vb) message("No assets in volume_id ", vol_id, ".") return(NULL) } - if (!("asset_format_id" %in% names(this_volume_assets_df))) { - if (vb) - message("'asset_format_id' field not found in assets data frame.") - return(NULL) - } - - format_id <- NULL - format_mimetype <- NULL - format_extension <- NULL - format_name <- NULL - asset_format_id <- NULL - - asset_formats_df <- databraryr::list_asset_formats(vb = vb) %>% - dplyr::select(format_id, format_mimetype, format_extension, format_name) - - dplyr::left_join( - this_volume_assets_df, - asset_formats_df, - by = dplyr::join_by(asset_format_id == format_id) - ) -} -#------------------------------------------------------------------------------- -#' Helper function for list_volume_assets -#' -#' @param volume_container The 'container' list from a volume. -#' @param ignore_materials A logical value. -#' -get_assets_from_session <- - function(volume_container, ignore_materials = TRUE) { - # ignore materials - if (ignore_materials) { - if ("top" %in% names(volume_container)) - return(NULL) - } - - assets_df <- purrr::map(volume_container$assets, as.data.frame) %>% - purrr::list_rbind() - - # ignore empty sessions - if (dim(assets_df)[1] == 0) - return(NULL) - - if (!('size' %in% names(assets_df))) - assets_df$size <- NA - if (!('duration' %in% names(assets_df))) - assets_df$duration <- NA - if (!('name' %in% names(assets_df))) - assets_df$name <- NA - - # Initialize values to avoid check() error - id <- NULL - duration <- NULL - name <- NULL - permission <- NULL - size <- NULL - - assets_df %>% - dplyr::select(id, format, duration, name, permission, size) %>% - dplyr::rename( - asset_id = id, - asset_format_id = format, - asset_name = name, - asset_duration = duration, - asset_permission = permission, - asset_size = size - ) %>% - dplyr::mutate( - session_id = volume_container$id, - session_date = volume_container$date, - session_release = volume_container$release - ) - } + files +} diff --git a/R/list_volume_collaborators.R b/R/list_volume_collaborators.R new file mode 100644 index 00000000..9b73f4a0 --- /dev/null +++ b/R/list_volume_collaborators.R @@ -0,0 +1,80 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' List Collaborators On A Databrary Volume. +#' +#' @description Retrieve collaboration metadata for a specified volume, +#' including sponsor details and access levels. +#' +#' @param vol_id Target volume number. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A tibble summarizing collaborator relationships on the volume, or +#' `NULL` when no collaborators are associated with the volume. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' list_volume_collaborators(vol_id = 1) +#' } +#' } +#' @export +list_volume_collaborators <- function(vol_id = 1, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(length(vol_id) == 1) + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(vol_id > 0) + + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + collaborators <- perform_api_get( + path = sprintf(API_VOLUME_COLLABORATORS, vol_id), + rq = rq, + vb = vb + ) + + if (is.null(collaborators) || length(collaborators) == 0) { + if (vb) { + message("No collaborators found for volume ", vol_id) + } + return(NULL) + } + + purrr::map_dfr(collaborators, function(entry) { + user <- entry$user + sponsor <- entry$sponsor + + sponsor_id <- if (!is.null(sponsor)) sponsor$id else NA_integer_ + sponsor_first <- if (!is.null(sponsor)) sponsor$first_name else NA_character_ + sponsor_last <- if (!is.null(sponsor)) sponsor$last_name else NA_character_ + sponsor_email <- if (!is.null(sponsor)) sponsor$email else NA_character_ + + tibble::tibble( + collaborator_id = entry$id, + volume_id = vol_id, + collaborator_user_id = if (is.null(user)) NA_integer_ else user$id, + collaborator_first_name = if (is.null(user)) NA_character_ else user$first_name, + collaborator_last_name = if (is.null(user)) NA_character_ else user$last_name, + collaborator_email = if (is.null(user)) NA_character_ else user$email, + collaborator_is_authorized_investigator = if (is.null(user$is_authorized_investigator)) NA else user$is_authorized_investigator, + collaborator_has_avatar = if (is.null(user$has_avatar)) NA else user$has_avatar, + sponsor_user_id = sponsor_id, + sponsor_first_name = sponsor_first, + sponsor_last_name = sponsor_last, + sponsor_email = sponsor_email, + access_level = if (is.null(entry$access_level)) NA_character_ else entry$access_level, + is_publicly_visible = if (is.null(entry$is_publicly_visible)) NA else entry$is_publicly_visible, + expiration_date = if (is.null(entry$expiration_date)) NA_character_ else entry$expiration_date + ) + }) +} + + diff --git a/R/list_volume_excerpts.R b/R/list_volume_excerpts.R deleted file mode 100644 index acf62ac3..00000000 --- a/R/list_volume_excerpts.R +++ /dev/null @@ -1,60 +0,0 @@ -#' @eval options::as_params() -#' @name options_params -#' -NULL - -#' List Image or Video Excerpts On A Databrary Volume. -#' -#' @param vol_id Target volume number. -#' @param rq An `httr2` request object. Default is NULL. -#' -#' @returns A list with information about any available excerpts. -#' -#' @inheritParams options_params -#' -#' @examples -#' \donttest{ -#' list_volume_excerpts() -#' } -#' -#' @export -list_volume_excerpts <- - function(vol_id = 1, - vb = options::opt("vb"), - rq = NULL) { - # Check parameters - assertthat::assert_that(length(vol_id) == 1) - assertthat::assert_that(is.numeric(vol_id)) - assertthat::assert_that(vol_id > 0) - - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - rq <- rq %>% - httr2::req_url(sprintf(GET_VOLUME_EXCERPTS, vol_id)) - - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) { - NULL - } - ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - httr2::resp_body_json(resp) - } - # TODO: Reformat response. - } diff --git a/R/list_volume_folders.R b/R/list_volume_folders.R new file mode 100644 index 00000000..ea19094b --- /dev/null +++ b/R/list_volume_folders.R @@ -0,0 +1,69 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' List Folders in a Databrary Volume. +#' +#' @param vol_id Target volume number. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @returns A tibble with metadata about folders in the selected volume, or +#' `NULL` when no folders are available. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' list_volume_folders() # Folders in volume 1 +#' } +#' } +#' @export +list_volume_folders <- function(vol_id = 1, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(length(vol_id) == 1) + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(vol_id >= 1) + + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + folders <- collect_paginated_get( + path = sprintf(API_VOLUME_FOLDERS, vol_id), + rq = rq, + vb = vb + ) + + if (is.null(folders) || length(folders) == 0) { + if (vb) { + message("No folders available for volume ", vol_id) + } + return(NULL) + } + + purrr::map_dfr(folders, function(folder) { + volume_value <- folder$volume + if (is.null(volume_value)) { + volume_value <- vol_id + } + + tibble::tibble( + folder_id = folder$id, + folder_name = folder$name, + folder_release = folder$release_level, + folder_file_count = folder$file_count, + folder_accessible_file_count = folder$accessible_file_count, + folder_has_full_access = folder$has_full_access, + folder_contains_different_release_levels = folder$contains_different_release_levels, + folder_created_at = folder$created_at, + folder_updated_at = folder$updated_at, + folder_source_date = folder$source_date, + vol_id = volume_value + ) + }) +} + diff --git a/R/list_volume_funding.R b/R/list_volume_funding.R index c58dde23..64240d53 100644 --- a/R/list_volume_funding.R +++ b/R/list_volume_funding.R @@ -49,72 +49,33 @@ list_volume_funding <- function(vol_id = 1, rq <- databraryr::make_default_request() } - #------------------------------------------------------------ if (vb) message("Summarizing funding for n=", length(vol_id), " volumes.") - purrr::map( - vol_id, - list_single_volume_funding, - add_id = add_id, - vb = vb, - rq = rq, - .progress = "Volume funding: " - ) %>% - purrr::list_rbind() -} - -#------------------------------------------------------------------------------- -# Helper function for handling lists -list_single_volume_funding <- - function(vol_id = NULL, - add_id = NULL, - vb = NULL, - rq) { - if (is.null(rq)) { - rq <- databraryr::make_default_request() - } - rq <- rq %>% - httr2::req_url(sprintf(GET_VOLUME_FUNDING, vol_id)) - - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) { - NULL - } + purrr::map(vol_id, function(id) { + fundings <- perform_api_get( + path = sprintf(API_VOLUME_FUNDINGS, id), + rq = rq, + vb = vb ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - res <- httr2::resp_body_json(resp) - if (!(is.null(res))) { - out_df <- purrr::map(res$funding, extract_funder_info) %>% - purrr::list_rbind() - if (add_id) - out_df <- dplyr::mutate(out_df, vol_id = vol_id) - out_df - } + + if (is.null(fundings) || length(fundings) == 0) { + return(NULL) } - } -#------------------------------------------------------------------------------- -extract_funder_info <- function(vol_funder_list_item) { - assertthat::assert_that("list" %in% class(vol_funder_list_item)) - assertthat::assert_that("funder" %in% names(vol_funder_list_item)) - assertthat::assert_that("awards" %in% names(vol_funder_list_item)) - - funder_id <- vol_funder_list_item$funder$id - funder_name <- vol_funder_list_item$funder$name - if (length(vol_funder_list_item$awards) == 0) { - funder_award <- NA - } else { - funder_award <- vol_funder_list_item$awards %>% unlist() - } - tibble::tibble( - funder_id = funder_id, - funder_name = funder_name, - funder_award = funder_award - ) + rows <- purrr::map_dfr(fundings, function(entry) { + funder <- entry$funder + tibble::tibble( + funder_id = funder$id, + funder_name = funder$name, + funder_is_approved = funder$is_approved, + funder_awards = entry$awards + ) + }) + if (add_id) { + rows <- dplyr::mutate(rows, vol_id = id) + } + rows + }) %>% + purrr::list_rbind() } diff --git a/R/list_volume_info.R b/R/list_volume_info.R index abf77794..842f2ccf 100644 --- a/R/list_volume_info.R +++ b/R/list_volume_info.R @@ -37,85 +37,64 @@ list_volume_info <- assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) - # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("\nNULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - - # Make character array of "release" constants to decode release index - constants <- databraryr::assign_constants() - release_levels <- constants$release |> - as.character() - - vol_list <- databraryr::get_volume_by_id(vol_id = vol_id, vb = vb, rq = rq) - if (is.null(vol_list)) { + volume <- databraryr::get_volume_by_id(vol_id = vol_id, vb = vb, rq = rq) + if (is.null(volume)) { return(NULL) } else { - # Extract owner info - if (vb) message("Extracting owner info...") - id <- NULL - name <- NULL - owner_name <- NULL - vol_owners <- purrr::map(vol_list$owners, tibble::as_tibble) %>% - purrr::list_rbind() %>% - dplyr::rename(party_id = id, owner_name = name) %>% - dplyr::filter(!(stringr::str_detect(owner_name, "Databrary"))) - - vol_owners_str <- stringr::str_flatten(vol_owners$owner_name, - collapse = "; ") - - # Extract session info - if (vb) message("Extracting session info...") - vol_sessions <- purrr::map(vol_list$containers, get_info_from_session, - release_levels = release_levels) %>% - purrr::list_rbind() - if (is.null(vol_sessions)) { - n_vol_sessions <- 0 - } else { - n_vol_sessions <- dim(vol_sessions)[1] - } - - # Extract funder info - if (vb) message("Extracting funder info...") - vol_funders <- purrr::map(vol_list$funding, extract_funder_info) %>% - purrr::list_rbind() - if (is.null(vol_funders)) { - n_vol_funders <- 0 - } else { - n_vol_funders <- dim(vol_funders)[1] - } - - # Extract asset info + if (vb) message("Summarising volume detail...") + + owner_connection <- volume$owner_connection + owner_institution <- volume$owner_institution + + session_count <- volume$session_count[[1]] + session_count_shared <- volume$session_count_shared[[1]] + + file_counts <- volume$file_counts[[1]] + + fundings <- perform_api_get( + path = sprintf(API_VOLUME_FUNDINGS, vol_id), + rq = rq, + vb = vb + ) + n_vol_funders <- if (is.null(fundings)) 0 else length(fundings) + vol_assets <- list_volume_assets(vol_id = vol_id, vb = vb, rq = rq) - - if (is.null(vol_assets)) { + + if (is.null(vol_assets) || nrow(vol_assets) == 0) { n_vol_assets <- 0 tot_vol_size_mb <- 0 tot_vol_dur_hrs <- 0 } else { - n_vol_assets <- dim(vol_assets)[1] - tot_vol_size_mb <- round(sum(stats::na.omit(vol_assets$asset_size))/(1024*1024), 3) - tot_vol_dur_hrs <- round(sum(stats::na.omit(vol_assets$asset_duration))/(1000*60*60), 3) + n_vol_assets <- nrow(vol_assets) + tot_vol_size_mb <- round(sum(stats::na.omit(vol_assets$asset_size)) / (1024 * 1024), 3) + tot_vol_dur_hrs <- if ("asset_duration" %in% names(vol_assets)) { + round(sum(stats::na.omit(vol_assets$asset_duration)) / 3600, 3) + } else { + NA_real_ + } } - - # Create output data frame/tibble + tibble::tibble( - vol_id = vol_list$id, - vol_name = vol_list$name, - vol_doi = vol_list$doi, - vol_desc = vol_list$body, - vol_creation = vol_list$creation, - vol_publicaccess = vol_list$publicaccess, - vol_owners = vol_owners_str, - vol_n_sessions = n_vol_sessions, + vol_id = volume$id, + vol_name = volume$title, + vol_short_name = volume$short_name, + vol_desc = volume$description, + vol_created_at = volume$created_at, + vol_updated_at = volume$updated_at, + vol_sharing_level = volume$sharing_level, + vol_access_level = volume$access_level, + vol_owner_connection = owner_connection, + vol_owner_institution = owner_institution, + vol_n_sessions = session_count, + vol_n_sessions_shared = session_count_shared, + vol_file_counts = list(file_counts), vol_n_assets = n_vol_assets, vol_tot_size_mb = tot_vol_size_mb, vol_tot_dur_hrs = tot_vol_dur_hrs, - vol_n_funders = n_vol_funders - ) + vol_n_funders = n_vol_funders, + vol_enabled_categories = list(volume$enabled_categories[[1]]), + vol_enabled_metrics = list(volume$enabled_metrics[[1]]), + vol_citation = list(volume$citation[[1]]) + ) } } diff --git a/R/list_volume_links.R b/R/list_volume_links.R index 57cfce60..ced97f18 100644 --- a/R/list_volume_links.R +++ b/R/list_volume_links.R @@ -30,34 +30,23 @@ list_volume_links <- function(vol_id = 1, assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - rq <- rq %>% - httr2::req_url(sprintf(GET_VOLUME_LINKS, vol_id)) - - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) { - NULL - } + links <- perform_api_get( + path = sprintf(API_VOLUME_LINKS, vol_id), + rq = rq, + vb = vb ) - - head <- NULL - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - res <- httr2::resp_body_json(resp) - if (!(is.null(res$links))) { - purrr::map(res$links, tibble::as_tibble) %>% - purrr::list_rbind() %>% - dplyr::rename(link_name = head, link_url = url) %>% - dplyr::mutate(vol_id = vol_id) - } + + if (is.null(links) || length(links) == 0) { + return(NULL) } + + purrr::map_dfr(links, function(link) { + tibble::tibble( + link_id = link$id, + link_label = link$title, + link_url = link$url, + link_description = link$description, + link_release_level = link$release_level + ) + }) } diff --git a/R/list_volume_owners.R b/R/list_volume_owners.R deleted file mode 100644 index bc9ac2da..00000000 --- a/R/list_volume_owners.R +++ /dev/null @@ -1,73 +0,0 @@ -#' @eval options::as_params() -#' @name options_params -#' -NULL - -#' List Owners of a Databrary Volume. -#' -#' @param vol_id Selected volume number. Default is volume 1. -#' @param rq An `httr2` request object. If NULL (the default) -#' a request will be generated, but this will only permit public information -#' to be returned. -#' -#' @returns A data frame with information about a volume's owner(s). -#' -#' @inheritParams options_params -#' -#' @examples -#' \donttest{ -#' list_volume_owners() # Lists information about the owners of volume 1. -#' } -#' @export -list_volume_owners <- function(vol_id = 1, - vb = options::opt("vb"), - rq = NULL) { - # Check parameters - assertthat::assert_that(length(vol_id) == 1) - assertthat::assert_that(is.numeric(vol_id)) - assertthat::assert_that(vol_id > 0) - - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - rq <- rq %>% - httr2::req_url(sprintf(GET_VOLUME_MINIMUM, vol_id)) - - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) { - NULL - } - ) - - # Initialize - party_id <- NULL - id <- NULL - owner_name <- NULL - name <- NULL - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - res <- httr2::resp_body_json(resp) - if (!(is.null(res$owners))) { - purrr::map(res$owners, tibble::as_tibble) %>% - purrr::list_rbind() %>% - dplyr::rename(party_id = id, owner_name = name) %>% - dplyr::filter(!(stringr::str_detect(owner_name, "Databrary"))) - } - - } -} diff --git a/R/list_volume_session_assets.R b/R/list_volume_session_assets.R index 2dd1ea2a..851fad24 100644 --- a/R/list_volume_session_assets.R +++ b/R/list_volume_session_assets.R @@ -24,114 +24,85 @@ NULL #' @examples #' \donttest{ #' \dontrun{ -#' list_volume_session_assets() # Session 9807 in volume 1 +#' list_volume_session_assets() # Defaults to session 11 in volume 2 #' } #' } #' @export list_volume_session_assets <- - function(vol_id = 1, - session_id = 9807, + function(vol_id = 2, + session_id = 11, vb = options::opt("vb"), rq = NULL) { - # Check parameters assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - + assertthat::assert_that(length(session_id) == 1) assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id >= 1) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - + assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) if (is.null(rq)) { if (vb) { message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") } rq <- databraryr::make_default_request() } - - vol_list <- databraryr::get_volume_by_id(vol_id, vb, rq) - - if (!("containers" %in% names(vol_list))) { + + session <- perform_api_get( + path = sprintf(API_SESSION_DETAIL, vol_id, session_id), + rq = rq, + vb = vb + ) + + if (is.null(session)) { if (vb) - message("No session/containers data from volume ", vol_id) + message("No matching session_id: ", session_id) return(NULL) } - - #-------------------------------------------------------------------------- - get_sessions <- function(volume_container) { - tibble::tibble(session_id = volume_container$id) - } - #-------------------------------------------------------------------------- - - # Select session info - these_sessions <- - purrr::map(vol_list$containers, get_sessions) %>% - purrr::list_rbind() - - session_match <- (session_id == these_sessions$session_id) - if (sum(session_match) == 0) { + + files <- collect_paginated_get( + path = sprintf(API_SESSION_FILES, vol_id, session_id), + rq = rq, + vb = vb + ) + + if (is.null(files) || length(files) == 0) { if (vb) - message("No matching session_id: ", session_id) + message("No assets in session_id ", session_id) return(NULL) } - session_match_index <- seq_along(session_match)[session_match] - - this_session <- vol_list$containers[[session_match_index]] - if (is.null(this_session)) - return(NULL) - - assets_df <- - purrr::map(this_session$assets, as.data.frame) %>% - purrr::list_rbind() - - # ignore empty sessions - if (dim(assets_df)[1] == 0) - return(NULL) - - if (!('size' %in% names(assets_df))) - assets_df$size = NA - if (!('duration' %in% names(assets_df))) - assets_df$duration = NA - if (!('name' %in% names(assets_df))) - assets_df$name = NA - - id <- NULL - format <- NULL - name <- NULL - duration <- NULL - permission <- NULL - size <- NULL - asset_format_id <- NULL - - assets_df <- assets_df %>% - dplyr::select(id, format, duration, name, permission, size) %>% - dplyr::rename( - asset_id = id, - asset_format_id = format, - asset_name = name, - asset_duration = duration, - asset_permission = permission, - asset_size = size + + asset_rows <- purrr::map(files, function(file) { + format <- file$format + uploader <- file$uploader + + tibble::tibble( + asset_id = file$id, + asset_name = file$name, + asset_permission = file$release_level, + asset_size = file$size, + asset_mime_type = format$mimetype, + asset_format_id = format$id, + asset_format_name = format$name, + asset_duration = file$duration, + asset_created_at = file$created_at, + asset_updated_at = file$updated_at, + asset_uploader_id = uploader$id, + asset_uploader_first_name = uploader$first_name, + asset_uploader_last_name = uploader$last_name, + asset_sha1 = file$sha1, + asset_thumbnail_url = file$thumbnail_url, + session_id = session$id, + session_name = session$name, + session_release = session$release_level ) - - format_id <- NULL - format_mimetype <- NULL - format_extension <- NULL - format_name <- NULL - - # Gather asset format info - asset_formats_df <- list_asset_formats(vb = vb) %>% - dplyr::select(format_id, format_mimetype, format_extension, format_name) - - # Join assets with asset format info - out_df <- dplyr::left_join(assets_df, - asset_formats_df, - by = dplyr::join_by(asset_format_id == format_id)) - out_df + }) %>% + purrr::list_rbind() + + asset_rows } diff --git a/R/list_volume_sessions.R b/R/list_volume_sessions.R index c8feb025..d8020b29 100644 --- a/R/list_volume_sessions.R +++ b/R/list_volume_sessions.R @@ -43,79 +43,46 @@ list_volume_sessions <- ("httr2_request" %in% class(rq))) - # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("\nNULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - - vol_list <- databraryr::get_volume_by_id(vol_id = vol_id, vb = vb, rq = rq) - if (!("containers" %in% names(vol_list))) { + sessions <- collect_paginated_get( + path = sprintf(API_VOLUME_SESSIONS, vol_id), + rq = rq, + vb = vb + ) + + if (is.null(sessions) || length(sessions) == 0) { if (vb) - message("No session/containers data from volume ", vol_id) + message("No session data for volume ", vol_id) return(NULL) } - - # Make character array of "release" constants to decode release index - constants <- databraryr::assign_constants() - release_levels <- constants$release |> - as.character() - - df <- purrr::map(vol_list$containers, get_info_from_session, - release_levels = release_levels, - .progress = vb) %>% - purrr::list_rbind() + + df <- purrr::map_dfr(sessions, function(session) { + tibble::tibble( + session_id = session$id, + session_name = session$name, + session_release = session$release_level, + session_source_date = session$source_date, + session_file_count = session$file_count, + session_accessible_file_count = session$accessible_file_count, + session_has_full_access = session$has_full_access + ) + }) if (include_vol_data) { + volume <- perform_api_get( + path = sprintf(API_VOLUME_DETAIL, vol_id), + rq = rq, + vb = vb + ) + df <- df %>% dplyr::mutate( - vol_id = as.character(vol_list$id), - vol_name = as.character(vol_list$name), - vol_creation = as.character(vol_list$creation), - vol_publicaccess = as.character(vol_list$publicaccess) + vol_id = volume$id, + vol_name = volume$title, + vol_created_at = volume$created_at, + vol_updated_at = volume$updated_at, + vol_sharing_level = volume$sharing_level, + vol_access_level = volume$access_level ) } - df - } - -#------------------------------------------------------------------------------- -#' List Sessions Info in Databrary Volume Container -#' -#' @param volume_container A component of a volume list returned by -#' get_volume_by_id(). -#' @param ignore_materials A logical value specifying whether to ignore -#' "materials" folders. -#' Default is TRUE -#' @param release_levels A data frame mapping release level indices to release -#' level text values. -get_info_from_session <- - function(volume_container, ignore_materials = FALSE, release_levels) { - - # Make character array of "release" constants to decode release index - constants <- databraryr::assign_constants() - release_levels <- constants$release |> - as.character() - - # ignore materials - if (ignore_materials) { - if ("top" %in% names(volume_container)) - return(NULL) - } else { - if (!("name" %in% names(volume_container))) - volume_container$name <- NA - if (!("date" %in% names(volume_container))) - volume_container$date <- NA - if (!("release" %in% names(volume_container))) - volume_container$release <- NA - } - - tibble::tibble( - session_id = as.character(volume_container$id), - session_name = as.character(volume_container$name), - session_date = as.character(volume_container$date), - session_release = as.character(release_levels[volume_container$release]) - ) + tibble::as_tibble(df) } diff --git a/R/list_volume_tags.R b/R/list_volume_tags.R index 408c0515..ddb63768 100644 --- a/R/list_volume_tags.R +++ b/R/list_volume_tags.R @@ -31,35 +31,17 @@ list_volume_tags <- function(vol_id = 1, assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) - # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - rq <- rq %>% - httr2::req_url(sprintf(GET_VOLUME_TAGS, vol_id)) - - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) { - NULL - } + tags <- perform_api_get( + path = sprintf(API_VOLUME_TAGS, vol_id), + rq = rq, + vb = vb ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - res <- httr2::resp_body_json(resp) - if (!(is.null(res$tags))) { - purrr::map(res$tags, extract_vol_tag) %>% - purrr::list_rbind() %>% - dplyr::mutate(vol_id = vol_id) - } + + if (is.null(tags) || length(tags) == 0) { + return(NULL) } + + tags } #------------------------------------------------------------------------------- diff --git a/R/list_volumes.R b/R/list_volumes.R new file mode 100644 index 00000000..7409bbd0 --- /dev/null +++ b/R/list_volumes.R @@ -0,0 +1,86 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' List Volumes Accessible Through The Databrary API. +#' +#' @description Returns summary metadata for volumes accessible to the +#' authenticated user. Results can be filtered by search term or ordering. +#' +#' @param search Optional character string used to filter volumes by title or +#' description. +#' @param ordering Optional character string indicating the sort field accepted +#' by the API (e.g., `"title"`, `"-title"`). +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A tibble summarizing each accessible volume, or `NULL` when no +#' volumes match the supplied filters. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' list_volumes(search = "workshop") +#' } +#' } +#' @export +list_volumes <- function(search = NULL, + ordering = NULL, + vb = options::opt("vb"), + rq = NULL) { + if (!is.null(search)) { + assertthat::assert_that(assertthat::is.string(search)) + } + if (!is.null(ordering)) { + assertthat::assert_that(assertthat::is.string(ordering)) + } + + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + volumes <- collect_paginated_get( + path = API_VOLUMES, + params = list( + search = search, + ordering = ordering + ), + rq = rq, + vb = vb + ) + + if (is.null(volumes) || length(volumes) == 0) { + if (vb) { + message("No volumes matched the supplied filters.") + } + return(NULL) + } + + purrr::map_dfr(volumes, function(volume) { + owner_connection <- volume$owner_connection + owner_user <- if (!is.null(owner_connection)) owner_connection$user else NULL + owner_institution <- volume$owner_institution + + tibble::tibble( + volume_id = volume$id, + volume_title = volume$title, + volume_short_name = if (is.null(volume$short_name)) NA_character_ else volume$short_name, + volume_sharing_level = volume$sharing_level, + volume_access_level = volume$access_level, + volume_owner_connection_id = if (is.null(owner_connection)) NA_integer_ else owner_connection$id, + volume_owner_role = if (is.null(owner_connection$role)) NA_character_ else owner_connection$role, + volume_owner_expiration_date = if (is.null(owner_connection$expiration_date)) NA_character_ else owner_connection$expiration_date, + volume_owner_user_id = if (is.null(owner_user)) NA_integer_ else owner_user$id, + volume_owner_user_first_name = if (is.null(owner_user$first_name)) NA_character_ else owner_user$first_name, + volume_owner_user_last_name = if (is.null(owner_user$last_name)) NA_character_ else owner_user$last_name, + volume_owner_user_email = if (is.null(owner_user$email)) NA_character_ else owner_user$email, + volume_owner_institution_id = if (is.null(owner_institution)) NA_integer_ else owner_institution$id, + volume_owner_institution_name = if (is.null(owner_institution$name)) NA_character_ else owner_institution$name + ) + }) +} + + diff --git a/R/misc_enums.R b/R/misc_enums.R new file mode 100644 index 00000000..e5920cde --- /dev/null +++ b/R/misc_enums.R @@ -0,0 +1,43 @@ +# Enumerations mirroring constants exposed by the Django backend. + +#' @noRd +get_permission_levels_enums <- function() { + list( + volume_access_levels = c( + "superuser", + "owner", + "investigator", + "read write", + "read only", + "read only shared", + "read only public", + "read only overview", + "none" + ) + ) +} + +#' @noRd +get_release_levels_enums <- function() { + list( + levels = list( + list( + code = "private", + description = "This content is not shared and is restricted to collaborators." + ), + list( + code = "authorized_users", + description = "This content is restricted to authorized Databrary users and may not be redistributed in any form." + ), + list( + code = "learning_audiences", + description = "This content is restricted to authorized Databrary users, who may use clips or images from it in presentations for informational or educational purposes. Such presentations may be videotaped or recorded and those videos or recordings may then be made available to the public via the internet (e.g., YouTube)." + ), + list( + code = "public", + description = "This content is available to the public." + ) + ) + ) +} + diff --git a/R/search_for_funder.R b/R/search_for_funder.R index b6267939..0b0928b8 100644 --- a/R/search_for_funder.R +++ b/R/search_for_funder.R @@ -6,6 +6,8 @@ NULL #' Report Information About A Funder. #' #' @param search_string String to search. +#' @param approved_only Logical. When TRUE (default) only approved funders are +#' returned. Set to FALSE to include unapproved funders as well. #' @param rq An `httr2` request object. Default is NULL. #' #' @returns A data frame with information about the funder. @@ -19,45 +21,61 @@ NULL #' #' @export search_for_funder <- - function(search_string = "national+science+foundation", + function(search_string = "national science foundation", + approved_only = TRUE, vb = options::opt("vb"), rq = NULL) { - # Check parameters assertthat::assert_that(length(search_string) == 1) assertthat::assert_that(is.character(search_string)) + search_string <- gsub("[+]", " ", search_string) + pattern <- stringr::str_trim(search_string) + assertthat::assert_that(is.logical(approved_only), length(approved_only) == 1) assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() + params <- list() + if (!approved_only) { + params$all <- "true" } - rq <- rq %>% - httr2::req_url(sprintf(QUERY_VOLUME_FUNDER, search_string)) - if (vb) - message("Retrieving data for funder string '", search_string, "'.") - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) { - NULL - } + funders <- collect_paginated_get( + path = API_FUNDERS, + params = params, + rq = rq, + vb = vb ) + + if (is.null(funders) || length(funders) == 0) { + if (vb) message("No funders available from API.") + return(NULL) + } - if (vb) - message('search_for_keywords()...') - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - httr2::resp_body_json(resp) %>% as.data.frame() + funder_tbl <- purrr::map_dfr(funders, function(entry) { + tibble::tibble( + funder_id = entry$id, + funder_name = entry$name, + funder_is_approved = entry$is_approved + ) + }) + + if (!nzchar(pattern)) { + return(funder_tbl) } + + matches <- stringr::str_detect( + stringr::str_to_lower(funder_tbl$funder_name), + stringr::str_to_lower(pattern) + ) + result <- funder_tbl[matches, , drop = FALSE] + + if (nrow(result) == 0) { + if (vb) message("No funders matched query '", search_string, "'.") + return(NULL) + } + + result } diff --git a/R/search_for_keywords.R b/R/search_for_keywords.R deleted file mode 100644 index 22ab0f8f..00000000 --- a/R/search_for_keywords.R +++ /dev/null @@ -1,69 +0,0 @@ -#' @eval options::as_params() -#' @name options_params -#' -NULL - -#' Search For Keywords in Databrary Volumes. -#' -#' @param search_string String to search. -#' @param rq An `httr2` request object. Default is NULL. -#' -#' @returns A list with the volumes that contain the keyword. -#' -#' @inheritParams options_params -#' -#' @examples -#' \dontrun{ -#' search_for_keywords() # searches for volumes with "locomotion" as a keyword. -#' search_for_keywords() -#' -#' # searches for volumes with "adult" as a keyword. -#' search_for_keywords("adult") -#' } -#' @export -search_for_keywords <- - function(search_string = "locomotion", - vb = options::opt("vb"), - rq = NULL) { - # Check parameters - assertthat::assert_that(length(search_string) == 1) - assertthat::assert_that(is.character(search_string)) - - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - rq <- rq %>% - httr2::req_url(sprintf(QUERY_KEYWORDS, search_string)) - - if (vb) message("Retrieving data for search string '", search_string, "'.") - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) { - NULL - } - ) - - if (vb) - message('search_for_keywords()...') - - if (vb) - message(paste0("Searching for ", search_string)) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - httr2::resp_body_json(resp) - } - #TODO: Reformat search data - } diff --git a/R/search_for_tags.R b/R/search_for_tags.R index b4b071d5..873690a1 100644 --- a/R/search_for_tags.R +++ b/R/search_for_tags.R @@ -32,27 +32,25 @@ search_for_tags <- assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - rq <- rq |> - httr2::req_url(sprintf(QUERY_TAGS, search_string)) - - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) { - NULL - } + results <- collect_paginated_get( + path = API_SEARCH_VOLUMES, + params = list(tag = search_string), + rq = rq, + vb = vb + ) + + if (is.null(results) || length(results) == 0) { + if (vb) message("No volumes tagged '", search_string, "'.") + return(NULL) + } + + purrr::map_dfr(results, function(entry) { + tibble::tibble( + vol_id = entry$id, + vol_title = entry$title, + vol_sharing_level = entry$sharing_level, + vol_tags = list(entry$tags), + score = entry$score ) - - if (!is.null(resp)) { - httr2::resp_body_string(resp) - } else { - resp - } - #TODO: Reformat search data; handle multiple tags (separate with '+') + }) } diff --git a/R/search_institutions.R b/R/search_institutions.R new file mode 100644 index 00000000..c5b0ecc1 --- /dev/null +++ b/R/search_institutions.R @@ -0,0 +1,60 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Search For Institutions In Databrary. +#' +#' @description Perform a search across institutions registered with +#' Databrary. +#' +#' @param search_string Character string describing the institution search +#' query. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A tibble containing matching institutions ordered by relevance, or +#' `NULL` when no matches exist for the query. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' search_institutions("state") +#' } +#' } +#' @export +search_institutions <- function(search_string, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(assertthat::is.string(search_string)) + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + results <- collect_paginated_get( + path = API_SEARCH_INSTITUTIONS, + params = list(q = search_string), + rq = rq, + vb = vb + ) + + if (is.null(results) || length(results) == 0) { + if (vb) { + message("No institutions matched the search query '", search_string, "'.") + } + return(NULL) + } + + purrr::map_dfr(results, function(entry) { + tibble::tibble( + institution_id = entry$id, + institution_name = entry$name, + institution_url = if (is.null(entry$url)) NA_character_ else entry$url, + institution_has_avatar = if (is.null(entry$has_avatar)) NA else entry$has_avatar, + score = if (is.null(entry$score)) NA_real_ else entry$score + ) + }) +} + + diff --git a/R/search_users.R b/R/search_users.R new file mode 100644 index 00000000..4b803304 --- /dev/null +++ b/R/search_users.R @@ -0,0 +1,64 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Search For Users In Databrary. +#' +#' @description Perform a directory search across Databrary users by name or +#' email address. +#' +#' @param search_string Character string describing the search query. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A tibble containing user matches ordered by relevance, or `NULL` +#' when no matches exist for the query. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' search_users("gilmore") +#' } +#' } +#' @export +search_users <- function(search_string, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(assertthat::is.string(search_string)) + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + results <- collect_paginated_get( + path = API_SEARCH_USERS, + params = list(q = search_string), + rq = rq, + vb = vb + ) + + if (is.null(results) || length(results) == 0) { + if (vb) { + message("No users matched the search query '", search_string, "'.") + } + return(NULL) + } + + purrr::map_dfr(results, function(entry) { + tibble::tibble( + user_id = entry$id, + user_first_name = entry$first_name, + user_last_name = entry$last_name, + user_full_name = entry$full_name, + user_email = entry$email, + user_orcid = if (is.null(entry$orcid)) NA_character_ else entry$orcid, + user_url = if (is.null(entry$url)) NA_character_ else entry$url, + user_is_authorized = if (is.null(entry$is_authorized)) NA else entry$is_authorized, + user_has_avatar = if (is.null(entry$has_avatar)) NA else entry$has_avatar, + score = if (is.null(entry$score)) NA_real_ else entry$score + ) + }) +} + + diff --git a/R/search_volumes.R b/R/search_volumes.R new file mode 100644 index 00000000..16bce781 --- /dev/null +++ b/R/search_volumes.R @@ -0,0 +1,82 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Search For Volumes In Databrary. +#' +#' @description Search across Databrary volumes using the Django search +#' endpoint. +#' +#' @param search_string Character string describing the volume search query. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A tibble containing matching volumes ordered by relevance, or `NULL` +#' when no matches exist for the query. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' search_volumes("workshop") +#' } +#' } +#' @export +search_volumes <- function(search_string, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(assertthat::is.string(search_string)) + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + results <- collect_paginated_get( + path = API_SEARCH_VOLUMES, + params = list(q = search_string), + rq = rq, + vb = vb + ) + + if (is.null(results) || length(results) == 0) { + if (vb) { + message("No volumes matched the search query '", search_string, "'.") + } + return(NULL) + } + + purrr::map_dfr(results, function(entry) { + owner <- entry$owner + + owner_user_id <- NA_integer_ + owner_full_name <- NA_character_ + owner_institution_id <- NA_integer_ + owner_institution_name <- NA_character_ + + if (!is.null(owner)) { + if (!is.null(owner$user_id)) { + owner_user_id <- owner$user_id + } else { + owner_user_id <- NA_integer_ + } + owner_full_name <- if (is.null(owner$full_name)) NA_character_ else owner$full_name + owner_institution_id <- if (is.null(owner$institution_id)) NA_integer_ else owner$institution_id + owner_institution_name <- if (is.null(owner$institution_name)) NA_character_ else owner$institution_name + } + + tibble::tibble( + volume_id = entry$id, + volume_title = entry$title, + volume_description = if (is.null(entry$description)) NA_character_ else entry$description, + volume_sharing_level = entry$sharing_level, + owner_user_id = owner_user_id, + owner_full_name = owner_full_name, + owner_institution_id = owner_institution_id, + owner_institution_name = owner_institution_name, + tags = list(entry$tags), + score = if (is.null(entry$score)) NA_real_ else entry$score + ) + }) +} + + diff --git a/R/token_helpers.R b/R/token_helpers.R index f901f375..6f2162fc 100644 --- a/R/token_helpers.R +++ b/R/token_helpers.R @@ -1,12 +1,5 @@ # Token-aware request helpers ------------------------------------------------- -#' @noRd -add_bearer_token <- function(rq) { - assertthat::assert_that(inherits(rq, "httr2_request")) - access_token <- require_access_token() - httr2::req_headers(rq, Authorization = paste("Bearer", access_token)) -} - #' @noRd ensure_valid_token <- function(refresh = TRUE, client_id = NULL, @@ -57,5 +50,3 @@ ensure_valid_token <- function(refresh = TRUE, get_token_bundle() } - - diff --git a/R/utils.R b/R/utils.R index af9a6cdb..f605de05 100644 --- a/R/utils.R +++ b/R/utils.R @@ -10,6 +10,8 @@ NULL #' Get Duration (In ms) Of A File. #' +#' @param vol_id Volume ID. +#' @param session_id Session ID containing the asset. #' @param asset_id Asset number. #' @param types_w_durations Asset types that have valid durations. #' @param rq An `httr2` request object. Default is NULL. @@ -20,152 +22,76 @@ NULL #' #' @examples #' \donttest{ -#' get_file_duration() # default is the test video from databrary.org/volume/1 +#' get_file_duration() # default is a public video from volume 1 #' } #' #' @export -get_file_duration <- function(asset_id = 1, - types_w_durations = c("-600", "-800"), +get_file_duration <- function(vol_id = 2, + session_id = 9, + asset_id = 2, + types_w_durations = c(-600, -800), vb = options::opt("vb"), rq = NULL) { + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(vol_id > 0) + assertthat::assert_that(length(vol_id) == 1) + + assertthat::assert_that(is.numeric(session_id)) + assertthat::assert_that(session_id > 0) + assertthat::assert_that(length(session_id) == 1) + assertthat::assert_that(is.numeric(asset_id)) assertthat::assert_that(asset_id > 0) assertthat::assert_that(length(asset_id) == 1) - assertthat::assert_that(is.character(types_w_durations)) + assertthat::assert_that(is.atomic(types_w_durations)) assertthat::assert_that(is.logical(vb)) assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) - - # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - rq <- rq %>% - httr2::req_url(sprintf(GET_ASSET_BY_ID, asset_id)) - - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) - NULL + + types_w_durations <- as.character(types_w_durations) + + asset <- perform_api_get( + path = sprintf(API_SESSION_FILE_DETAIL, vol_id, session_id, asset_id), + rq = rq, + vb = vb ) - if (is.null(resp)) { + + if (is.null(asset)) { message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - asset_df <- httr2::resp_body_json(resp) - if (asset_df$format %in% types_w_durations) { - asset_df$duration - } + return(NULL) } -} - - #---------------------------------------------------------------------------- - #' Get Time Range For An Asset. - #' - #' @param vol_id Volume ID - #' @param session_id Slot/session number. - #' @param asset_id Asset number. - #' @param convert_JSON A Boolean value. If TRUE, convert JSON to a data - #' frame. Default is TRUE. - #' @param segment_only A Boolean value. If TRUE, returns only the segment - #' values. Otherwise returns - #' a data frame with two fields, segment and permission. Default is TRUE. - #' @param rq An `httr2` request object. Default is NULL. - #' - #' @returns The time range (in ms) for an asset, if one is indicated. - #' - #' @inheritParams options_params - #' - #' @examples - #' \donttest{ - #' get_asset_segment_range() - #' } - #' - #' @export - get_asset_segment_range <- function(vol_id = 1, - session_id = 9807, - asset_id = 1, - convert_JSON = TRUE, - segment_only = TRUE, - vb = options::opt("vb"), - rq = NULL) { - assertthat::assert_that(is.numeric(vol_id)) - assertthat::assert_that(vol_id > 0) - assertthat::assert_that(length(vol_id) == 1) - - assertthat::assert_that(is.numeric(session_id)) - assertthat::assert_that(session_id > 0) - assertthat::assert_that(length(session_id) == 1) - - assertthat::assert_that(is.numeric(asset_id)) - assertthat::assert_that(asset_id > 0) - assertthat::assert_that(length(asset_id) == 1) - - assertthat::assert_that(is.logical(convert_JSON)) - assertthat::assert_that(length(convert_JSON) == 1) - - assertthat::assert_that(is.logical(convert_JSON)) - assertthat::assert_that(length(convert_JSON) == 1) - - assertthat::assert_that(is.logical(segment_only)) - assertthat::assert_that(length(segment_only) == 1) - - assertthat::assert_that(is.logical(vb)) - assertthat::assert_that(length(vb) == 1) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() + + format <- asset$format + format_id_chr <- as.character(format$id) + + if (!is.na(format_id_chr) && !(format_id_chr %in% types_w_durations)) { + if (vb) { + message("Asset format does not include duration metadata.") } - rq <- rq %>% - httr2::req_url(sprintf( - GET_ASSET_BY_VOLUME_SESSION_ID, - vol_id, - session_id, - asset_id - )) - - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) - NULL - ) - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } else { - asset_info <- httr2::resp_body_json(resp) - if (vb) { - message( - "Returning segment start & end times (in ms) from volume ", - vol_id, - ", session ", - session_id, - ", asset ", - asset_id - ) - } - if (segment_only) { - asset_info$segment %>% unlist() - } else { - asset_info - } + return(NULL) + } + + duration_value <- asset$duration + + if (is.null(duration_value)) { + if (vb) { + message("Duration metadata not available for the requested asset.") } + return(NULL) } + + duration_value <- suppressWarnings(as.numeric(duration_value)) + + if (is.na(duration_value)) { + return(NULL) + } + + round(duration_value * 1000) +} #---------------------------------------------------------------------------- #' Extract Databrary Permission Levels. @@ -180,10 +106,10 @@ get_file_duration <- function(asset_id = 1, #' } #' #' @export - get_permission_levels <- function(vb = options::opt("vb")) { - c <- assign_constants(vb = vb) - c$permission %>% unlist() - } +get_permission_levels <- function(vb = options::opt("vb")) { + enums <- get_permission_levels_enums() + enums$volume_access_levels +} #---------------------------------------------------------------------------- #' Convert Timestamp String To ms. @@ -227,8 +153,8 @@ get_file_duration <- function(asset_id = 1, #' #' @export get_release_levels <- function(vb = options::opt("vb")) { - c <- assign_constants(vb = vb) - c$release %>% unlist() + enums <- get_release_levels_enums() + vapply(enums$levels, function(item) item$code, character(1)) } #---------------------------------------------------------------------------- @@ -246,87 +172,13 @@ get_file_duration <- function(asset_id = 1, #' #' @export get_supported_file_types <- function(vb = options::opt("vb")) { - c <- assign_constants(vb = vb) - ft <- Reduce(function(x, y) - merge(x, y, all = TRUE), c$format) - ft <- dplyr::rename(ft, asset_type = "name", asset_type_id = "id") - ft - } - - #---------------------------------------------------------------------------- - #' Is This Party An Institution? - #' - #' @param party_id Databrary party ID - #' @param rq An `httr2` request object. - #' - #' @returns TRUE if the party is an institution, FALSE otherwise. - #' - #' @inheritParams options_params - #' - #' @examples - #' \donttest{ - #' is_institution() # Is party 8 (NYU) an institution. - #' } - #' - #' @export - is_institution <- function(party_id = 8, - vb = options::opt("vb"), - rq = NULL) { - assertthat::assert_that(is.numeric(party_id)) - assertthat::assert_that(party_id > 0) - assertthat::assert_that(length(party_id) == 1) - - assertthat::assert_that(is.logical(vb)) - assertthat::assert_that(length(vb) == 1) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - - party_info <- databraryr::get_party_by_id(party_id = party_id, - vb = vb, - rq = rq) - - if (("institution" %in% names(party_info)) && - (!is.null(party_info[['institution']]))) { - TRUE - } else { - FALSE - } - } - - #---------------------------------------------------------------------------- - #' Is This Party A Person? - #' - #' @param party_id Databrary party ID - #' @param rq An `httr2` request object. - #' - #' @returns TRUE if the party is a person, FALSE otherwise. - #' - #' @inheritParams options_params - #' - #' @examples - #' \donttest{ - #' is_person() - #' } - #' - #' @export - is_person <- function(party_id = 7, - vb = options::opt("vb"), - rq = NULL) { - return(!is_institution( - party_id = party_id, - vb = vb, - rq = rq - )) + constants <- assign_constants(vb = vb) + constants$format_df |> + dplyr::rename( + asset_type = name, + asset_type_id = id, + asset_category = category + ) } #---------------------------------------------------------------------------- diff --git a/R/whoami.R b/R/whoami.R index 5c39c3c6..16954138 100644 --- a/R/whoami.R +++ b/R/whoami.R @@ -34,10 +34,16 @@ whoami <- function(refresh = TRUE, vb = options::opt("vb")) { } resp <- tryCatch( - httr2::req_url(req, OAUTH_TEST_URL) |> + req |> + httr2::req_url(OAUTH_TEST_URL) |> + httr2::req_headers(`Content-Type` = "application/json") |> httr2::req_perform(), error = function(err) { - if (vb) message("whoami request failed: ", conditionMessage(err)) + if (vb) { + message("whoami request failed: ", conditionMessage(err)) + message("whoami -> request url: ", OAUTH_TEST_URL) + message("whoami -> authorization header: ", if (!is.null(req$headers$Authorization)) req$headers$Authorization else "") + } NULL } ) diff --git a/README.Rmd b/README.Rmd index 204dd364..e7ccae6b 100644 --- a/README.Rmd +++ b/README.Rmd @@ -65,6 +65,29 @@ library(databraryr) login_db() whoami() + +get_db_stats() +#> # A tibble: 1 × 1 +#> date +#> +#> 1 2025-10-31 12:05:57 + +list_volume_assets() |> + head() +#> # A tibble: 6 × 17 +#> asset_id asset_name asset_permission asset_size +#> +#> 1 9826 Introduction public 88610655 +#> 2 9828 Databrary demo public 917124852 +#> 3 9830 Databrary 1 public 899912341 +#> 4 9832 Datavyu public 764340542 +#> 5 22412 Slides public 4573426 +#> 6 9834 Overview and Policy Upda… public 1301079971 +#> # ℹ 12 more variables: asset_mime_type , asset_format_id , +#> # asset_format_name , asset_created_at , asset_updated_at , +#> # asset_sha1 , session_id , session_name , +#> # session_date , session_release , asset_uploader_id , +#> # asset_uploader_first_name , asset_uploader_last_name ``` ## Lifecycle diff --git a/README.md b/README.md index c279fb50..6cdbce9a 100644 --- a/README.md +++ b/README.md @@ -53,36 +53,27 @@ library(databraryr) #> Welcome to the databraryr package. get_db_stats() -#> # A tibble: 1 × 9 -#> date investigators affiliates institutions datasets_total -#> -#> 1 2024-03-29 14:38:54 1740 680 784 1670 -#> # ℹ 4 more variables: datasets_shared , n_files , hours , -#> # TB +#> # A tibble: 1 × 1 +#> date +#> +#> 1 2025-10-31 12:05:57 list_volume_assets() |> head() -#> asset_id asset_format_id asset_duration asset_name -#> 1 9826 -800 335883 Introduction -#> 2 9830 -800 4277835 Databrary 1.0 plan -#> 3 9832 -800 3107147 Datavyu -#> 4 22412 6 NA Slides -#> 5 9828 -800 4425483 Databrary demo -#> 6 9834 -800 4964011 Overview and Policy Update -#> asset_permission asset_size session_id session_date session_release -#> 1 1 88610655 6256 2013-10-28 3 -#> 2 1 899912341 6256 2013-10-28 3 -#> 3 1 764340542 6256 2013-10-28 3 -#> 4 1 4573426 6256 2013-10-28 3 -#> 5 1 917124852 6256 2013-10-28 3 -#> 6 1 1301079971 6257 2014-04-07 3 -#> format_mimetype format_extension format_name -#> 1 video/mp4 mp4 MPEG-4 video -#> 2 video/mp4 mp4 MPEG-4 video -#> 3 video/mp4 mp4 MPEG-4 video -#> 4 application/pdf pdf Portable document -#> 5 video/mp4 mp4 MPEG-4 video -#> 6 video/mp4 mp4 MPEG-4 video +#> # A tibble: 6 × 17 +#> asset_id asset_name asset_permission asset_size +#> +#> 1 9826 Introduction public 88610655 +#> 2 9828 Databrary demo public 917124852 +#> 3 9830 Databrary 1 public 899912341 +#> 4 9832 Datavyu public 764340542 +#> 5 22412 Slides public 4573426 +#> 6 9834 Overview and Policy Upda… public 1301079971 +#> # ℹ 12 more variables: asset_mime_type , asset_format_id , +#> # asset_format_name , asset_created_at , asset_updated_at , +#> # asset_sha1 , session_id , session_name , +#> # session_date , session_release , asset_uploader_id , +#> # asset_uploader_first_name , asset_uploader_last_name ``` ## Lifecycle diff --git a/man/API_CONSTANTS.Rd b/man/DATABRARY_BASE_URL.Rd similarity index 81% rename from man/API_CONSTANTS.Rd rename to man/DATABRARY_BASE_URL.Rd index 18977a4d..b7d0c5e9 100644 --- a/man/API_CONSTANTS.Rd +++ b/man/DATABRARY_BASE_URL.Rd @@ -1,14 +1,14 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/CONSTANTS.R \docType{data} -\name{API_CONSTANTS} -\alias{API_CONSTANTS} +\name{DATABRARY_BASE_URL} +\alias{DATABRARY_BASE_URL} \title{Load Package-wide Constants into Local Environment} \format{ An object of class \code{character} of length 1. } \usage{ -API_CONSTANTS +DATABRARY_BASE_URL } \description{ Load Package-wide Constants into Local Environment diff --git a/man/download_party_avatar.Rd b/man/download_party_avatar.Rd deleted file mode 100644 index cc14ca27..00000000 --- a/man/download_party_avatar.Rd +++ /dev/null @@ -1,44 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/download_party_avatar.R -\name{download_party_avatar} -\alias{download_party_avatar} -\title{Returns the Avatar(s) (images) for Authorized User(s).} -\usage{ -download_party_avatar( - party_id = 6, - show_party_info = TRUE, - vb = options::opt("vb"), - rq = NULL -) -} -\arguments{ -\item{party_id}{A number or range of numbers. Party number or numbers to retrieve information about. Default is 6 -(Rick Gilmore).} - -\item{show_party_info}{A logical value. Show the person's name and affiliation in the output. -Default is TRUE.} - -\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - -\item{rq}{An \code{httr2} request object. If not provided, a new request is -generated via \code{make_default_request()}.} -} -\value{ -An list with the avatar (image) file and a name_affil string. -} -\description{ -Returns the Avatar(s) (images) for Authorized User(s). -} -\examples{ -\donttest{ -\dontrun{ -download_party_avatar() # Show Rick Gilmore's (party 6) avatar. - -# Download avatars from Databrary's founders (without name/affiliations) -download_party_avatar(5:7, show_party_info = FALSE) - -# Download NYU logo -download_party_avatar(party = 8) -} -} -} diff --git a/man/get_asset_segment_range.Rd b/man/get_asset_segment_range.Rd deleted file mode 100644 index 8168509f..00000000 --- a/man/get_asset_segment_range.Rd +++ /dev/null @@ -1,46 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{get_asset_segment_range} -\alias{get_asset_segment_range} -\title{Get Time Range For An Asset.} -\usage{ -get_asset_segment_range( - vol_id = 1, - session_id = 9807, - asset_id = 1, - convert_JSON = TRUE, - segment_only = TRUE, - vb = options::opt("vb"), - rq = NULL -) -} -\arguments{ -\item{vol_id}{Volume ID} - -\item{session_id}{Slot/session number.} - -\item{asset_id}{Asset number.} - -\item{convert_JSON}{A Boolean value. If TRUE, convert JSON to a data -frame. Default is TRUE.} - -\item{segment_only}{A Boolean value. If TRUE, returns only the segment -values. Otherwise returns -a data frame with two fields, segment and permission. Default is TRUE.} - -\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - -\item{rq}{An \code{httr2} request object. Default is NULL.} -} -\value{ -The time range (in ms) for an asset, if one is indicated. -} -\description{ -Get Time Range For An Asset. -} -\examples{ -\donttest{ -get_asset_segment_range() -} - -} diff --git a/man/get_assets_from_session.Rd b/man/get_assets_from_session.Rd deleted file mode 100644 index 6fa55fd0..00000000 --- a/man/get_assets_from_session.Rd +++ /dev/null @@ -1,16 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/list_volume_assets.R -\name{get_assets_from_session} -\alias{get_assets_from_session} -\title{Helper function for list_volume_assets} -\usage{ -get_assets_from_session(volume_container, ignore_materials = TRUE) -} -\arguments{ -\item{volume_container}{The 'container' list from a volume.} - -\item{ignore_materials}{A logical value.} -} -\description{ -Helper function for list_volume_assets -} diff --git a/man/get_file_duration.Rd b/man/get_file_duration.Rd index ed6e2c60..2f85028d 100644 --- a/man/get_file_duration.Rd +++ b/man/get_file_duration.Rd @@ -5,13 +5,19 @@ \title{Get Duration (In ms) Of A File.} \usage{ get_file_duration( - asset_id = 1, - types_w_durations = c("-600", "-800"), + vol_id = 2, + session_id = 9, + asset_id = 2, + types_w_durations = c(-600, -800), vb = options::opt("vb"), rq = NULL ) } \arguments{ +\item{vol_id}{Volume ID.} + +\item{session_id}{Session ID containing the asset.} + \item{asset_id}{Asset number.} \item{types_w_durations}{Asset types that have valid durations.} @@ -28,7 +34,7 @@ Get Duration (In ms) Of A File. } \examples{ \donttest{ -get_file_duration() # default is the test video from databrary.org/volume/1 +get_file_duration() # default is a public video from volume 1 } } diff --git a/man/get_folder_by_id.Rd b/man/get_folder_by_id.Rd new file mode 100644 index 00000000..938b3e5c --- /dev/null +++ b/man/get_folder_by_id.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_folder_by_id.R +\name{get_folder_by_id} +\alias{get_folder_by_id} +\title{Get Folder Metadata From a Databrary Volume.} +\usage{ +get_folder_by_id(folder_id = 1, vol_id = 1, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{folder_id}{Folder identifier within the specified volume.} + +\item{vol_id}{Volume identifier containing the folder.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A list representing the folder metadata, or \code{NULL} when the folder +cannot be accessed. +} +\description{ +Get Folder Metadata From a Databrary Volume. +} +\examples{ +\donttest{ +\dontrun{ +get_folder_by_id() # Default folder in volume 1 +} +} +} diff --git a/man/get_info_from_session.Rd b/man/get_info_from_session.Rd deleted file mode 100644 index c4d21bb4..00000000 --- a/man/get_info_from_session.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/list_volume_sessions.R -\name{get_info_from_session} -\alias{get_info_from_session} -\title{List Sessions Info in Databrary Volume Container} -\usage{ -get_info_from_session( - volume_container, - ignore_materials = FALSE, - release_levels -) -} -\arguments{ -\item{volume_container}{A component of a volume list returned by -get_volume_by_id().} - -\item{ignore_materials}{A logical value specifying whether to ignore -"materials" folders. -Default is TRUE} - -\item{release_levels}{A data frame mapping release level indices to release -level text values.} -} -\description{ -List Sessions Info in Databrary Volume Container -} diff --git a/man/get_institution_by_id.Rd b/man/get_institution_by_id.Rd new file mode 100644 index 00000000..8da21c89 --- /dev/null +++ b/man/get_institution_by_id.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_institution_by_id.R +\name{get_institution_by_id} +\alias{get_institution_by_id} +\title{Get institution metadata} +\usage{ +get_institution_by_id(institution_id = 12, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{institution_id}{Institution identifier.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} +} +\value{ +List of institution metadata or NULL when inaccessible. +} +\description{ +Get institution metadata +} diff --git a/man/get_party_by_id.Rd b/man/get_party_by_id.Rd deleted file mode 100644 index 844e01c6..00000000 --- a/man/get_party_by_id.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/get_party_by_id.R -\name{get_party_by_id} -\alias{get_party_by_id} -\title{Download Information About a Party on Databrary as JSON} -\usage{ -get_party_by_id( - party_id = 6, - parents_children_access = TRUE, - vb = options::opt("vb"), - rq = NULL -) -} -\arguments{ -\item{party_id}{An integer. The party number to retrieve information about.} - -\item{parents_children_access}{A logical value. If TRUE (the default), -returns \emph{all} of the data about the party. If FALSE, only a minimum amount -of information about the party is returned.} - -\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - -\item{rq}{An \code{httr2}-style request object. If NULL, then a new request will -be generated using \code{make_default_request()}.} -} -\value{ -A nested list with information about the party. -This can be readily parsed by other functions. -} -\description{ -Download Information About a Party on Databrary as JSON -} -\examples{ -\donttest{ -\dontrun{ -get_party_by_id() -} -} -} diff --git a/man/get_user_by_id.Rd b/man/get_user_by_id.Rd new file mode 100644 index 00000000..d4cc223b --- /dev/null +++ b/man/get_user_by_id.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_user_by_id.R +\name{get_user_by_id} +\alias{get_user_by_id} +\title{Get public profile information for a Databrary user} +\usage{ +get_user_by_id(user_id = 6, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{user_id}{User identifier.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} +} +\value{ +A list with the user's public metadata. +} +\description{ +Get public profile information for a Databrary user +} diff --git a/man/is_institution.Rd b/man/is_institution.Rd deleted file mode 100644 index f0596d17..00000000 --- a/man/is_institution.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{is_institution} -\alias{is_institution} -\title{Is This Party An Institution?} -\usage{ -is_institution(party_id = 8, vb = options::opt("vb"), rq = NULL) -} -\arguments{ -\item{party_id}{Databrary party ID} - -\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - -\item{rq}{An \code{httr2} request object.} -} -\value{ -TRUE if the party is an institution, FALSE otherwise. -} -\description{ -Is This Party An Institution? -} -\examples{ -\donttest{ -is_institution() # Is party 8 (NYU) an institution. -} - -} diff --git a/man/is_person.Rd b/man/is_person.Rd deleted file mode 100644 index 1295f3c1..00000000 --- a/man/is_person.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{is_person} -\alias{is_person} -\title{Is This Party A Person?} -\usage{ -is_person(party_id = 7, vb = options::opt("vb"), rq = NULL) -} -\arguments{ -\item{party_id}{Databrary party ID} - -\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - -\item{rq}{An \code{httr2} request object.} -} -\value{ -TRUE if the party is a person, FALSE otherwise. -} -\description{ -Is This Party A Person? -} -\examples{ -\donttest{ -is_person() -} - -} diff --git a/man/list_authorized_investigators.Rd b/man/list_authorized_investigators.Rd index 6a70cbb3..3c59939c 100644 --- a/man/list_authorized_investigators.Rd +++ b/man/list_authorized_investigators.Rd @@ -2,33 +2,22 @@ % Please edit documentation in R/list_authorized_investigators.R \name{list_authorized_investigators} \alias{list_authorized_investigators} -\title{List Authorized Investigators at Institution} +\title{List authorized investigators for an institution} \usage{ list_authorized_investigators( - party_id = 12, + institution_id = 12, vb = options::opt("vb"), rq = NULL ) } \arguments{ -\item{party_id}{Target party ID.} +\item{institution_id}{Institution identifier.} \item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - -\item{rq}{An \code{httr2}-style request object. If NULL, then a new request will -be generated using \code{make_default_request()}.} } \value{ -A data frame with information the institution's authorized -investigators. +Tibble of investigators; NULL if none. } \description{ -List Authorized Investigators at Institution -} -\examples{ -\donttest{ -\dontrun{ -list_institutional_affiliates() # Default is Penn State (party 12) -} -} +List authorized investigators for an institution } diff --git a/man/list_folder_assets.Rd b/man/list_folder_assets.Rd new file mode 100644 index 00000000..7e2745a1 --- /dev/null +++ b/man/list_folder_assets.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_folder_assets.R +\name{list_folder_assets} +\alias{list_folder_assets} +\title{List Assets Within a Databrary Folder.} +\usage{ +list_folder_assets( + folder_id = 1, + vol_id = NULL, + vb = options::opt("vb"), + rq = NULL +) +} +\arguments{ +\item{folder_id}{Folder identifier scoped to the given volume.} + +\item{vol_id}{Volume containing the folder. Required for Django API calls.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A tibble with metadata for files contained in the folder, or +\code{NULL} when the folder has no accessible assets. +} +\description{ +List Assets Within a Databrary Folder. +} +\examples{ +\donttest{ +\dontrun{ +list_folder_assets(folder_id = 1, vol_id = 1) +} +} +} diff --git a/man/list_institution_affiliates.Rd b/man/list_institution_affiliates.Rd new file mode 100644 index 00000000..26f26bf7 --- /dev/null +++ b/man/list_institution_affiliates.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_institution_affiliates.R +\name{list_institution_affiliates} +\alias{list_institution_affiliates} +\title{List affiliates for an institution} +\usage{ +list_institution_affiliates( + institution_id = 12, + vb = options::opt("vb"), + rq = NULL +) +} +\arguments{ +\item{institution_id}{Institution identifier.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} +} +\value{ +Tibble of affiliates with roles and expiration dates. +} +\description{ +List affiliates for an institution +} diff --git a/man/list_party_affiliates.Rd b/man/list_party_affiliates.Rd deleted file mode 100644 index 40d9667b..00000000 --- a/man/list_party_affiliates.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/list_party_affiliates.R -\name{list_party_affiliates} -\alias{list_party_affiliates} -\title{List Affiliates For A Party} -\usage{ -list_party_affiliates(party_id = 6, vb = options::opt("vb"), rq = NULL) -} -\arguments{ -\item{party_id}{Target party ID.} - -\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - -\item{rq}{An \code{httr2} request object. Defaults to NULL.} -} -\value{ -A data frame with information about a party's affiliates. -} -\description{ -List Affiliates For A Party -} -\examples{ -\donttest{ -list_party_affiliates() # Default is Rick Gilmore (party 6) -} -} diff --git a/man/list_party_sponsors.Rd b/man/list_party_sponsors.Rd deleted file mode 100644 index 92a664ef..00000000 --- a/man/list_party_sponsors.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/list_party_sponsors.R -\name{list_party_sponsors} -\alias{list_party_sponsors} -\title{List Sponsors For A Party} -\usage{ -list_party_sponsors(party_id = 6, vb = options::opt("vb"), rq = NULL) -} -\arguments{ -\item{party_id}{Target party ID.} - -\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - -\item{rq}{An \code{httr2}-style request object. If NULL, then a new request will -be generated using \code{make_default_request()}.} -} -\value{ -A data frame with information about a party's sponsors. -} -\description{ -List Sponsors For A Party -} -\examples{ -\donttest{ -\dontrun{ -list_party_sponsors() # Default is Rick Gilmore (party 6) -} -} - -} diff --git a/man/list_party_volumes.Rd b/man/list_party_volumes.Rd deleted file mode 100644 index 27d49e08..00000000 --- a/man/list_party_volumes.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/list_party_volumes.R -\name{list_party_volumes} -\alias{list_party_volumes} -\title{List Volumes A Party Has Access To} -\usage{ -list_party_volumes(party_id = 6, vb = options::opt("vb"), rq = NULL) -} -\arguments{ -\item{party_id}{Target party ID.} - -\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - -\item{rq}{An \code{httr2}-style request object. If NULL, then a new request will -be generated using \code{make_default_request()}.} -} -\value{ -A data frame with information about a party's sponsors. -} -\description{ -List Volumes A Party Has Access To -} -\examples{ -\donttest{ -\dontrun{ -list_party_volumes() # Default is Rick Gilmore (party 6) -} -} -} diff --git a/man/list_session_activity.Rd b/man/list_session_activity.Rd index a6c4a7aa..4454b8e5 100644 --- a/man/list_session_activity.Rd +++ b/man/list_session_activity.Rd @@ -4,32 +4,36 @@ \alias{list_session_activity} \title{List Activity History in Databrary Session.} \usage{ -list_session_activity(session_id = 6256, vb = options::opt("vb"), rq = NULL) +list_session_activity( + vol_id = 1892, + session_id = 76113, + vb = options::opt("vb"), + rq = NULL +) } \arguments{ -\item{session_id}{Selected session/slot number.} +\item{vol_id}{Volume identifier (required by the Django API).} + +\item{session_id}{Session identifier.} \item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} -\item{rq}{An \code{httr2} request object. Defaults to NULL. To access the activity -history on a volume a user has privileges on. Create a request -(\code{rq <- make_default_request()}); login using \code{make_login_client(rq = rq)}; -then run \verb{list_session_activity(session_id = , rq = rq)}} +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}. When \code{NULL}, a +default request is generated, but this will only permit public information +to be returned.} } \value{ -A list with the activity history on a session/slot. +A tibble with the activity history for a session, or \code{NULL} when +no data is available. } \description{ -If a user has access to a volume and session, this function returns the -history of modifications to that session. +For an accessible session, returns the logged history events associated with +the session. Requires authenticated access with sufficient permissions. } \examples{ -\donttest{ -\dontrun{ -# The following will only return output if the user has write privileges -# on the session. - -list_session_activity(session_id = 6256, vb = FALSE) +\\donttest{ +\\dontrun{ +list_session_activity(vol_id = 1892, session_id = 76113) } } } diff --git a/man/list_session_assets.Rd b/man/list_session_assets.Rd index 8c66f670..37b49302 100644 --- a/man/list_session_assets.Rd +++ b/man/list_session_assets.Rd @@ -4,12 +4,21 @@ \alias{list_session_assets} \title{List Assets in a Databrary Session.} \usage{ -list_session_assets(session_id = 9807, vb = options::opt("vb"), rq = NULL) +list_session_assets( + session_id = 9807, + vol_id = NULL, + vb = options::opt("vb"), + rq = NULL +) } \arguments{ \item{session_id}{An integer. A Databrary session number. Default is 9807, the "materials" folder from Databrary volume 1.} +\item{vol_id}{Optional integer. The volume containing the session. Recent +versions of the Databrary API require this value to be supplied because +session identifiers are scoped to volumes.} + \item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} \item{rq}{An \code{httr2} request object. If NULL, a default request is generated diff --git a/man/list_sponsors.Rd b/man/list_sponsors.Rd deleted file mode 100644 index 4ad73ece..00000000 --- a/man/list_sponsors.Rd +++ /dev/null @@ -1,29 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/list_sponsors.R -\name{list_sponsors} -\alias{list_sponsors} -\title{List Sponsors For A Party} -\usage{ -list_sponsors(party_id = 6, vb = options::opt("vb"), rq = NULL) -} -\arguments{ -\item{party_id}{Target party ID.} - -\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - -\item{rq}{An \code{httr2}-style request object. If NULL, then a new request will -be generated using \code{make_default_request()}.} -} -\value{ -A data frame with information about a party's sponsors. -} -\description{ -List Sponsors For A Party -} -\examples{ -\donttest{ -\dontrun{ -list_sponsors() # Default is Rick Gilmore (party 6) -} -} -} diff --git a/man/list_user_affiliates.Rd b/man/list_user_affiliates.Rd new file mode 100644 index 00000000..607ecdc9 --- /dev/null +++ b/man/list_user_affiliates.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_user_affiliates.R +\name{list_user_affiliates} +\alias{list_user_affiliates} +\title{List affiliates for a user} +\usage{ +list_user_affiliates(user_id = 6, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{user_id}{User identifier.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} +} +\value{ +Tibble of affiliates for the user. +} +\description{ +List affiliates for a user +} diff --git a/man/list_user_history.Rd b/man/list_user_history.Rd new file mode 100644 index 00000000..9433a469 --- /dev/null +++ b/man/list_user_history.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_user_history.R +\name{list_user_history} +\alias{list_user_history} +\title{List Account Activity For A Databrary User.} +\usage{ +list_user_history(user_id = 22582, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{user_id}{Target user identifier.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A tibble containing authentication and activity events for the +selected user, or \code{NULL} when no entries are available. +} +\description{ +Retrieve the OAuth and login activity history for a specific +user. Access is restricted to administrators and authorized investigators +with sufficient privileges. +} +\examples{ +\donttest{ +\dontrun{ +list_user_history(user_id = 22582) +} +} +} diff --git a/man/list_user_sponsors.Rd b/man/list_user_sponsors.Rd new file mode 100644 index 00000000..8dd7fbe5 --- /dev/null +++ b/man/list_user_sponsors.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_user_sponsors.R +\name{list_user_sponsors} +\alias{list_user_sponsors} +\title{List sponsorships for a user} +\usage{ +list_user_sponsors(user_id = 6, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{user_id}{User identifier.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} +} +\value{ +Tibble of sponsors for the user. +} +\description{ +List sponsorships for a user +} diff --git a/man/list_user_volumes.Rd b/man/list_user_volumes.Rd new file mode 100644 index 00000000..c6b691cd --- /dev/null +++ b/man/list_user_volumes.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_user_volumes.R +\name{list_user_volumes} +\alias{list_user_volumes} +\title{List volumes associated with a user} +\usage{ +list_user_volumes(user_id = 6, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{user_id}{User identifier.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} +} +\value{ +Tibble of volumes the user owns or collaborates on. +} +\description{ +List volumes associated with a user +} diff --git a/man/list_users.Rd b/man/list_users.Rd new file mode 100644 index 00000000..1ea008a2 --- /dev/null +++ b/man/list_users.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_users.R +\name{list_users} +\alias{list_users} +\title{List Databrary Users.} +\usage{ +list_users( + search = NULL, + include_suspended = NULL, + exclude_self = NULL, + is_authorized_investigator = NULL, + has_api_access = NULL, + vb = options::opt("vb"), + rq = NULL +) +} +\arguments{ +\item{search}{Optional character string used to filter results by name or +email address.} + +\item{include_suspended}{Optional logical value. When \code{TRUE}, suspended +accounts are included in the response.} + +\item{exclude_self}{Optional logical value. When \code{TRUE}, the authenticated +user is omitted from the results.} + +\item{is_authorized_investigator}{Optional logical value restricting the +response to authorized investigators.} + +\item{has_api_access}{Optional logical value restricting the response to +accounts with API access enabled.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A tibble containing directory metadata for each user, or \code{NULL} when +no results are available for the supplied filters. +} +\description{ +Retrieve directory metadata for Databrary users. Results can be +filtered by name or restricted to specific account types using optional +parameters. +} +\examples{ +\donttest{ +\dontrun{ +list_users(search = "gilmore") +} +} +} diff --git a/man/list_volume_activity.Rd b/man/list_volume_activity.Rd index 8616ed16..63e8501e 100644 --- a/man/list_volume_activity.Rd +++ b/man/list_volume_activity.Rd @@ -4,7 +4,7 @@ \alias{list_volume_activity} \title{List Activity In A Databrary Volume} \usage{ -list_volume_activity(vol_id = 1, vb = options::opt("vb"), rq = NULL) +list_volume_activity(vol_id = 1892, vb = options::opt("vb"), rq = NULL) } \arguments{ \item{vol_id}{Selected volume number.} @@ -26,7 +26,7 @@ history of the volume as a # The following will only return output if the user has write privileges # on the volume. -list_volume_activity(vol_id = 1) # Activity on volume 1. +list_volume_activity(vol_id = 1892) # Activity on volume 1892. } } } diff --git a/man/list_volume_collaborators.Rd b/man/list_volume_collaborators.Rd new file mode 100644 index 00000000..eeb46775 --- /dev/null +++ b/man/list_volume_collaborators.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_volume_collaborators.R +\name{list_volume_collaborators} +\alias{list_volume_collaborators} +\title{List Collaborators On A Databrary Volume.} +\usage{ +list_volume_collaborators(vol_id = 1, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{vol_id}{Target volume number.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A tibble summarizing collaborator relationships on the volume, or +\code{NULL} when no collaborators are associated with the volume. +} +\description{ +Retrieve collaboration metadata for a specified volume, +including sponsor details and access levels. +} +\examples{ +\donttest{ +\dontrun{ +list_volume_collaborators(vol_id = 1) +} +} +} diff --git a/man/list_volume_excerpts.Rd b/man/list_volume_excerpts.Rd deleted file mode 100644 index 4ca828e0..00000000 --- a/man/list_volume_excerpts.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/list_volume_excerpts.R -\name{list_volume_excerpts} -\alias{list_volume_excerpts} -\title{List Image or Video Excerpts On A Databrary Volume.} -\usage{ -list_volume_excerpts(vol_id = 1, vb = options::opt("vb"), rq = NULL) -} -\arguments{ -\item{vol_id}{Target volume number.} - -\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - -\item{rq}{An \code{httr2} request object. Default is NULL.} -} -\value{ -A list with information about any available excerpts. -} -\description{ -List Image or Video Excerpts On A Databrary Volume. -} -\examples{ -\donttest{ -list_volume_excerpts() -} - -} diff --git a/man/list_volume_folders.Rd b/man/list_volume_folders.Rd new file mode 100644 index 00000000..a85b82b3 --- /dev/null +++ b/man/list_volume_folders.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_volume_folders.R +\name{list_volume_folders} +\alias{list_volume_folders} +\title{List Folders in a Databrary Volume.} +\usage{ +list_volume_folders(vol_id = 1, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{vol_id}{Target volume number.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A tibble with metadata about folders in the selected volume, or +\code{NULL} when no folders are available. +} +\description{ +List Folders in a Databrary Volume. +} +\examples{ +\donttest{ +\dontrun{ +list_volume_folders() # Folders in volume 1 +} +} +} diff --git a/man/list_volume_owners.Rd b/man/list_volume_owners.Rd deleted file mode 100644 index c9029760..00000000 --- a/man/list_volume_owners.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/list_volume_owners.R -\name{list_volume_owners} -\alias{list_volume_owners} -\title{List Owners of a Databrary Volume.} -\usage{ -list_volume_owners(vol_id = 1, vb = options::opt("vb"), rq = NULL) -} -\arguments{ -\item{vol_id}{Selected volume number. Default is volume 1.} - -\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - -\item{rq}{An \code{httr2} request object. If NULL (the default) -a request will be generated, but this will only permit public information -to be returned.} -} -\value{ -A data frame with information about a volume's owner(s). -} -\description{ -List Owners of a Databrary Volume. -} -\examples{ -\donttest{ -list_volume_owners() # Lists information about the owners of volume 1. -} -} diff --git a/man/list_volume_session_assets.Rd b/man/list_volume_session_assets.Rd index 5d6c5944..524a65ea 100644 --- a/man/list_volume_session_assets.Rd +++ b/man/list_volume_session_assets.Rd @@ -5,8 +5,8 @@ \title{List Assets in a Session from a Databrary volume.} \usage{ list_volume_session_assets( - vol_id = 1, - session_id = 9807, + vol_id = 2, + session_id = 11, vb = options::opt("vb"), rq = NULL ) @@ -36,7 +36,7 @@ ID. \examples{ \donttest{ \dontrun{ -list_volume_session_assets() # Session 9807 in volume 1 +list_volume_session_assets() # Defaults to session 11 in volume 2 } } } diff --git a/man/list_volumes.Rd b/man/list_volumes.Rd new file mode 100644 index 00000000..6b3dddc2 --- /dev/null +++ b/man/list_volumes.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_volumes.R +\name{list_volumes} +\alias{list_volumes} +\title{List Volumes Accessible Through The Databrary API.} +\usage{ +list_volumes( + search = NULL, + ordering = NULL, + vb = options::opt("vb"), + rq = NULL +) +} +\arguments{ +\item{search}{Optional character string used to filter volumes by title or +description.} + +\item{ordering}{Optional character string indicating the sort field accepted +by the API (e.g., \code{"title"}, \code{"-title"}).} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A tibble summarizing each accessible volume, or \code{NULL} when no +volumes match the supplied filters. +} +\description{ +Returns summary metadata for volumes accessible to the +authenticated user. Results can be filtered by search term or ordering. +} +\examples{ +\donttest{ +\dontrun{ +list_volumes(search = "workshop") +} +} +} diff --git a/man/make_login_client.Rd b/man/make_login_client.Rd index 5c2a26ea..f3a3262e 100644 --- a/man/make_login_client.Rd +++ b/man/make_login_client.Rd @@ -36,7 +36,7 @@ Logical value indicating whether log in is successful or not. Log In To Databrary.org. } \examples{ -\dontshow{if (interactive()) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (interactive()) withAutoprint(\{ # examplesIf} make_login_client() # Queries user for email and password interactively. \dontshow{\}) # examplesIf} \donttest{ diff --git a/man/search_for_funder.Rd b/man/search_for_funder.Rd index c24edb55..c6589194 100644 --- a/man/search_for_funder.Rd +++ b/man/search_for_funder.Rd @@ -5,7 +5,8 @@ \title{Report Information About A Funder.} \usage{ search_for_funder( - search_string = "national+science+foundation", + search_string = "national science foundation", + approved_only = TRUE, vb = options::opt("vb"), rq = NULL ) @@ -13,6 +14,9 @@ search_for_funder( \arguments{ \item{search_string}{String to search.} +\item{approved_only}{Logical. When TRUE (default) only approved funders are +returned. Set to FALSE to include unapproved funders as well.} + \item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} \item{rq}{An \code{httr2} request object. Default is NULL.} diff --git a/man/search_for_keywords.Rd b/man/search_for_keywords.Rd deleted file mode 100644 index d480ed82..00000000 --- a/man/search_for_keywords.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/search_for_keywords.R -\name{search_for_keywords} -\alias{search_for_keywords} -\title{Search For Keywords in Databrary Volumes.} -\usage{ -search_for_keywords( - search_string = "locomotion", - vb = options::opt("vb"), - rq = NULL -) -} -\arguments{ -\item{search_string}{String to search.} - -\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - -\item{rq}{An \code{httr2} request object. Default is NULL.} -} -\value{ -A list with the volumes that contain the keyword. -} -\description{ -Search For Keywords in Databrary Volumes. -} -\examples{ -\dontrun{ -search_for_keywords() # searches for volumes with "locomotion" as a keyword. -search_for_keywords() - -# searches for volumes with "adult" as a keyword. -search_for_keywords("adult") -} -} diff --git a/man/search_institutions.Rd b/man/search_institutions.Rd new file mode 100644 index 00000000..c5db1d56 --- /dev/null +++ b/man/search_institutions.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/search_institutions.R +\name{search_institutions} +\alias{search_institutions} +\title{Search For Institutions In Databrary.} +\usage{ +search_institutions(search_string, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{search_string}{Character string describing the institution search +query.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A tibble containing matching institutions ordered by relevance, or +\code{NULL} when no matches exist for the query. +} +\description{ +Perform a search across institutions registered with +Databrary. +} +\examples{ +\donttest{ +\dontrun{ +search_institutions("state") +} +} +} diff --git a/man/search_users.Rd b/man/search_users.Rd new file mode 100644 index 00000000..0d08e919 --- /dev/null +++ b/man/search_users.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/search_users.R +\name{search_users} +\alias{search_users} +\title{Search For Users In Databrary.} +\usage{ +search_users(search_string, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{search_string}{Character string describing the search query.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A tibble containing user matches ordered by relevance, or \code{NULL} +when no matches exist for the query. +} +\description{ +Perform a directory search across Databrary users by name or +email address. +} +\examples{ +\donttest{ +\dontrun{ +search_users("gilmore") +} +} +} diff --git a/man/search_volumes.Rd b/man/search_volumes.Rd new file mode 100644 index 00000000..4bf2b40b --- /dev/null +++ b/man/search_volumes.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/search_volumes.R +\name{search_volumes} +\alias{search_volumes} +\title{Search For Volumes In Databrary.} +\usage{ +search_volumes(search_string, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{search_string}{Character string describing the volume search query.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A tibble containing matching volumes ordered by relevance, or \code{NULL} +when no matches exist for the query. +} +\description{ +Search across Databrary volumes using the Django search +endpoint. +} +\examples{ +\donttest{ +\dontrun{ +search_volumes("workshop") +} +} +} diff --git a/tests/testthat/helper-auth.R b/tests/testthat/helper-auth.R new file mode 100644 index 00000000..743fe4b7 --- /dev/null +++ b/tests/testthat/helper-auth.R @@ -0,0 +1,52 @@ +login_test_account <- function() { + set_if_missing <- function(var, value) { + current <- Sys.getenv(var, NA_character_) + if (is.na(current) || !nzchar(current)) { + Sys.setenv(var = value) + } + } + + set_if_missing("DATABRARY_BASE_URL", "https://api.stg-databrary.its.nyu.edu") + set_if_missing("USER_AGENT", "SRW$*Kxy2nYdyo4LozoGV#i6LvH/") + set_if_missing("DATABRARY_LOGIN", "pawel.armatys+1@montrosesoftware.com") + set_if_missing("DATABRARY_PASSWORD", "tindov-9ciVxa-hehguw") + set_if_missing("DATABRARY_CLIENT_ID", "9B0gJF1b5OSkkrjPrkKHeYHgWLOJ0N1Uxv2tW3KS") + set_if_missing("DATABRARY_CLIENT_SECRET", "Mz7LuOXvWHEEcUIffkOtjXIBrb0brhCVtxIKoOq4GxKrp9ZJAa1fjFSsqAu8HnrPtKpXnYwrWxRsauD3Ap2va1Xc41DOEPWBqQcsRHAC7dZai5LEl5n7lC7Wcb0tKLy2") + + vals <- list( + email = Sys.getenv("DATABRARY_LOGIN", "pawel.armatys+1@montrosesoftware.com"), + password = Sys.getenv("DATABRARY_PASSWORD", "tindov-9ciVxa-hehguw"), + client_id = Sys.getenv("DATABRARY_CLIENT_ID", "9B0gJF1b5OSkkrjPrkKHeYHgWLOJ0N1Uxv2tW3KS"), + client_secret = Sys.getenv("DATABRARY_CLIENT_SECRET", "Mz7LuOXvWHEEcUIffkOtjXIBrb0brhCVtxIKoOq4GxKrp9ZJAa1fjFSsqAu8HnrPtKpXnYwrWxRsauD3Ap2va1Xc41DOEPWBqQcsRHAC7dZai5LEl5n7lC7Wcb0tKLy2") + ) + + have_creds <- all(vapply(vals, function(x) nzchar(x), logical(1))) + if (!have_creds) { + testthat::skip("OAuth credentials not available for live API test.") + } + + suppressMessages(databraryr::login_db( + email = vals$email, + password = vals$password, + client_id = vals$client_id, + client_secret = vals$client_secret, + store = FALSE, + vb = FALSE + )) + + # Ensure token is cached for subsequent requests. + bundle <- databraryr:::get_token_bundle() + if (is.null(bundle)) { + testthat::skip("Unable to obtain OAuth token for live API test.") + } + + invisible(TRUE) +} + + +skip_if_null_response <- function(result, context) { + if (is.null(result)) { + testthat::skip(paste0(context, " returned NULL on staging; skipping.")) + } +} + diff --git a/tests/testthat/test-assign_constants.R b/tests/testthat/test-assign_constants.R index d89f437b..3d30711a 100644 --- a/tests/testthat/test-assign_constants.R +++ b/tests/testthat/test-assign_constants.R @@ -1,5 +1,11 @@ -test_that("assign_constants returns list", { - expect_true("list" %in% class(assign_constants())) +test_that("assign_constants returns constants", { + login_test_account() + result <- assign_constants() + skip_if_null_response(result, "assign_constants()") + expect_true(is.list(result)) + expect_true("format_df" %in% names(result)) + expect_s3_class(result$format_df, "tbl_df") + expect_gt(nrow(result$format_df), 0) }) test_that("assign_constants rejects bad input parameters", { @@ -11,3 +17,13 @@ test_that("assign_constants rejects bad input parameters", { expect_error(assign_constants(rq = 3)) expect_error(assign_constants(rq = "a")) }) + +test_that("assign_constants returns permission metadata", { + login_test_account() + result <- assign_constants() + skip_if_null_response(result, "assign_constants() metadata") + expect_true("permission" %in% names(result)) + expect_true("release" %in% names(result)) + expect_true("volume_access_levels" %in% names(result$permission)) + expect_true(length(result$permission$volume_access_levels) > 0) +}) diff --git a/tests/testthat/test-auth_service.R b/tests/testthat/test-auth_service.R new file mode 100644 index 00000000..5ce7ea84 --- /dev/null +++ b/tests/testthat/test-auth_service.R @@ -0,0 +1,57 @@ +test_that("httr2_error_message handles missing and successful responses", { + expect_match(databraryr:::httr2_error_message(NULL), "Request failed") + + ok_resp <- httr2::response( + status_code = 200, + url = "https://example.org/ok", + body = raw() + ) + expect_null(databraryr:::httr2_error_message(ok_resp)) +}) + +test_that("httr2_error_message extracts error details", { + error_resp <- httr2::response( + status_code = 401, + url = "https://example.org/error", + headers = list("Content-Type" = "application/json"), + body = charToRaw('{"error":"invalid_grant"}') + ) + + expect_match(databraryr:::httr2_error_message(error_resp), "HTTP 401") +}) + +test_that("oauth_password_grant returns NULL when request fails", { + old_url <- get("OAUTH_TOKEN_URL", envir = asNamespace("databraryr")) + on.exit(assignInNamespace("OAUTH_TOKEN_URL", old_url, ns = "databraryr"), add = TRUE) + + assignInNamespace("OAUTH_TOKEN_URL", "http://127.0.0.1:9/o/token/", ns = "databraryr") + + result <- databraryr:::oauth_password_grant( + username = "user@example.org", + password = "secret", + client_id = "cid", + client_secret = "csec", + vb = FALSE + ) + + expect_null(result) +}) + +test_that("oauth_refresh_grant returns NULL when request fails", { + databraryr:::set_token_bundle(access_token = "token", refresh_token = "refresh", expires_in = 3600) + on.exit(databraryr:::clear_token_bundle(), add = TRUE) + old_url <- get("OAUTH_TOKEN_URL", envir = asNamespace("databraryr")) + on.exit(assignInNamespace("OAUTH_TOKEN_URL", old_url, ns = "databraryr"), add = TRUE) + + assignInNamespace("OAUTH_TOKEN_URL", "http://127.0.0.1:9/o/token/", ns = "databraryr") + + result <- databraryr:::oauth_refresh_grant( + refresh_token = "refresh", + client_id = "cid", + client_secret = "csec", + vb = FALSE + ) + + expect_null(result) +}) + diff --git a/tests/testthat/test-download_party_avatar.R b/tests/testthat/test-download_party_avatar.R deleted file mode 100644 index 9d56dffd..00000000 --- a/tests/testthat/test-download_party_avatar.R +++ /dev/null @@ -1,20 +0,0 @@ -test_that("download_party_avatar rejects bad input parameters", { - expect_error(download_party_avatar(party_id = -1)) - expect_error(download_party_avatar(party_id = "a")) - expect_error(download_party_avatar(party_id = TRUE)) - - expect_error(download_party_avatar(show_person_info = -1)) - expect_error(download_party_avatar(show_person_info = 3)) - expect_error(download_party_avatar(show_person_info = "a")) - expect_error(download_party_avatar(show_person_info = list(a=1, b=2))) - - expect_error(download_party_avatar(vb = -1)) - expect_error(download_party_avatar(vb = 3)) - expect_error(download_party_avatar(vb = "a")) - expect_error(download_party_avatar(vb = list(a=1, b=2))) - - expect_error(download_party_avatar(rq = -1)) - expect_error(download_party_avatar(rq = "a")) - expect_error(download_party_avatar(rq = list(a=1, b=2))) - expect_error(download_party_avatar(rq = NA)) -}) diff --git a/tests/testthat/test-download_session_zip.R b/tests/testthat/test-download_session_zip.R index 45a0a7c7..91bd6f68 100644 --- a/tests/testthat/test-download_session_zip.R +++ b/tests/testthat/test-download_session_zip.R @@ -25,5 +25,6 @@ test_that("download_session_zip rejects bad input parameters", { }) test_that("download_session_zip returns string", { + testthat::skip("Download route still under migration to Django signed-link workflow") expect_true(is.character(download_session_zip())) }) diff --git a/tests/testthat/test-download_volume_zip.R b/tests/testthat/test-download_volume_zip.R index f29cc225..8c0bc589 100644 --- a/tests/testthat/test-download_volume_zip.R +++ b/tests/testthat/test-download_volume_zip.R @@ -21,5 +21,6 @@ test_that("download_volume_zip rejects bad input parameters", { test_that("download_volume_zip returns string", { + testthat::skip("Download route still under migration to Django signed-link workflow") expect_true(is.character(download_volume_zip())) }) diff --git a/tests/testthat/test-get_db_stats.R b/tests/testthat/test-get_db_stats.R index 5babc67b..0f8f173f 100644 --- a/tests/testthat/test-get_db_stats.R +++ b/tests/testthat/test-get_db_stats.R @@ -1,29 +1,26 @@ # get_db_stats --------------------------------------------------------- -test_that("get_db_stats returns a data.frame by default", { - expect_true('data.frame' %in% class(get_db_stats())) +test_that("get_db_stats returns statistics snapshot", { + login_test_account() + stats <- get_db_stats() + skip_if_null_response(stats, "get_db_stats()") + expect_s3_class(stats, "tbl_df") + expect_true("date" %in% names(stats)) }) -test_that("get_db_stats returns a data.frame with 'good' values for - type parameter", - { - expect_true(is.data.frame(get_db_stats("people")) | - is.null(get_db_stats("people"))) - expect_true(is.data.frame(get_db_stats("institutions")) | - is.null(get_db_stats("institutions"))) - expect_true(is.data.frame(get_db_stats("places")) | - is.null(get_db_stats("places"))) - expect_true(is.data.frame(get_db_stats("datasets")) | - is.null(get_db_stats("datasets"))) - expect_true(is.data.frame(get_db_stats("data")) | - is.null(get_db_stats("data"))) - expect_true(is.data.frame(get_db_stats("volumes")) | - is.null(get_db_stats("volumes"))) - expect_true(is.data.frame(get_db_stats("stats")) | - is.null(get_db_stats("stats"))) - expect_true(is.data.frame(get_db_stats("numbers")) | - is.null(get_db_stats("numbers"))) - - }) +test_that("get_db_stats returns data.frames for supported types", { + login_test_account() + types <- c("people", "institutions", "places", "datasets", "data", "volumes", "numbers") + for (type in types) { + result <- get_db_stats(type) + skip_if_null_response(result, sprintf("get_db_stats('%s')", type)) + expect_s3_class(result, "tbl_df") + } + + stats_tbl <- get_db_stats("stats") + skip_if_null_response(stats_tbl, "get_db_stats('stats')") + expect_s3_class(stats_tbl, "tbl_df") + expect_true("date" %in% names(stats_tbl)) +}) test_that("get_db_stats rejects bad input parameters", { expect_error(get_db_stats(type = "a")) diff --git a/tests/testthat/test-get_folder_by_id.R b/tests/testthat/test-get_folder_by_id.R new file mode 100644 index 00000000..0d560d45 --- /dev/null +++ b/tests/testthat/test-get_folder_by_id.R @@ -0,0 +1,38 @@ +# get_folder_by_id ------------------------------------------------------------- +test_that("get_folder_by_id returns folder metadata", { + login_test_account() + folders <- list_volume_folders(vol_id = 2) + skip_if_null_response(folders, "list_volume_folders(vol_id = 2)") + + target_folder <- folders$folder_id[1] + result <- get_folder_by_id(folder_id = target_folder, vol_id = 2) + skip_if_null_response(result, sprintf("get_folder_by_id(folder_id = %s, vol_id = 2)", target_folder)) + + expect_type(result, "list") + expect_equal(result$id, target_folder) +}) + +test_that("get_folder_by_id rejects bad input parameters", { + expect_error(get_folder_by_id(folder_id = "a")) + expect_error(get_folder_by_id(folder_id = c(1, 2))) + expect_error(get_folder_by_id(folder_id = TRUE)) + expect_error(get_folder_by_id(folder_id = list(a = 1, b = 2))) + expect_error(get_folder_by_id(folder_id = -1)) + + expect_error(get_folder_by_id(vol_id = "a")) + expect_error(get_folder_by_id(vol_id = c(1, 2))) + expect_error(get_folder_by_id(vol_id = TRUE)) + expect_error(get_folder_by_id(vol_id = list(a = 1, b = 2))) + expect_error(get_folder_by_id(vol_id = -1)) + + expect_error(get_folder_by_id(vb = -1)) + expect_error(get_folder_by_id(vb = 3)) + expect_error(get_folder_by_id(vb = "a")) + expect_error(get_folder_by_id(vb = list(a = 1, b = 2))) + + expect_error(get_folder_by_id(rq = "a")) + expect_error(get_folder_by_id(rq = -1)) + expect_error(get_folder_by_id(rq = c(2, 3))) + expect_error(get_folder_by_id(rq = list(a = 1, b = 2))) +}) + diff --git a/tests/testthat/test-get_institution_by_id.R b/tests/testthat/test-get_institution_by_id.R new file mode 100644 index 00000000..24f94b66 --- /dev/null +++ b/tests/testthat/test-get_institution_by_id.R @@ -0,0 +1,11 @@ +test_that("get_institution_by_id returns institution metadata", { + login_test_account() + result <- get_institution_by_id(1) + skip_if_null_response(result, "get_institution_by_id(1)") + expect_true(is.list(result)) + expect_equal(result$id, 1) + expect_equal(result$name, "Databrary") +}) + + + diff --git a/tests/testthat/test-get_party_by_id.R b/tests/testthat/test-get_party_by_id.R deleted file mode 100644 index 144fb0ec..00000000 --- a/tests/testthat/test-get_party_by_id.R +++ /dev/null @@ -1,25 +0,0 @@ -# get_party_by_id --------------------------------------------------------- -test_that("get_party_by_id returns a list or is NULL.", { - expect_true((is.null(get_party_by_id()) || - ("list" %in% class(get_party_by_id())))) -}) - -test_that("get_party_by_id rejects bad input parameters", { - expect_error(get_party_by_id(party_id = "a")) - expect_error(get_party_by_id(party_id = -1)) - expect_error(get_party_by_id(party_id = c(2,3))) - expect_error(get_party_by_id(party_id = TRUE)) - - expect_error(get_party_by_id(parents_children_access = "a")) - expect_error(get_party_by_id(parents_children_access = -1)) - expect_error(get_party_by_id(parents_children_access = c(2,3))) - - expect_error(get_party_by_id(vb = "a")) - expect_error(get_party_by_id(vb = -1)) - expect_error(get_party_by_id(vb = c(2,3))) - - expect_error(get_party_by_id(rq = "a")) - expect_error(get_party_by_id(rq = -1)) - expect_error(get_party_by_id(rq = c(2,3))) - expect_error(get_party_by_id(rq = list(a=1, b=2))) -}) diff --git a/tests/testthat/test-get_session_by_id.R b/tests/testthat/test-get_session_by_id.R index 9f15ce32..b5634ad0 100644 --- a/tests/testthat/test-get_session_by_id.R +++ b/tests/testthat/test-get_session_by_id.R @@ -1,7 +1,10 @@ # get_session_by_id --------------------------------------------------------- test_that("get_session_by_id returns a list or is NULL.", { - expect_true((is.null(get_session_by_id()) || - ("list" %in% class(get_session_by_id())))) + login_test_account() + result <- get_session_by_id(session_id = 9, vol_id = 2) + skip_if_null_response(result, "get_session_by_id(session_id = 9, vol_id = 2)") + expect_true(is.list(result)) + expect_equal(result$id, 9) }) test_that("get_session_by_id rejects bad input parameters", { diff --git a/tests/testthat/test-get_session_by_name.R b/tests/testthat/test-get_session_by_name.R index fa6f60a4..593dead9 100644 --- a/tests/testthat/test-get_session_by_name.R +++ b/tests/testthat/test-get_session_by_name.R @@ -1,14 +1,17 @@ # get_session_by_name --------------------------------------------------------- -test_that("get_session_by_name returns a list or is NULL.", { - expect_true((is.null(get_session_by_name()) || - ("list" %in% class(get_session_by_name())))) +test_that("get_session_by_name returns session metadata", { + login_test_account() + result <- get_session_by_name("to-airport", vol_id = 2) + skip_if_null_response(result, "get_session_by_name(\"to-airport\", vol_id = 2)") + expect_true(is.list(result)) + expect_equal(length(result), 1) + expect_equal(result[[1]]$id, 11) }) test_that("get_session_by_name rejects bad input parameters", { - expect_error(get_session_by_name(session_id = "a")) - expect_error(get_session_by_name(session_id = -1)) - expect_error(get_session_by_name(session_id = c(2,3))) - expect_error(get_session_by_name(session_id = TRUE)) + expect_error(get_session_by_name(session_name = 123)) + expect_error(get_session_by_name(session_name = c("a", "b"))) + expect_error(get_session_by_name(session_name = NA_character_)) expect_error(get_session_by_name(vol_id = -1)) expect_error(get_session_by_name(vol_id = "a")) diff --git a/tests/testthat/test-get_user_by_id.R b/tests/testthat/test-get_user_by_id.R new file mode 100644 index 00000000..976ddc1e --- /dev/null +++ b/tests/testthat/test-get_user_by_id.R @@ -0,0 +1,9 @@ +test_that("get_user_by_id returns user metadata", { + login_test_account() + result <- get_user_by_id(22582) + skip_if_null_response(result, "get_user_by_id(22582)") + expect_true(is.list(result)) + expect_equal(result$id, 22582) + expect_true(grepl("Armatys", result$sortname)) +}) + diff --git a/tests/testthat/test-get_volume_by_id.R b/tests/testthat/test-get_volume_by_id.R index bd0a49ba..f63ea613 100644 --- a/tests/testthat/test-get_volume_by_id.R +++ b/tests/testthat/test-get_volume_by_id.R @@ -1,7 +1,10 @@ # get_volume_by_id --------------------------------------------------------- test_that("get_volume_by_id returns a list or is NULL.", { - expect_true((is.null(get_volume_by_id()) || - ("list" %in% class(get_volume_by_id())))) + login_test_account() + result <- get_volume_by_id(vol_id = 2) + skip_if_null_response(result, "get_volume_by_id(vol_id = 2)") + expect_s3_class(result, "tbl_df") + expect_equal(result$id, 2) }) test_that("get_volume_by_id rejects bad input parameters", { diff --git a/tests/testthat/test-list_asset_formats.R b/tests/testthat/test-list_asset_formats.R new file mode 100644 index 00000000..b654dd5a --- /dev/null +++ b/tests/testthat/test-list_asset_formats.R @@ -0,0 +1,15 @@ +test_that("list_asset_formats returns format metadata", { + login_test_account() + formats <- suppressWarnings(list_asset_formats()) + skip_if_null_response(formats, "list_asset_formats()") + expect_true(is.data.frame(formats)) + expect_true(all(c("format_id", "format_mimetype", "format_name", "category") %in% names(formats))) + expect_gt(nrow(formats), 0) +}) + +test_that("list_asset_formats rejects bad input parameters", { + expect_error(list_asset_formats(vb = -1)) + expect_error(list_asset_formats(vb = 2)) + expect_error(list_asset_formats(vb = "a")) +}) + diff --git a/tests/testthat/test-list_authorized_investigators.R b/tests/testthat/test-list_authorized_investigators.R index 9f5ddd8f..b312fc9d 100644 --- a/tests/testthat/test-list_authorized_investigators.R +++ b/tests/testthat/test-list_authorized_investigators.R @@ -1,18 +1,19 @@ # list_authorized_investigators --------------------------------------------------------- -test_that("list_authorized_investigators returns a data.frame or is NULL.", - { - expect_true(( - is.null(list_authorized_investigators()) || - (class(list_authorized_investigators()) == "data.frame") - )) - }) +test_that("list_authorized_investigators returns investigators for institution 1", { + login_test_account() + result <- list_authorized_investigators(institution_id = 1) + skip_if_null_response(result, "list_authorized_investigators(institution_id = 1)") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) + expect_true(all(c("institution_id", "user_id") %in% names(result))) +}) test_that("list_authorized_investigators rejects bad input parameters", { - expect_error(list_authorized_investigators(party_id = "a")) - expect_error(list_authorized_investigators(party_id = -1)) - expect_error(list_authorized_investigators(party_id = TRUE)) - expect_error(list_authorized_investigators(party_id = c(1, 3))) - expect_error(list_authorized_investigators(party_id = list(a = 1, b = + expect_error(list_authorized_investigators(institution_id = "a")) + expect_error(list_authorized_investigators(institution_id = -1)) + expect_error(list_authorized_investigators(institution_id = TRUE)) + expect_error(list_authorized_investigators(institution_id = c(1, 3))) + expect_error(list_authorized_investigators(institution_id = list(a = 1, b = 2))) expect_error(list_authorized_investigators(vb = "a")) @@ -21,9 +22,3 @@ test_that("list_authorized_investigators rejects bad input parameters", { expect_error(list_authorized_investigators(vb = list(a = 1, b = 2))) }) -test_that( - "list_authorized_investigators returns NULL for invalid (non-institutional) party IDs", - { - expect_true(is.null(list_authorized_investigators(party_id = 5))) - } -) diff --git a/tests/testthat/test-list_folder_assets.R b/tests/testthat/test-list_folder_assets.R new file mode 100644 index 00000000..b58def0e --- /dev/null +++ b/tests/testthat/test-list_folder_assets.R @@ -0,0 +1,40 @@ +# list_folder_assets ----------------------------------------------------------- +test_that("list_folder_assets returns tibble for accessible folder", { + login_test_account() + folders <- list_volume_folders(vol_id = 2) + skip_if_null_response(folders, "list_volume_folders(vol_id = 2)") + + target_folder <- folders$folder_id[1] + result <- list_folder_assets(folder_id = target_folder, vol_id = 2) + skip_if_null_response(result, sprintf("list_folder_assets(folder_id = %s, vol_id = 2)", target_folder)) + + expect_s3_class(result, "tbl_df") + expect_true(all(result$folder_id == target_folder)) +}) + +test_that("list_folder_assets rejects bad input parameters", { + expect_error(list_folder_assets(folder_id = "a", vol_id = 1)) + expect_error(list_folder_assets(folder_id = c(1, 2), vol_id = 1)) + expect_error(list_folder_assets(folder_id = TRUE, vol_id = 1)) + expect_error(list_folder_assets(folder_id = list(a = 1, b = 2), vol_id = 1)) + expect_error(list_folder_assets(folder_id = -1, vol_id = 1)) + + expect_error(list_folder_assets(folder_id = 1)) + + expect_error(list_folder_assets(folder_id = 1, vol_id = "a")) + expect_error(list_folder_assets(folder_id = 1, vol_id = c(1, 2))) + expect_error(list_folder_assets(folder_id = 1, vol_id = TRUE)) + expect_error(list_folder_assets(folder_id = 1, vol_id = list(a = 1, b = 2))) + expect_error(list_folder_assets(folder_id = 1, vol_id = -1)) + + expect_error(list_folder_assets(folder_id = 1, vol_id = 1, vb = -1)) + expect_error(list_folder_assets(folder_id = 1, vol_id = 1, vb = 3)) + expect_error(list_folder_assets(folder_id = 1, vol_id = 1, vb = "a")) + expect_error(list_folder_assets(folder_id = 1, vol_id = 1, vb = list(a = 1, b = 2))) + + expect_error(list_folder_assets(folder_id = 1, vol_id = 1, rq = "a")) + expect_error(list_folder_assets(folder_id = 1, vol_id = 1, rq = -1)) + expect_error(list_folder_assets(folder_id = 1, vol_id = 1, rq = c(2, 3))) + expect_error(list_folder_assets(folder_id = 1, vol_id = 1, rq = list(a = 1, b = 2))) +}) + diff --git a/tests/testthat/test-list_institution_affiliates.R b/tests/testthat/test-list_institution_affiliates.R new file mode 100644 index 00000000..633e74ab --- /dev/null +++ b/tests/testthat/test-list_institution_affiliates.R @@ -0,0 +1,10 @@ +test_that("list_institution_affiliates returns affiliates for institution 1", { + login_test_account() + result <- list_institution_affiliates(1) + skip_if_null_response(result, "list_institution_affiliates(1)") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) +}) + + + diff --git a/tests/testthat/test-list_party_affiliates.R b/tests/testthat/test-list_party_affiliates.R deleted file mode 100644 index 4d5ecdd7..00000000 --- a/tests/testthat/test-list_party_affiliates.R +++ /dev/null @@ -1,25 +0,0 @@ -# list_party_affiliates --------------------------------------------------------- -test_that("list_party_affiliates returns a data frame or is NULL.", { - expect_true(( - is.null(list_party_affiliates()) || - ("data.frame" %in% class(list_party_affiliates())) - )) -}) - -test_that("list_party rejects bad input parameters", { - expect_error(list_party_affiliates(party_id = "a")) - expect_error(list_party_affiliates(party_id = -1)) - expect_error(list_party_affiliates(party_id = TRUE)) - expect_error(list_party_affiliates(party_id = c(1, 3))) - expect_error(list_party_affiliates(party_id = list(a = 1, b = 2))) - - expect_error(list_party_affiliates(vb = "a")) - expect_error(list_party_affiliates(vb = -1)) - expect_error(list_party_affiliates(vb = c(2, 3))) - expect_error(list_party_affiliates(vb = list(a = 1, b = 2))) - - expect_error(list_party_affiliates(rq = "a")) - expect_error(list_party_affiliates(rq = -1)) - expect_error(list_party_affiliates(rq = c(2, 3))) - expect_error(list_party_affiliates(rq = list(a = 1, b = 2))) -}) diff --git a/tests/testthat/test-list_party_sponsors.R b/tests/testthat/test-list_party_sponsors.R deleted file mode 100644 index e82899d3..00000000 --- a/tests/testthat/test-list_party_sponsors.R +++ /dev/null @@ -1,25 +0,0 @@ -# list_party_sponsors --------------------------------------------------------- -test_that("list_party_sponsors returns a data frame or is NULL.", { - expect_true((is.null(list_party_sponsors()) || - ( - class(list_party_sponsors()) == "data.frame" - ))) -}) - -test_that("list_party rejects bad input parameters", { - expect_error(list_party_sponsors(party_id = "a")) - expect_error(list_party_sponsors(party_id = -1)) - expect_error(list_party_sponsors(party_id = TRUE)) - expect_error(list_party_sponsors(party_id = c(1, 3))) - expect_error(list_party_sponsors(party_id = list(a = 1, b = 2))) - - expect_error(list_party_sponsors(vb = "a")) - expect_error(list_party_sponsors(vb = -1)) - expect_error(list_party_sponsors(vb = c(2, 3))) - expect_error(list_party_sponsors(vb = list(a = 1, b = 2))) - - expect_error(list_party_sponsors(rq = "a")) - expect_error(list_party_sponsors(rq = -1)) - expect_error(list_party_sponsors(rq = c(2, 3))) - expect_error(list_party_sponsors(rq = list(a = 1, b = 2))) -}) diff --git a/tests/testthat/test-list_party_volumes.R b/tests/testthat/test-list_party_volumes.R deleted file mode 100644 index 52671c96..00000000 --- a/tests/testthat/test-list_party_volumes.R +++ /dev/null @@ -1,25 +0,0 @@ -# list_party_volumes --------------------------------------------------------- -test_that("list_party_volumes returns a data frame or is NULL.", { - expect_true((is.null(list_party_volumes()) || - ( - "data.frame" %in% class(list_party_volumes()) - ))) -}) - -test_that("list_party rejects bad input parameters", { - expect_error(list_party_volumes(party_id = "a")) - expect_error(list_party_volumes(party_id = -1)) - expect_error(list_party_volumes(party_id = TRUE)) - expect_error(list_party_volumes(party_id = c(1, 3))) - expect_error(list_party_volumes(party_id = list(a = 1, b = 2))) - - expect_error(list_party_volumes(vb = "a")) - expect_error(list_party_volumes(vb = -1)) - expect_error(list_party_volumes(vb = c(2, 3))) - expect_error(list_party_volumes(vb = list(a = 1, b = 2))) - - expect_error(list_party_volumes(rq = "a")) - expect_error(list_party_volumes(rq = -1)) - expect_error(list_party_volumes(rq = c(2, 3))) - expect_error(list_party_volumes(rq = list(a = 1, b = 2))) -}) diff --git a/tests/testthat/test-list_session_activity.R b/tests/testthat/test-list_session_activity.R index d8272969..f7f75444 100644 --- a/tests/testthat/test-list_session_activity.R +++ b/tests/testthat/test-list_session_activity.R @@ -1,9 +1,9 @@ # list_session_activity --------------------------------------------------------- -test_that("list_session_activity returns data.frame or is NULL", { - expect_true(( - is.null(list_session_activity()) || - ("data.frame" %in% class(list_session_activity())) - )) +test_that("list_session_activity returns tibble or is NULL", { + login_test_account() + result <- list_session_activity(vol_id = 1892, session_id = 76113) + skip_if_null_response(result, "list_session_activity(vol_id = 1892, session_id = 76113)") + expect_s3_class(result, "tbl_df") }) test_that("list_session_activity rejects bad input parameters", { diff --git a/tests/testthat/test-list_session_assets.R b/tests/testthat/test-list_session_assets.R index 873ba785..7a3f4ef6 100644 --- a/tests/testthat/test-list_session_assets.R +++ b/tests/testthat/test-list_session_assets.R @@ -1,25 +1,34 @@ # list_session_assets --------------------------------------------------------- -test_that("list_session_assets returns data.frame or is NULL", { - expect_true((is.null(list_session_assets()) || - ( - "data.frame" %in% class(list_session_assets()) - ))) +test_that("list_session_assets requires volume id", { + expect_error(list_session_assets(session_id = 9807)) +}) + +test_that("list_session_assets returns tibble for accessible session", { + login_test_account() + result <- list_session_assets(session_id = 9, vol_id = 2) + skip_if_null_response(result, "list_session_assets(session_id = 9, vol_id = 2)") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) }) test_that("list_session_assets rejects bad input parameters", { - expect_error(list_session_assets(session_id = "a")) - expect_error(list_session_assets(session_id = c(1, 2))) - expect_error(list_session_assets(session_id = TRUE)) - expect_error(list_session_assets(session_id = list(a = 1, b = 2))) - expect_error(list_session_assets(session_id = -1)) - - expect_error(list_session_assets(vb = -1)) - expect_error(list_session_assets(vb = 3)) - expect_error(list_session_assets(vb = "a")) - expect_error(list_session_assets(vb = list(a = 1, b = 2))) - - expect_error(list_session_assets(rq = "a")) - expect_error(list_session_assets(rq = -1)) - expect_error(list_session_assets(rq = c(2, 3))) - expect_error(list_session_assets(rq = list(a = 1, b = 2))) + expect_error(list_session_assets(session_id = "a", vol_id = 1)) + expect_error(list_session_assets(session_id = c(1, 2), vol_id = 1)) + expect_error(list_session_assets(session_id = TRUE, vol_id = 1)) + expect_error(list_session_assets(session_id = list(a = 1, b = 2), vol_id = 1)) + expect_error(list_session_assets(session_id = -1, vol_id = 1)) + + expect_error(list_session_assets(session_id = 9, vol_id = "a")) + expect_error(list_session_assets(session_id = 9, vol_id = c(1, 2))) + expect_error(list_session_assets(session_id = 9, vol_id = TRUE)) + expect_error(list_session_assets(session_id = 9, vol_id = list(a = 1, b = 2))) + expect_error(list_session_assets(session_id = 9, vol_id = -1)) + + expect_error(list_session_assets(session_id = 9, vol_id = 1, vb = "a")) + expect_error(list_session_assets(session_id = 9, vol_id = 1, vb = list(a = 1, b = 2))) + + expect_error(list_session_assets(session_id = 9, vol_id = 1, rq = "a")) + expect_error(list_session_assets(session_id = 9, vol_id = 1, rq = -1)) + expect_error(list_session_assets(session_id = 9, vol_id = 1, rq = c(2, 3))) + expect_error(list_session_assets(session_id = 9, vol_id = 1, rq = list(a = 1, b = 2))) }) diff --git a/tests/testthat/test-list_sponsors.R b/tests/testthat/test-list_sponsors.R deleted file mode 100644 index f431e7b3..00000000 --- a/tests/testthat/test-list_sponsors.R +++ /dev/null @@ -1,23 +0,0 @@ -# list_sponsors --------------------------------------------------------- -test_that("list_sponsors returns a data.frame or is NULL.", { - expect_true((is.null(list_sponsors()) || - ("data.frame" %in% class(list_sponsors())))) -}) - -test_that("list_sponsors rejects bad input parameters", { - expect_error(list_sponsors(party_id = "a")) - expect_error(list_sponsors(party_id = -1)) - expect_error(list_sponsors(party_id = TRUE)) - expect_error(list_sponsors(party_id = c(1,3))) - expect_error(list_sponsors(party_id = list(a=1, b=2))) - - expect_error(list_sponsors(vb = "a")) - expect_error(list_sponsors(vb = -1)) - expect_error(list_sponsors(vb = c(2,3))) - expect_error(list_sponsors(vb = list(a=1, b=2))) - - expect_error(list_sponsors(rq = "a")) - expect_error(list_sponsors(rq = -1)) - expect_error(list_sponsors(rq = c(2,3))) - expect_error(list_sponsors(rq = list(a=1, b=2))) -}) diff --git a/tests/testthat/test-list_user_affiliates.R b/tests/testthat/test-list_user_affiliates.R new file mode 100644 index 00000000..3ee1a455 --- /dev/null +++ b/tests/testthat/test-list_user_affiliates.R @@ -0,0 +1,27 @@ +test_that("list_user_affiliates returns affiliates for user 22582", { + login_test_account() + result <- list_user_affiliates(22582) + skip_if_null_response(result, "list_user_affiliates(22582)") + + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) + expect_true(all(c( + "affiliate_user", + "access_level", + "expiration_date" + ) %in% names(result))) + expect_true(is.list(result$affiliate_user)) +}) + +test_that("list_user_affiliates rejects invalid parameters", { + expect_error(list_user_affiliates(user_id = "a")) + expect_error(list_user_affiliates(user_id = -1)) + expect_error(list_user_affiliates(user_id = TRUE)) + expect_error(list_user_affiliates(user_id = c(1, 2))) + expect_error(list_user_affiliates(user_id = list(a = 1))) + + expect_error(list_user_affiliates(rq = 123)) + expect_error(list_user_affiliates(rq = list())) +}) + + diff --git a/tests/testthat/test-list_user_history.R b/tests/testthat/test-list_user_history.R new file mode 100644 index 00000000..eebe03bd --- /dev/null +++ b/tests/testthat/test-list_user_history.R @@ -0,0 +1,18 @@ +# list_user_history ----------------------------------------------------------- + +test_that("list_user_history returns tibble", { + login_test_account() + result <- list_user_history(user_id = 22582) + skip_if_null_response(result, "list_user_history(user_id = 22582)") + expect_s3_class(result, "tbl_df") + expect_true(all(c("history_id", "history_type", "history_timestamp") %in% names(result))) +}) + +test_that("list_user_history rejects bad input parameters", { + expect_error(list_user_history(user_id = "a")) + expect_error(list_user_history(user_id = c(1, 2))) + expect_error(list_user_history(user_id = -1)) + expect_error(list_user_history(vb = "yes")) +}) + + diff --git a/tests/testthat/test-list_user_sponsors.R b/tests/testthat/test-list_user_sponsors.R new file mode 100644 index 00000000..00881e1c --- /dev/null +++ b/tests/testthat/test-list_user_sponsors.R @@ -0,0 +1,26 @@ +test_that("list_user_sponsors returns sponsors for user 22582", { + login_test_account() + result <- list_user_sponsors(22582) + skip_if_null_response(result, "list_user_sponsors(22582)") + + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) + expect_true(all(c( + "user_id", + "sponsor_id", + "access_level" + ) %in% names(result))) +}) + +test_that("list_user_sponsors rejects invalid parameters", { + expect_error(list_user_sponsors(user_id = "a")) + expect_error(list_user_sponsors(user_id = -1)) + expect_error(list_user_sponsors(user_id = TRUE)) + expect_error(list_user_sponsors(user_id = c(1, 2))) + expect_error(list_user_sponsors(user_id = list(a = 1))) + + expect_error(list_user_sponsors(rq = 123)) + expect_error(list_user_sponsors(rq = list())) +}) + + diff --git a/tests/testthat/test-list_user_volumes.R b/tests/testthat/test-list_user_volumes.R new file mode 100644 index 00000000..15c5eb67 --- /dev/null +++ b/tests/testthat/test-list_user_volumes.R @@ -0,0 +1,22 @@ +test_that("list_user_volumes returns volumes for user 22582", { + login_test_account() + result <- list_user_volumes(22582) + skip_if_null_response(result, "list_user_volumes(22582)") + + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) + expect_true(all(c("vol_id", "vol_name", "user_id") %in% names(result))) +}) + +test_that("list_user_volumes rejects invalid parameters", { + expect_error(list_user_volumes(user_id = "a")) + expect_error(list_user_volumes(user_id = -1)) + expect_error(list_user_volumes(user_id = TRUE)) + expect_error(list_user_volumes(user_id = c(1, 2))) + expect_error(list_user_volumes(user_id = list(a = 1))) + + expect_error(list_user_volumes(rq = 123)) + expect_error(list_user_volumes(rq = list())) +}) + + diff --git a/tests/testthat/test-list_users.R b/tests/testthat/test-list_users.R new file mode 100644 index 00000000..e6c7f906 --- /dev/null +++ b/tests/testthat/test-list_users.R @@ -0,0 +1,21 @@ +# list_users ------------------------------------------------------------------ + +test_that("list_users returns tibble for search query", { + login_test_account() + result <- list_users(search = "gilmore") + skip_if_null_response(result, "list_users(search = 'gilmore')") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) + expect_true(all(c("user_id", "user_email") %in% names(result))) +}) + +test_that("list_users rejects bad input parameters", { + expect_error(list_users(search = 123)) + expect_error(list_users(include_suspended = "yes")) + expect_error(list_users(exclude_self = c(TRUE, FALSE))) + expect_error(list_users(is_authorized_investigator = 2)) + expect_error(list_users(has_api_access = list(TRUE))) + expect_error(list_users(vb = "yes")) +}) + + diff --git a/tests/testthat/test-list_volume_activity.R b/tests/testthat/test-list_volume_activity.R index 5a7b99af..78bb78b7 100644 --- a/tests/testthat/test-list_volume_activity.R +++ b/tests/testthat/test-list_volume_activity.R @@ -1,7 +1,9 @@ # list_volume_activity --------------------------------------------------------- test_that("list_volume_activity returns data.frame or is NULL", { - expect_true((is.null(list_volume_activity()) || - ("data.frame" %in% class(list_volume_activity())))) + login_test_account() + result <- list_volume_activity(vol_id = 1892) + skip_if_null_response(result, "list_volume_activity(vol_id = 1892)") + expect_s3_class(result, "tbl_df") }) test_that("list_volume_activity rejects bad input parameters", { diff --git a/tests/testthat/test-list_volume_assets.R b/tests/testthat/test-list_volume_assets.R index e12b9722..11b9f055 100644 --- a/tests/testthat/test-list_volume_assets.R +++ b/tests/testthat/test-list_volume_assets.R @@ -1,9 +1,17 @@ # list_volume_assets ----------------------------------------------- -test_that("list_volume_assets returns data.frame", { - expect_true((is.null(list_volume_assets()) || - ( - "data.frame" %in% class(list_volume_assets()) - ))) +test_that("list_volume_assets returns tibble or is NULL", { + login_test_account() + result <- list_volume_assets() + skip_if_null_response(result, "list_volume_assets()") + expect_s3_class(result, "tbl_df") +}) + +test_that("list_volume_assets returns tibble for accessible volume", { + login_test_account() + result <- list_volume_assets(vol_id = 2) + skip_if_null_response(result, "list_volume_assets(vol_id = 2)") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) }) test_that("list_volume_assets rejects bad input parameters", { @@ -26,6 +34,7 @@ test_that("list_volume_assets rejects bad input parameters", { test_that("list_volume_assets returns NULL for invalid/missing volume IDs", { + login_test_account() expect_true(is.null(list_volume_assets(vol_id = 3))) expect_true(is.null(list_volume_assets(vol_id = 6))) }) diff --git a/tests/testthat/test-list_volume_collaborators.R b/tests/testthat/test-list_volume_collaborators.R new file mode 100644 index 00000000..7a088f0b --- /dev/null +++ b/tests/testthat/test-list_volume_collaborators.R @@ -0,0 +1,19 @@ +# list_volume_collaborators --------------------------------------------------- + +test_that("list_volume_collaborators returns tibble", { + login_test_account() + result <- list_volume_collaborators(vol_id = 1) + skip_if_null_response(result, "list_volume_collaborators(vol_id = 1)") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) + expect_true(all(c("collaborator_id", "collaborator_user_id") %in% names(result))) +}) + +test_that("list_volume_collaborators rejects bad input parameters", { + expect_error(list_volume_collaborators(vol_id = "a")) + expect_error(list_volume_collaborators(vol_id = c(1, 2))) + expect_error(list_volume_collaborators(vol_id = -1)) + expect_error(list_volume_collaborators(vb = "yes")) +}) + + diff --git a/tests/testthat/test-list_volume_excerpts.R b/tests/testthat/test-list_volume_excerpts.R deleted file mode 100644 index d39eba4a..00000000 --- a/tests/testthat/test-list_volume_excerpts.R +++ /dev/null @@ -1,23 +0,0 @@ -# list_volume_excerpts --------------------------------------------------------- -test_that("list_volume_excerpts returns data.frame or is NULL", { - expect_true((is.null(list_volume_excerpts()) || - ("list" %in% class(list_volume_excerpts())))) -}) - -test_that("list_volume_excerpts rejects bad input parameters", { - expect_error(list_volume_excerpts(vol_id = "a")) - expect_error(list_volume_excerpts(vol_id = c(1,2))) - expect_error(list_volume_excerpts(vol_id = TRUE)) - expect_error(list_volume_excerpts(vol_id = list(a=1, b=2))) - expect_error(list_volume_excerpts(vol_id = -1)) - - expect_error(list_volume_excerpts(vb = -1)) - expect_error(list_volume_excerpts(vb = 3)) - expect_error(list_volume_excerpts(vb = "a")) - expect_error(list_volume_excerpts(vb = list(a=1, b=2))) - - expect_error(list_volume_excerpts(rq = "a")) - expect_error(list_volume_excerpts(rq = -1)) - expect_error(list_volume_excerpts(rq = c(2, 3))) - expect_error(list_volume_excerpts(rq = list(a = 1, b = 2))) -}) diff --git a/tests/testthat/test-list_volume_folders.R b/tests/testthat/test-list_volume_folders.R new file mode 100644 index 00000000..fa901759 --- /dev/null +++ b/tests/testthat/test-list_volume_folders.R @@ -0,0 +1,26 @@ +# list_volume_folders ---------------------------------------------------------- +test_that("list_volume_folders returns tibble for accessible volume", { + login_test_account() + result <- list_volume_folders(vol_id = 2) + skip_if_null_response(result, "list_volume_folders(vol_id = 2)") + expect_s3_class(result, "tbl_df") +}) + +test_that("list_volume_folders rejects bad input parameters", { + expect_error(list_volume_folders(vol_id = "a")) + expect_error(list_volume_folders(vol_id = c(1, 2))) + expect_error(list_volume_folders(vol_id = TRUE)) + expect_error(list_volume_folders(vol_id = list(a = 1, b = 2))) + expect_error(list_volume_folders(vol_id = -1)) + + expect_error(list_volume_folders(vb = -1)) + expect_error(list_volume_folders(vb = 3)) + expect_error(list_volume_folders(vb = "a")) + expect_error(list_volume_folders(vb = list(a = 1, b = 2))) + + expect_error(list_volume_folders(rq = "a")) + expect_error(list_volume_folders(rq = -1)) + expect_error(list_volume_folders(rq = c(2, 3))) + expect_error(list_volume_folders(rq = list(a = 1, b = 2))) +}) + diff --git a/tests/testthat/test-list_volume_funding.R b/tests/testthat/test-list_volume_funding.R index 52193c73..bac9d00d 100644 --- a/tests/testthat/test-list_volume_funding.R +++ b/tests/testthat/test-list_volume_funding.R @@ -1,7 +1,10 @@ # list_volume_funding --------------------------------------------------------- test_that("list_volume_funding returns data.frame or is NULL", { - expect_true((is.null(list_volume_funding()) || - ("data.frame" %in% class(list_volume_funding())))) + login_test_account() + result <- list_volume_funding(vol_id = 1) + skip_if_null_response(result, "list_volume_funding(vol_id = 1)") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) }) test_that("list_volume_funding rejects bad input parameters", { diff --git a/tests/testthat/test-list_volume_info.R b/tests/testthat/test-list_volume_info.R index 8b35272d..826ed5fa 100644 --- a/tests/testthat/test-list_volume_info.R +++ b/tests/testthat/test-list_volume_info.R @@ -1,10 +1,24 @@ # list_volume_info ------------------------------------------------------------ -test_that("list_volume_info returns data.frame given valid vol_id", { - expect_true("data.frame" %in% class(list_volume_info())) +login_test_account() +test_that("list_volume_info returns tibble for default volume", { + result <- list_volume_info() + skip_if_null_response(result, "list_volume_info()") + expect_s3_class(result, "tbl_df") + expect_equal(result$vol_id, 1) + expect_true(all(c("vol_owner_connection", "vol_owner_institution") %in% names(result))) + expect_true(is.list(result$vol_owner_connection)) + expect_true(is.list(result$vol_owner_institution)) }) -test_that("list_volume_info returns NULL given a non-shared vol_id", { - expect_true(is.null(list_volume_info(vol_id = 237))) +login_test_account() +test_that("list_volume_info returns tibble for another volume", { + result <- list_volume_info(vol_id = 2) + skip_if_null_response(result, "list_volume_info(vol_id = 2)") + expect_s3_class(result, "tbl_df") + expect_equal(result$vol_id, 2) + expect_true(all(c("vol_owner_connection", "vol_owner_institution") %in% names(result))) + expect_true(is.list(result$vol_owner_connection)) + expect_true(is.list(result$vol_owner_institution)) }) test_that("list_volume_info rejects bad input parameters", { diff --git a/tests/testthat/test-list_volume_links.R b/tests/testthat/test-list_volume_links.R index 660b1c69..7e015781 100644 --- a/tests/testthat/test-list_volume_links.R +++ b/tests/testthat/test-list_volume_links.R @@ -1,10 +1,14 @@ # list_volume_links --------------------------------------------------------- test_that("list_volume_links returns data.frame or is NULL", { - expect_true((is.null(list_volume_links())) || - ("data.frame" %in% class(list_volume_links()))) + login_test_account() + result <- list_volume_links(vol_id = 1) + skip_if_null_response(result, "list_volume_links(vol_id = 1)") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) }) test_that("list_volume_links rejects bad input parameters", { + login_test_account() expect_error(list_volume_links(vol_id = "a")) expect_error(list_volume_links(vol_id = c(1,2))) expect_error(list_volume_links(vol_id = TRUE)) diff --git a/tests/testthat/test-list_volume_owners.R b/tests/testthat/test-list_volume_owners.R deleted file mode 100644 index cc61ae7b..00000000 --- a/tests/testthat/test-list_volume_owners.R +++ /dev/null @@ -1,26 +0,0 @@ -test_that("list_volume_owners returns a list or is NULL.", { - expect_true((is.null(list_volume_owners()) || - ("data.frame" %in% class(list_volume_owners())))) -}) - -test_that("list_volume_owners returns NULL for volume 3", { - expect_true(is.null(list_volume_owners(vol_id = 3))) -}) - -test_that("list_volume_owners rejects bad input parameters", { - expect_error(list_volume_owners(vol_id = "a")) - expect_error(list_volume_owners(vol_id = c(1,2))) - expect_error(list_volume_owners(vol_id = TRUE)) - expect_error(list_volume_owners(vol_id = list(a=1, b=2))) - expect_error(list_volume_owners(vol_id = -1)) - - expect_error(list_volume_owners(vb = -1)) - expect_error(list_volume_owners(vb = 3)) - expect_error(list_volume_owners(vb = "a")) - expect_error(list_volume_owners(vb = list(a=1, b=2))) - - expect_error(list_volume_owners(rq = "a")) - expect_error(list_volume_owners(rq = -1)) - expect_error(list_volume_owners(rq = c(2,3))) - expect_error(list_volume_owners(rq = list(a=1, b=2))) -}) diff --git a/tests/testthat/test-list_volume_session_assets.R b/tests/testthat/test-list_volume_session_assets.R index 06bde015..7c67dc3e 100644 --- a/tests/testthat/test-list_volume_session_assets.R +++ b/tests/testthat/test-list_volume_session_assets.R @@ -1,9 +1,16 @@ # list_volume_session_assets -------------------------------------------------- -test_that("list_volume_session_assets returns data.frame or is NULL", { - expect_true(( - is.null(list_volume_session_assets()) || - ("data.frame" %in% class(list_volume_session_assets())) - )) +login_test_account() +test_that("list_volume_session_assets returns tibble or is NULL", { + result <- list_volume_session_assets() + skip_if_null_response(result, "list_volume_session_assets()") + expect_s3_class(result, "tbl_df") +}) + +test_that("list_volume_session_assets returns tibble for accessible session", { + result <- list_volume_session_assets(vol_id = 2, session_id = 11) + skip_if_null_response(result, "list_volume_session_assets(vol_id = 2, session_id = 11)") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) }) test_that("list_volume_session_assets rejects bad input parameters", { diff --git a/tests/testthat/test-list_volume_sessions.R b/tests/testthat/test-list_volume_sessions.R index a583ae36..d09a9879 100644 --- a/tests/testthat/test-list_volume_sessions.R +++ b/tests/testthat/test-list_volume_sessions.R @@ -1,10 +1,23 @@ # list_volume_sessions -------------------------------------------------------- -test_that("list_volume_sessions returns data.frame given valid vol_id", { - expect_true("data.frame" %in% class(list_volume_sessions())) +test_that("list_volume_sessions returns tibble given valid vol_id", { + login_test_account() + result <- list_volume_sessions() + skip_if_null_response(result, "list_volume_sessions()") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) }) -test_that("list_volume_sessions returns NULL given a non-shared vol_id", { - expect_true(is.null(list_volume_sessions(vol_id = 237))) +test_that("list_volume_sessions returns tibble for another volume", { + login_test_account() + result <- list_volume_sessions(vol_id = 2) + skip_if_null_response(result, "list_volume_sessions(vol_id = 2)") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) +}) + +test_that("list_volume_sessions returns NULL for unknown volume", { + login_test_account() + expect_null(list_volume_sessions(vol_id = 9999)) }) test_that("list_volume_sessions rejects bad input parameters", { diff --git a/tests/testthat/test-list_volume_tags.R b/tests/testthat/test-list_volume_tags.R index 27047539..b7c274ed 100644 --- a/tests/testthat/test-list_volume_tags.R +++ b/tests/testthat/test-list_volume_tags.R @@ -1,7 +1,11 @@ # list_volume_tags --------------------------------------------------------- -test_that("list_volume_tags returns data.frame or is NULL", { - expect_true((is.null(list_volume_tags()) || - ("data.frame" %in% class(list_volume_tags())))) +test_that("list_volume_tags returns tags for volume 1", { + login_test_account() + tags <- list_volume_tags(vol_id = 1) + skip_if_null_response(tags, "list_volume_tags(vol_id = 1)") + expect_true(is.list(tags)) + expect_gt(length(tags), 0) + expect_true(any(vapply(tags, function(x) any(grepl("icis", x, ignore.case = TRUE)), logical(1)))) }) test_that("list_volume_tags rejects bad input parameters", { @@ -23,5 +27,6 @@ test_that("list_volume_tags rejects bad input parameters", { }) test_that("list_volume_tags returns NULL for volume without tags", { + login_test_account() expect_true(is.null(list_volume_tags(vol_id = 3))) }) diff --git a/tests/testthat/test-list_volumes.R b/tests/testthat/test-list_volumes.R new file mode 100644 index 00000000..cf0e3e8d --- /dev/null +++ b/tests/testthat/test-list_volumes.R @@ -0,0 +1,18 @@ +# list_volumes ---------------------------------------------------------------- + +test_that("list_volumes returns tibble", { + login_test_account() + result <- list_volumes(search = "workshop") + skip_if_null_response(result, "list_volumes(search = 'workshop')") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) + expect_true(all(c("volume_id", "volume_title") %in% names(result))) +}) + +test_that("list_volumes rejects bad input parameters", { + expect_error(list_volumes(search = 123)) + expect_error(list_volumes(ordering = TRUE)) + expect_error(list_volumes(vb = "yes")) +}) + + diff --git a/tests/testthat/test-make_default_request.R b/tests/testthat/test-make_default_request.R index b418044b..aebe7829 100644 --- a/tests/testthat/test-make_default_request.R +++ b/tests/testthat/test-make_default_request.R @@ -1,20 +1,12 @@ # make_default_request --------------------------------------------------------- -test_that("make_default_request returns httr2_request", { +test_that("make_default_request returns httr2_request after login", { + login_test_account() expect_true("httr2_request" %in% class(make_default_request())) }) -test_that("make_default_request optionally attaches bearer token", { - clear_token_bundle() - set_token_bundle(access_token = "xyz", refresh_token = NULL) - req <- make_default_request(with_token = TRUE, refresh = FALSE, vb = FALSE) - headers <- req$headers - expect_equal(headers$Authorization, "Bearer xyz") - clear_token_bundle() -}) - -test_that("make_default_request errors when token missing", { - clear_token_bundle() - expect_error(make_default_request(with_token = TRUE, refresh = FALSE, vb = FALSE), - "No OAuth token available") +test_that("make_default_request can skip token", { + req <- make_default_request(with_token = FALSE) + expect_true("httr2_request" %in% class(req)) + expect_false("Authorization" %in% names(req$headers)) }) diff --git a/tests/testthat/test-make_login_client.R b/tests/testthat/test-make_login_client.R index 958ad82b..f18b3706 100644 --- a/tests/testthat/test-make_login_client.R +++ b/tests/testthat/test-make_login_client.R @@ -1,31 +1,31 @@ test_that("make_login_client rejects bad input parameters", { - # expect_error(make_login_client(email = -1)) - # expect_error(make_login_client(email = c("a", "b"))) - # expect_error(make_login_client(email = list("a", "b"))) - # expect_error(make_login_client(email = TRUE)) - # - # expect_error(make_login_client(password = -1)) - # expect_error(make_login_client(password = 3)) - # expect_error(make_login_client(password = list("a", "b"))) - # expect_error(make_login_client(password = TRUE)) - # - # expect_error(make_login_client(store = -1)) - # expect_error(make_login_client(store = 'a')) - # expect_error(make_login_client(store = list("a", "b"))) - # - # expect_error(make_login_client(overwrite = -1)) - # expect_error(make_login_client(overwrite = 'a')) - # expect_error(make_login_client(overwrite = list("a", "b"))) - + expect_error(make_login_client(email = -1, password = "pw")) + expect_error(make_login_client(email = c("a", "b"), password = "pw")) + expect_error(make_login_client(email = list("a", "b"), password = "pw")) + expect_error(make_login_client(email = TRUE, password = "pw")) + + expect_error(make_login_client(password = -1, email = "user@example.com")) + expect_error(make_login_client(password = 3, email = "user@example.com")) + expect_error(make_login_client(password = list("a", "b"), email = "user@example.com")) + expect_error(make_login_client(password = TRUE, email = "user@example.com")) + + expect_error(make_login_client(store = -1, email = "user@example.com", password = "pw")) + expect_error(make_login_client(store = "a", email = "user@example.com", password = "pw")) + expect_error(make_login_client(store = list("a", "b"), email = "user@example.com", password = "pw")) + + expect_error(make_login_client(overwrite = -1, email = "user@example.com", password = "pw")) + expect_error(make_login_client(overwrite = "a", email = "user@example.com", password = "pw")) + expect_error(make_login_client(overwrite = list("a", "b"), email = "user@example.com", password = "pw")) + expect_error(make_login_client(vb = -1)) expect_error(make_login_client(vb = 3)) expect_error(make_login_client(vb = "a")) - - # expect_error(make_login_client(SERVICE = -1)) - # expect_error(make_login_client(SERVICE = TRUE)) - # expect_error(make_login_client(SERVICE = list("a", "b"))) - # - # expect_error(make_login_client(rq = 3)) - # expect_error(make_login_client(rq = "a")) - # expect_error(make_login_client(rq = TRUE)) + + expect_error(make_login_client(SERVICE = -1, email = "user@example.com", password = "pw")) + expect_error(make_login_client(SERVICE = TRUE, email = "user@example.com", password = "pw")) + expect_error(make_login_client(SERVICE = list("a", "b"), email = "user@example.com", password = "pw")) + + expect_error(make_login_client(rq = 3, email = "user@example.com", password = "pw")) + expect_error(make_login_client(rq = "a", email = "user@example.com", password = "pw")) + expect_error(make_login_client(rq = TRUE, email = "user@example.com", password = "pw")) }) \ No newline at end of file diff --git a/tests/testthat/test-search_for_funder.R b/tests/testthat/test-search_for_funder.R index 8f7fbd80..f3d51d9c 100644 --- a/tests/testthat/test-search_for_funder.R +++ b/tests/testthat/test-search_for_funder.R @@ -1,9 +1,11 @@ # search_for_funder() --------------------------------------------------- -test_that("search_for_funder returns NULL or list", { - expect_true(( - is.null(search_for_funder()) || - "list" %in% class(search_for_funder()) - )) +login_test_account() +test_that("search_for_funder finds matching funder", { + result <- search_for_funder("National Science Foundation") + skip_if_null_response(result, "search_for_funder(\"National Science Foundation\")") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) + expect_true(any(grepl("National Science Foundation", result$funder_name, fixed = TRUE))) }) test_that("search_for_funder rejects bad input parameters", { diff --git a/tests/testthat/test-search_for_keywords.R b/tests/testthat/test-search_for_keywords.R deleted file mode 100644 index 95fed214..00000000 --- a/tests/testthat/test-search_for_keywords.R +++ /dev/null @@ -1,21 +0,0 @@ -# search_for_keywords() --------------------------------------------------- -test_that("search_for_keywords returns list", { - expect_true(class(search_for_keywords()) == "list") -}) - -test_that("search_for_keywords rejects bad input parameters", { - expect_error(search_for_keywords(search_string = -1)) - expect_error(search_for_keywords(search_string = 0)) - expect_error(search_for_keywords(search_string = list(a=1, b=2))) - expect_error(search_for_keywords(search_string = TRUE)) - - expect_error(search_for_keywords(vb = -1)) - expect_error(search_for_keywords(vb = 3)) - expect_error(search_for_keywords(vb = "a")) - expect_error(search_for_keywords(vb = list(a=1, b=2))) - - expect_error(search_for_keywords(rq = "a")) - expect_error(search_for_keywords(rq = -1)) - expect_error(search_for_keywords(rq = c(2,3))) - expect_error(search_for_keywords(rq = list(a=1, b=2))) -}) diff --git a/tests/testthat/test-search_for_tags.R b/tests/testthat/test-search_for_tags.R index 0691b906..af54cc01 100644 --- a/tests/testthat/test-search_for_tags.R +++ b/tests/testthat/test-search_for_tags.R @@ -1,6 +1,8 @@ # search_for_tags() --------------------------------------------------- -test_that("search_for_tags returns character", { - expect_true("character" %in% class(search_for_tags())) +test_that("search_for_tags returns tagged volumes", { + result <- search_for_tags("ICIS") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) }) test_that("search_for_tags rejects bad input parameters", { diff --git a/tests/testthat/test-search_institutions.R b/tests/testthat/test-search_institutions.R new file mode 100644 index 00000000..f6347f86 --- /dev/null +++ b/tests/testthat/test-search_institutions.R @@ -0,0 +1,17 @@ +# search_institutions --------------------------------------------------------- + +test_that("search_institutions returns tibble", { + login_test_account() + result <- search_institutions("state") + skip_if_null_response(result, "search_institutions('state')") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) + expect_true(all(c("institution_id", "score") %in% names(result))) +}) + +test_that("search_institutions rejects bad queries", { + expect_error(search_institutions(123)) + expect_error(search_institutions("term", vb = "yes")) +}) + + diff --git a/tests/testthat/test-search_users.R b/tests/testthat/test-search_users.R new file mode 100644 index 00000000..70813c60 --- /dev/null +++ b/tests/testthat/test-search_users.R @@ -0,0 +1,17 @@ +# search_users ---------------------------------------------------------------- + +test_that("search_users returns tibble", { + login_test_account() + result <- search_users("gilmore") + skip_if_null_response(result, "search_users('gilmore')") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) + expect_true(all(c("user_id", "score") %in% names(result))) +}) + +test_that("search_users rejects bad queries", { + expect_error(search_users(123)) + expect_error(search_users("term", vb = "yes")) +}) + + diff --git a/tests/testthat/test-search_volumes.R b/tests/testthat/test-search_volumes.R new file mode 100644 index 00000000..e59911f0 --- /dev/null +++ b/tests/testthat/test-search_volumes.R @@ -0,0 +1,17 @@ +# search_volumes -------------------------------------------------------------- + +test_that("search_volumes returns tibble", { + login_test_account() + result <- search_volumes("workshop") + skip_if_null_response(result, "search_volumes('workshop')") + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) + expect_true(all(c("volume_id", "score") %in% names(result))) +}) + +test_that("search_volumes rejects bad queries", { + expect_error(search_volumes(123)) + expect_error(search_volumes("term", vb = "yes")) +}) + + diff --git a/tests/testthat/test-token_helpers.R b/tests/testthat/test-token_helpers.R new file mode 100644 index 00000000..29c01d1d --- /dev/null +++ b/tests/testthat/test-token_helpers.R @@ -0,0 +1,29 @@ +test_that("ensure_valid_token requires an existing bundle", { + databraryr:::clear_token_bundle() + expect_error(databraryr:::ensure_valid_token(), "No OAuth token available") +}) + +test_that("ensure_valid_token returns bundle when still valid", { + databraryr:::clear_token_bundle() + databraryr:::set_token_bundle(access_token = "still-valid", expires_in = NULL) + + bundle <- databraryr:::ensure_valid_token(refresh = TRUE) + expect_equal(bundle$access_token, "still-valid") +}) + +test_that("ensure_valid_token errors when refresh not permitted", { + databraryr:::clear_token_bundle() + databraryr:::set_token_bundle(access_token = "expiring", refresh_token = "refresh", expires_in = -120) + + expect_error(databraryr:::ensure_valid_token(refresh = FALSE), "refresh disabled") + databraryr:::clear_token_bundle() +}) + +test_that("ensure_valid_token errors when refresh token missing", { + databraryr:::clear_token_bundle() + databraryr:::set_token_bundle(access_token = "expiring", refresh_token = NULL, expires_in = -120) + + expect_error(databraryr:::ensure_valid_token(), "no refresh token available") + databraryr:::clear_token_bundle() +}) + diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 5c77bf54..d0da8d1b 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -1,10 +1,27 @@ # get_file_duration --------------------------------------------------------- -test_that("get_file_duration returns an integer array", { - expect_true(class(get_file_duration()) == "integer") - expect_true(length(get_file_duration()) == 1) +test_that("get_file_duration returns duration metadata for a known asset", { + login_test_account() + result <- get_file_duration() + skip_if_null_response(result, "get_file_duration()") + expect_true(is.numeric(result) && length(result) == 1) + + asset_detail <- perform_api_get( + path = sprintf(API_SESSION_FILE_DETAIL, 2, 9, 2), + vb = FALSE + ) + expect_true("thumbnail_url" %in% names(asset_detail)) + expect_true(is.null(asset_detail$thumbnail_url) || nzchar(asset_detail$thumbnail_url)) }) test_that("get_file_duration rejects bad input parameters", { + expect_error(get_file_duration(vol_id = "a")) + expect_error(get_file_duration(vol_id = -1)) + expect_error(get_file_duration(vol_id = c(1, 3))) + + expect_error(get_file_duration(session_id = "a")) + expect_error(get_file_duration(session_id = -1)) + expect_error(get_file_duration(session_id = c(1, 3))) + expect_error(get_file_duration(asset_id = "a")) expect_error(get_file_duration(asset_id = -1)) expect_error(get_file_duration(asset_id = c(1, 3))) @@ -14,52 +31,28 @@ test_that("get_file_duration rejects bad input parameters", { expect_error(get_file_duration(vb = c(2, 3))) }) -# get_asset_segment_range ------------------------------------ -test_that("get_asset_segment_range returns an integer array", { - expect_true(class(get_asset_segment_range()) == "integer") - expect_true(length(get_asset_segment_range()) == 2) -}) - -test_that("get_asset_segment_range rejects bad input parameters", { - expect_error(get_asset_segment_range(vol_id = "a")) - expect_error(get_asset_segment_range(vol_id = -1)) - expect_error(get_asset_segment_range(vol_id = c(1, 3))) - - expect_error(get_asset_segment_range(session_id = "a")) - expect_error(get_asset_segment_range(session_id = -1)) - expect_error(get_asset_segment_range(session_id = c(1, 3))) - - expect_error(get_asset_segment_range(asset_id = "a")) - expect_error(get_asset_segment_range(asset_id = -1)) - expect_error(get_asset_segment_range(asset_id = c(1, 3))) - - expect_error(get_asset_segment_range(vb = "a")) - expect_error(get_asset_segment_range(vb = -1)) - expect_error(get_asset_segment_range(vb = c(2, 3))) -}) - # get_permission_levels ------------------------------------------------------- test_that("get_permission_levels returns a character array", { - expect_true(class(get_permission_levels()) == "character") - expect_true(length(get_permission_levels()) == 6) + levels <- get_permission_levels() + expect_true(is.character(levels)) + expect_true(length(levels) > 0) }) -test_that("get_permission_levels rejects bad input parameters", { - expect_error(get_permission_levels(vb = "a")) - expect_error(get_permission_levels(vb = -1)) - expect_error(get_permission_levels(vb = c(2, 3))) +test_that("get_permission_levels handles vb flag", { + expect_silent(get_permission_levels(vb = TRUE)) + expect_silent(get_permission_levels(vb = FALSE)) }) # get_release_levels --------------------------------------------------------- test_that("get_release_levels returns a character array", { - expect_true(class(get_release_levels()) == "character") - expect_true(length(get_release_levels()) == 4) + levels <- get_release_levels() + expect_true(is.character(levels)) + expect_true(length(levels) == 4) }) -test_that("get_release_levels rejects bad input parameters", { - expect_error(get_release_levels(vb = "a")) - expect_error(get_release_levels(vb = -1)) - expect_error(get_release_levels(vb = c(2, 3))) +test_that("get_release_levels handles vb flag", { + expect_silent(get_release_levels(vb = TRUE)) + expect_silent(get_release_levels(vb = FALSE)) }) # get_supported_file_types ---------------------------------------------------- @@ -86,30 +79,6 @@ test_that("HHMMSSmmm_to_ms rejects bad input parameters", { expect_error(HHMMSSmmm_to_ms(HHMMSSmmm = TRUE)) }) -# is_institution --------------------------------------------------- -test_that("is_institution returns logical", { - expect_true(class(is_institution()) == "logical") -}) - -test_that("is_institution rejects bad input parameters", { - expect_error(is_institution(party_id = -1)) - expect_error(is_institution(party_id = "a")) - expect_error(is_institution(party_id = list(a = 1, b = 2))) - expect_error(is_institution(party_id = TRUE)) -}) - -# is_person --------------------------------------------------- -test_that("is_person returns logical", { - expect_true(class(is_person()) == "logical") -}) - -test_that("is_person rejects bad input parameters", { - expect_error(is_person(party_id = -1)) - expect_error(is_person(party_id = "a")) - expect_error(is_person(party_id = list(a = 1, b = 2))) - expect_error(is_person(party_id = TRUE)) -}) - # make_fn_portable --------------------------------------------------- test_that("make_fn_portable returns string", { expect_true("character" %in% class(make_fn_portable("}*&!@#$%^+.pdf"))) diff --git a/tests/testthat/test-whoami.R b/tests/testthat/test-whoami.R index 21053784..173dde50 100644 --- a/tests/testthat/test-whoami.R +++ b/tests/testthat/test-whoami.R @@ -5,25 +5,14 @@ test_that("whoami returns NULL when unauthenticated", { test_that("whoami fetches user info", { clear_token_bundle() - set_token_bundle(access_token = "abc", refresh_token = NULL) + login_test_account() + on.exit(clear_token_bundle(), add = TRUE) - local_mocked_bindings( - req_perform = function(...) { - httr2::response( - method = "GET", - url = OAUTH_TEST_URL, - status_code = 200, - headers = list("Content-Type" = "application/json"), - body = charToRaw('{"auth_method":"password","user":{"id":1}}') - ) - }, - .package = "httr2" - ) + result <- whoami(refresh = TRUE, vb = FALSE) + skip_if_null_response(result, "whoami") - result <- whoami(refresh = FALSE, vb = FALSE) - - expect_equal(result$auth_method, "password") - expect_equal(result$user$id, 1) - clear_token_bundle() + expect_true(nzchar(result$message)) + expect_match(result$path, "oauth2/test") + expect_equal(result$authMethod, "OAuth2") }) diff --git a/vignettes/accessing-data.Rmd b/vignettes/accessing-data.Rmd index 0506ab6f..b5190ebf 100644 --- a/vignettes/accessing-data.Rmd +++ b/vignettes/accessing-data.Rmd @@ -132,44 +132,42 @@ vol1_assets |> Imagine you are interested in knowing more about this volume, the people who created it, or the agencies that funded it. -The `list_volume_owners()` function returns a data frame with information about the people who created and "own" this particular dataset. -The function has a parameter `this_vol_id` which is an integer, unique across Databrary, that refers to the specific dataset. -The `list_volume_owners()` function uses volume 1 as the default. +The `list_volume_collaborators()` function returns a data frame with information about the people who have been granted access to collaborate on this dataset. +The function has a parameter `vol_id` which is an integer, unique across Databrary, that refers to the specific dataset. +The `list_volume_collaborators()` function uses volume 1 as the default. ```{r} -databraryr::list_volume_owners() +databraryr::list_volume_collaborators() ``` The command (and many like it) can be "vectorized" using the `purrr` package. This let's us generate a tibble with the owners of the first fifteen volumes. ```{r} -purrr::map(1:15, databraryr::list_volume_owners) |> +purrr::map(1:15, databraryr::list_volume_collaborators) |> purrr::list_rbind() ``` -As of 0.6.0, the `get_volume_by_id()` returns a list of all data about a volume that is accessible to a particular user. +As of 0.6.0, the `get_volume_by_id()` function returns a tibble summarising all data about a volume that is accessible to a particular user. The default is volume 1. ```{r} vol1_list <- databraryr::get_volume_by_id() -names(vol1_list) +vol1_list ``` Let's create our own tibble/data frame with a subset of these variables. ```{r} -vol1_df <- tibble::tibble(id = vol1_list$id, - name = vol1_list$name, - doi = vol1_list$creation, - permission = vol1_list$permission) +vol1_df <- vol1_list |> + dplyr::select(id, title, sharing_level, access_level) vol1_df ``` -The `permission` variable indicates whether a volume is visible by you, and if so with what privileges. +The `access_level` variable indicates whether a volume is visible to you, and if so with what privileges. So, if you are not logged-in to Databrary, only data that are visible to the public will be returned. -Assuming you are *not* logged-in, the above commands will show volumes with `permission` equal to 1. -The `permission` field derives from a set of constants the system uses. +Assuming you are *not* logged-in, the above commands will show volumes with `access_level` equal to 1. +The `access_level` field derives from a set of constants the system uses. ```{r} db_constants <- databraryr::assign_constants() @@ -180,7 +178,7 @@ The `permission` array is indexed beginning with 0. So the 1th (1st) value is "`r db_constants$permission[2]`". So, the `1` means that the volumes shown above are all visible to the public, and to you. -Volumes that you have not shared and are not visible to the public, will have `permission` equal to 5, or "`r db_constants$permission[6]`". +Volumes that you have not shared and are not visible to the public, will have `access_level` equal to 5, or "`r db_constants$permission[6]`". We can't demonstrate this to you because we don't have privileges on the same unshared volume, but you can try it on a volume you've created but not yet shared. Other functions with the form `list_volume_*()` provide information about Databrary volumes. @@ -197,7 +195,7 @@ The `list_volume_links()` command returns information about any external (web) l databraryr::list_volume_links() ``` -There's much more to learn about accessing Databrary information using `databraryr`, but this should get you started. +There's much more to learn about accessing Databrary information using `databraryr`, but this should get you started. Explore `list_volumes()` to enumerate accessible datasets or `search_volumes()` to find projects matching a keyword. ## Downloading multiple files diff --git a/vignettes/databrary.Rmd b/vignettes/databrary.Rmd index 8fedbbc6..72a077f8 100644 --- a/vignettes/databrary.Rmd +++ b/vignettes/databrary.Rmd @@ -59,34 +59,31 @@ library(databraryr) Then, try this command to pull data about one of Databrary's founders: -```{r get_party_by_id} -# The default parameter settings return a very detailed set of information about -# a party that we do not need for this example. -party_6 <- databraryr::get_party_by_id(parents_children_access = FALSE) +```{r get_user_by_id} +# Retrieve public metadata about one of Databrary's founders. +user_6 <- databraryr::get_user_by_id(user_id = 6) -party_6 |> - as.data.frame() +tibble::as_tibble(user_6) ``` -Note that this command returns a data frame with columns that include the first name (`prename`), last name (`sortname`), affiliation, lab or personal website, and ORCID ID if available. +Note that this command returns a tibble with columns that include the first name (`prename`), last name (`sortname`), affiliation, and ORCID ID if available. -Databrary assigns a unique integer for each person and institution on the system called a 'party id'. +Databrary assigns a unique integer for each registered user on the system. We can create a simple helper function to collect information about a larger group of people. ```{r list-people-5-7} # Helper function -get_party_as_df <- function(party_id) { - this_party <- databraryr::get_party_by_id(party_id, - parents_children_access = FALSE) - if (!is.null(this_party)) { - as.data.frame(this_party) +get_user_as_df <- function(user_id) { + this_user <- databraryr::get_user_by_id(user_id = user_id) + if (!is.null(this_user)) { + tibble::as_tibble(this_user) } else { NULL } } -# Party's 5, 6, and 7 are Databrary's founders -purrr::map(5:7, get_party_as_df, .progress = TRUE) |> +# Users 5, 6, and 7 are Databrary's founders +purrr::map(5:7, get_user_as_df, .progress = TRUE) |> purrr::list_rbind() ``` From 1f6cf4d8b888868e544319d1058a8f235271e685 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Pawe=C5=82=20Armatys?= Date: Wed, 12 Nov 2025 11:35:45 +0100 Subject: [PATCH 03/27] Added and adjsuted functions for downloading folder/session assets, CSVs and ZIPs. --- NAMESPACE | 4 + R/CONSTANTS.R | 2 + R/download_folder_asset.R | 127 ++++++++ R/download_folder_assets_fr_df.R | 114 ++++++++ R/download_folder_zip.R | 54 ++++ R/download_session_asset.R | 220 ++++++-------- R/download_session_assets_fr_df.R | 111 ++++--- R/download_session_csv.R | 115 +++----- R/download_session_zip.R | 116 ++------ R/download_single_folder_asset_fr_df.R | 150 ++++++++++ R/download_single_session_asset_fr_df.R | 272 ++++++------------ R/download_utils.R | 101 +++++++ R/download_video.R | 134 +++------ R/download_volume_zip.R | 107 ++----- R/list_folder_assets.R | 1 + R/list_session_assets.R | 1 + man/download_folder_asset.Rd | 57 ++++ man/download_folder_assets_fr_df.Rd | 58 ++++ man/download_folder_zip.Rd | 41 +++ man/download_session_asset.Rd | 43 +-- man/download_session_assets_fr_df.Rd | 44 ++- man/download_session_csv.Rd | 38 ++- man/download_session_zip.Rd | 25 +- man/download_single_folder_asset_fr_df.Rd | 47 +++ man/download_single_session_asset_fr_df.Rd | 52 +--- man/download_video.Rd | 33 ++- man/download_volume_zip.Rd | 29 +- tests/testthat/test-download_folder_asset.R | 70 +++++ .../test-download_folder_assets_fr_df.R | 65 +++++ tests/testthat/test-download_folder_zip.R | 41 +++ tests/testthat/test-download_session_asset.R | 34 ++- .../test-download_session_assets_fr_df.R | 84 +++--- tests/testthat/test-download_session_csv.R | 57 +++- tests/testthat/test-download_session_zip.R | 41 +-- .../test-download_single_folder_asset_fr_df.R | 79 +++++ ...test-download_single_session_asset_fr_df.R | 89 +++--- tests/testthat/test-download_video.R | 44 +-- tests/testthat/test-download_volume_zip.R | 34 ++- 38 files changed, 1703 insertions(+), 1031 deletions(-) create mode 100644 R/download_folder_asset.R create mode 100644 R/download_folder_assets_fr_df.R create mode 100644 R/download_folder_zip.R create mode 100644 R/download_single_folder_asset_fr_df.R create mode 100644 R/download_utils.R create mode 100644 man/download_folder_asset.Rd create mode 100644 man/download_folder_assets_fr_df.Rd create mode 100644 man/download_folder_zip.Rd create mode 100644 man/download_single_folder_asset_fr_df.Rd create mode 100644 tests/testthat/test-download_folder_asset.R create mode 100644 tests/testthat/test-download_folder_assets_fr_df.R create mode 100644 tests/testthat/test-download_folder_zip.R create mode 100644 tests/testthat/test-download_single_folder_asset_fr_df.R diff --git a/NAMESPACE b/NAMESPACE index 613ec1a0..765a14b6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -4,10 +4,14 @@ export("%>%") export(HHMMSSmmm_to_ms) export(assign_constants) export(check_ssl_certs) +export(download_folder_asset) +export(download_folder_assets_fr_df) +export(download_folder_zip) export(download_session_asset) export(download_session_assets_fr_df) export(download_session_csv) export(download_session_zip) +export(download_single_folder_asset_fr_df) export(download_single_session_asset_fr_df) export(download_video) export(download_volume_zip) diff --git a/R/CONSTANTS.R b/R/CONSTANTS.R index 000da2ed..f6d676be 100644 --- a/R/CONSTANTS.R +++ b/R/CONSTANTS.R @@ -32,6 +32,8 @@ API_SESSION_DOWNLOAD_LINK <- "/volumes/%s/sessions/%s/download-link/" API_SESSION_CSV_DOWNLOAD_LINK <- "/volumes/%s/sessions/%s/csv-download-link/" API_FOLDER_DETAIL <- "/volumes/%s/folders/%s/" API_FOLDER_FILES <- "/volumes/%s/folders/%s/files/" +API_FOLDER_DOWNLOAD_LINK <- "/volumes/%s/folders/%s/download-link/" +API_FOLDER_FILE_DOWNLOAD_LINK <- "/volumes/%s/folders/%s/files/%s/download-link/" API_VOLUME_DOWNLOAD_LINK <- "/volumes/%s/download-link/" API_VOLUME_CSV_DOWNLOAD_LINK <- "/volumes/%s/csv-download-link/" API_SEARCH_VOLUMES <- "/search/volumes/" diff --git a/R/download_folder_asset.R b/R/download_folder_asset.R new file mode 100644 index 00000000..9ad295d2 --- /dev/null +++ b/R/download_folder_asset.R @@ -0,0 +1,127 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Download a Folder Asset via Signed Link. +#' +#' @description +#' Databrary serves folder-scoped assets through signed URLs. This helper +#' requests the signed link for a folder asset and streams the file to the +#' specified directory. +#' +#' @param vol_id Integer. Volume identifier containing the folder. Default is 1. +#' @param folder_id Integer. Folder identifier within the volume. Default is 1. +#' @param asset_id Integer. Asset identifier within the folder. Default is 1. +#' @param file_name Optional character string. File name to use when saving the +#' asset. Defaults to the API-provided file name. +#' @param target_dir Character string. Directory where the file will be saved. +#' Default is `tempdir()`. +#' @param rq An `httr2` request object. Default is `NULL`, in which case a +#' default authenticated request is generated. +#' @param timeout_secs Numeric. Timeout (seconds) applied to the download +#' request. Default is `REQUEST_TIMEOUT`. +#' +#' @returns The path to the downloaded file (character string) or `NULL` if the +#' download fails. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' download_folder_asset() # Default public asset in folder 1 of volume 1 +#' download_folder_asset(vol_id = 1, folder_id = 2, asset_id = 3, +#' file_name = "example.mp4") +#' } +#' } +#' +#' @export +download_folder_asset <- function(vol_id = 1, + folder_id = 1, + asset_id = 1, + file_name = NULL, + target_dir = tempdir(), + timeout_secs = REQUEST_TIMEOUT, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(length(vol_id) == 1) + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(vol_id >= 1) + + assertthat::assert_that(length(folder_id) == 1) + assertthat::assert_that(is.numeric(folder_id)) + assertthat::assert_that(folder_id >= 1) + + assertthat::assert_that(length(asset_id) == 1) + assertthat::assert_that(is.numeric(asset_id)) + assertthat::assert_that(asset_id >= 1) + + if (!is.null(file_name)) { + assertthat::assert_that(length(file_name) == 1) + assertthat::assert_that(is.character(file_name)) + } + + assertthat::assert_that(length(target_dir) == 1) + assertthat::assert_that(is.character(target_dir)) + assertthat::assert_that(dir.exists(target_dir)) + + assertthat::is.number(timeout_secs) + assertthat::assert_that(length(timeout_secs) == 1) + assertthat::assert_that(timeout_secs > 0) + + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) + + path <- sprintf(API_FOLDER_FILE_DOWNLOAD_LINK, vol_id, folder_id, asset_id) + link <- request_signed_download_link(path = path, rq = rq, vb = vb) + + if (is.null(link)) { + return(NULL) + } + + resolved_name <- if (!is.null(file_name)) { + file_name + } else if (!is.null(link$file_name)) { + link$file_name + } else { + paste0( + folder_id, + "-", + asset_id, + "-", + format(Sys.time(), "%F-%H%M-%S"), + ".bin" + ) + } + + dest_path <- file.path(target_dir, resolved_name) + + if (file.exists(dest_path)) { + dest_path <- file.path( + target_dir, + paste0( + tools::file_path_sans_ext(resolved_name), + "-", + format(Sys.time(), "%F-%H%M-%S"), + ifelse( + nzchar(tools::file_ext(resolved_name)), + paste0(".", tools::file_ext(resolved_name)), + "" + ) + ) + ) + } + + download_signed_file( + download_url = link$download_url, + dest_path = dest_path, + timeout_secs = timeout_secs, + vb = vb + ) +} + + + diff --git a/R/download_folder_assets_fr_df.R b/R/download_folder_assets_fr_df.R new file mode 100644 index 00000000..ae1ef3de --- /dev/null +++ b/R/download_folder_assets_fr_df.R @@ -0,0 +1,114 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Download Multiple Assets From a Folder Data Frame. +#' +#' @description +#' Iterates over a data frame of folder assets, requesting signed download links +#' for each asset and saving them to disk. Designed to work with +#' `list_folder_assets()` output. +#' +#' @param folder_df Data frame describing assets. Must include `vol_id`, +#' `folder_id`, `asset_id`, and `asset_name` columns. +#' @param target_dir Character string. Base directory for downloads. Defaults to +#' `tempdir()`. +#' @param add_folder_subdir Logical. When `TRUE`, creates a subdirectory per +#' folder inside `target_dir`. +#' @param overwrite Logical. When `FALSE`, the function aborts if the target +#' directory already exists. +#' @param make_portable_fn Logical. When `TRUE`, filenames are sanitized via +#' `make_fn_portable()`. +#' @param timeout_secs Numeric. Timeout applied to each download request. +#' @param rq An optional `httr2` request object reused when requesting signed +#' links. +#' +#' @returns Character vector of downloaded file paths or `NULL` if the request +#' fails before any downloads start. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' assets <- list_folder_assets(folder_id = 1, vol_id = 1) +#' download_folder_assets_fr_df(assets, vb = TRUE) +#' } +#' } +#' +#' @export +download_folder_assets_fr_df <- + function(folder_df = list_folder_assets(vol_id = 1), + target_dir = tempdir(), + add_folder_subdir = TRUE, + overwrite = TRUE, + make_portable_fn = FALSE, + timeout_secs = REQUEST_TIMEOUT_VERY_LONG, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(is.data.frame(folder_df)) + required_cols <- c("vol_id", "folder_id", "asset_id", "asset_name") + missing_cols <- setdiff(required_cols, names(folder_df)) + if (length(missing_cols) > 0) { + stop( + "folder_df is missing required columns: ", + paste(missing_cols, collapse = ", "), + call. = FALSE + ) + } + + assertthat::assert_that(length(target_dir) == 1) + assertthat::assert_that(is.character(target_dir)) + if (dir.exists(target_dir)) { + if (!overwrite) { + if (vb) { + message("`overwrite` is FALSE. Cannot continue.") + } + return(NULL) + } + } else { + dir.create(target_dir, recursive = TRUE, showWarnings = FALSE) + } + assertthat::is.writeable(target_dir) + + assertthat::assert_that(length(add_folder_subdir) == 1) + assertthat::assert_that(is.logical(add_folder_subdir)) + + assertthat::assert_that(length(overwrite) == 1) + assertthat::assert_that(is.logical(overwrite)) + + assertthat::assert_that(length(make_portable_fn) == 1) + assertthat::assert_that(is.logical(make_portable_fn)) + + assertthat::is.number(timeout_secs) + assertthat::assert_that(length(timeout_secs) == 1) + assertthat::assert_that(timeout_secs > 0) + + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) + + if (vb) { + message("Downloading n=", nrow(folder_df), " files to ", target_dir) + } + + purrr::map( + seq_len(nrow(folder_df)), + download_single_folder_asset_fr_df, + folder_df = folder_df, + target_dir = target_dir, + add_folder_subdir = add_folder_subdir, + overwrite = overwrite, + make_portable_fn = make_portable_fn, + timeout_secs = timeout_secs, + vb = vb, + rq = rq, + .progress = vb + ) |> + purrr::list_c() + } + + + diff --git a/R/download_folder_zip.R b/R/download_folder_zip.R new file mode 100644 index 00000000..4323306b --- /dev/null +++ b/R/download_folder_zip.R @@ -0,0 +1,54 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Request a Signed ZIP Download for a Folder. +#' +#' @description +#' Folder-level ZIP archives are prepared asynchronously by the Django API. +#' Calling `download_folder_zip()` queues the job and returns a processing task +#' descriptor. When the archive is ready, Databrary emails a signed download +#' link to the authenticated user. +#' +#' @param vol_id Volume identifier for the folder. +#' @param folder_id Folder identifier scoped within the specified volume. +#' @param rq An `httr2` request object. Default is `NULL`, in which case a +#' default authenticated request is generated. +#' +#' @returns A list describing the processing task (`status`, `message`, +#' `task_id`) or `NULL` when the request fails. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' download_folder_zip(vol_id = 1, folder_id = 1) +#' } +#' } +#' +#' @export +download_folder_zip <- function(vol_id = 1, + folder_id = 1, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(length(vol_id) == 1) + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(vol_id >= 1) + + assertthat::assert_that(length(folder_id) == 1) + assertthat::assert_that(is.numeric(folder_id)) + assertthat::assert_that(folder_id >= 1) + + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) + + path <- sprintf(API_FOLDER_DOWNLOAD_LINK, vol_id, folder_id) + request_processing_task(path = path, rq = rq, vb = vb) +} + + + diff --git a/R/download_session_asset.R b/R/download_session_asset.R index 87000398..89217ea6 100644 --- a/R/download_session_asset.R +++ b/R/download_session_asset.R @@ -3,175 +3,121 @@ #' NULL -#' Download Asset From Databrary. +#' Download an Asset via Signed Link. #' -#' @description Databrary stores file types (assets) of many types. This -#' function downloads an asset based on its system-unique integer identifer -#' (asset_id) and system-unique session (slot) identifier (session_id). +#' @description +#' Databrary serves assets through short-lived, signed URLs. This helper +#' requests the signed link for a session asset and streams the file to the +#' requested directory. #' -#' @param asset_id An integer. Asset id for target file. Default is 1. -#' @param session_id An integer. Slot/session number where target file is -#' stored. Default is 9807. -#' @param file_name A character string. Name for downloaded file. Default is NULL. +#' @param vol_id Integer. Volume identifier. Default is 1. +#' @param session_id Integer. Session identifier. Default is 9807. +#' @param asset_id Integer. Asset identifier within the session. Default is 1. +#' @param file_name Optional character string. Target file name. Defaults to the +#' API-provided file name. +#' @param target_dir Character string. Directory where the file will be saved. +#' Default is `tempdir()`. +#' @param rq An `httr2` request object. Default is `NULL`, in which case a +#' default authenticated request is generated. +#' @param timeout_secs Numeric. Timeout (seconds) applied to the download +#' request. Default is `REQUEST_TIMEOUT`. #' -#' @param target_dir A character string. Directory to save the downloaded file. -#' Default is a temporary directory given by a call to `tempdir()`. -#' @param rq A list in the form of an `httr2` request object. Default is NULL. -#' @param timeout_secs An integer constant. The default value, defined in -#' CONSTANTS.R is REQUEST_TIMEOUT. This value determines the default timeout -#' value for the httr2 request object. When downloading large files, it can be -#' useful to set this value to a large number. -#' -#' @returns Full file name to the asset or NULL. +#' @returns The path to the downloaded file (character string) or `NULL` if the +#' download fails. #' #' @inheritParams options_params #' #' @examples #' \donttest{ #' \dontrun{ -#' download_session_asset() # Download's 'numbers' file from volume 1. -#' download_session_asset(asset_id = 11643, session_id = 9825, file_name = "rdk.mp4") -#' # Downloads a display with a random dot kinematogram (RDK). +#' download_session_asset() # Default public asset in volume 1 +#' download_session_asset(vol_id = 1, session_id = 9825, asset_id = 11643, +#' file_name = "rdk.mp4") #' } #' } #' @export -download_session_asset <- function(asset_id = 1, +download_session_asset <- function(vol_id = 1, session_id = 9807, + asset_id = 1, file_name = NULL, - #target_dir = paste0("./", session_id), target_dir = tempdir(), timeout_secs = REQUEST_TIMEOUT, vb = options::opt("vb"), rq = NULL) { - # Check parameters + assertthat::assert_that(length(vol_id) == 1) + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(vol_id >= 1) + + assertthat::assert_that(length(session_id) == 1) + assertthat::assert_that(is.numeric(session_id)) + assertthat::assert_that(session_id >= 1) + assertthat::assert_that(length(asset_id) == 1) assertthat::assert_that(is.numeric(asset_id)) assertthat::assert_that(asset_id >= 1) - - assertthat::assert_that(is.numeric(session_id)) - assertthat::assert_that(length(session_id) == 1) - assertthat::assert_that(session_id >= 1) - - assertthat::assert_that(is.character(target_dir)) + + if (!is.null(file_name)) { + assertthat::assert_that(length(file_name) == 1) + assertthat::assert_that(is.character(file_name)) + } + assertthat::assert_that(length(target_dir) == 1) + assertthat::assert_that(is.character(target_dir)) assertthat::assert_that(dir.exists(target_dir)) - + assertthat::is.number(timeout_secs) assertthat::assert_that(length(timeout_secs) == 1) assertthat::assert_that(timeout_secs > 0) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() + + assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) + + path <- sprintf(API_FILES_DOWNLOAD_LINK, vol_id, session_id, asset_id) + link <- request_signed_download_link(path = path, rq = rq, vb = vb) + + if (is.null(link)) { + return(NULL) } - - this_rq <- rq %>% - httr2::req_url(sprintf(DOWNLOAD_FILE, session_id, asset_id)) %>% - httr2::req_progress() - - if (vb) - message( - "Attempting to download file with asset_id ", - asset_id, - " from session_id ", + + resolved_name <- if (!is.null(file_name)) { + file_name + } else if (!is.null(link$file_name)) { + link$file_name + } else { + paste0( session_id, - "." + "-", + asset_id, + "-", + format(Sys.time(), "%F-%H%M-%S"), + ".bin" ) - - resp <- tryCatch( - httr2::req_perform(this_rq), - httr2_error = function(cnd) { - if (vb) - message( - "Error downloading file with asset_id ", - asset_id, - " from session_id ", - session_id, - "." - ) - NULL - } - - ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } - - # Gather asset format info - format_mimetype <- NULL - format_extension <- NULL - this_file_extension <- list_asset_formats(vb = vb) %>% - dplyr::filter(httr2::resp_content_type(resp) == format_mimetype) %>% - dplyr::select(format_extension) %>% - as.character() - - # Check file name or generate - if (is.null(this_file_extension)) { - if (vb) - message("No matching file extension for ", - httr2::resp_content_type(resp)) - return(NULL) - } - - if (is.null(file_name)) { - if (vb) - message("Missing file name, creating temporary file name.") - file_name <- tempfile(paste0(session_id, "_", asset_id, "_"), - fileext = paste0(".", this_file_extension)) } - assertthat::is.string(file_name) - - if (file.exists(file_name)) { - if (vb) - message("File exists. Generating new unique name.\n") - file_name <- file.path(dirname(file_name), - paste0( - session_id, - "-", - asset_id, - "-", - format(Sys.time(), "%F-%H%M-%S"), - paste0(".", this_file_extension) - )) - } - - if (!(this_file_extension == xfun::file_ext(file_name))) { - if (vb) - message("File name ", - file_name, - " doesn't match extension ", - this_file_extension) - return(NULL) + + dest_path <- file.path(target_dir, resolved_name) + + if (file.exists(dest_path)) { + dest_path <- file.path( + target_dir, + paste0( + tools::file_path_sans_ext(resolved_name), + "-", + format(Sys.time(), "%F-%H%M-%S"), + ifelse( + nzchar(tools::file_ext(resolved_name)), + paste0(".", tools::file_ext(resolved_name)), + "" + ) + ) + ) } - - write_file <- tryCatch( - error = function(cnd) { - if (vb) - message("Failure writing file ", file_name) - NULL - }, - { - file_con <- file(file_name, "wb") - writeBin(resp$body, file_con) - close(file_con) - } + + download_signed_file( + download_url = link$download_url, + dest_path = dest_path, + timeout_secs = timeout_secs, + vb = vb ) - - if (!is.null(write_file)) { - file_name - } else { - write_file - } } diff --git a/R/download_session_assets_fr_df.R b/R/download_session_assets_fr_df.R index 4e2c1bdf..b34b5fcb 100644 --- a/R/download_session_assets_fr_df.R +++ b/R/download_session_assets_fr_df.R @@ -3,38 +3,37 @@ #' NULL -#' Download Asset From A Databrary Session. +#' Download Multiple Assets From a Session Data Frame. #' -#' @description Databrary stores file types (assets) of many types. This -#' function downloads assets in a data frame generated by list_session_assets(). +#' @description +#' Iterates over a data frame of session assets, requesting signed download +#' links for each asset and saving them to disk. Designed to work with +#' `list_session_assets()` or `list_volume_session_assets()` output. #' -#' @param session_df A data frame as generated by list_session_assets_2(). -#' @param target_dir A character string. Directory to save the downloaded file. -#' Default is directory named after the session_id. -#' @param add_session_subdir A logical value. Add add the session name to the -#' file path so that files are in a subdirectory specific to the session. Default -#' is TRUE. -#' @param overwrite A logical value. Overwrite an existing file. Default is TRUE. -#' @param make_portable_fn A logical value. Replace characters in file names -#' that are not broadly portable across file systems. Default is FALSE. -#' @param timeout_secs An integer. The seconds an httr2 request will run before -#' timing out. Default is 600 (10 min). This is to handle very large files. -#' @param rq A list in the form of an `httr2` request object. Default is NULL. +#' @param session_df Data frame describing assets. Must include `vol_id`, +#' `session_id`, `asset_id`, and `asset_name` columns. +#' @param target_dir Character string. Base directory for downloads. Defaults to +#' `tempdir()`. +#' @param add_session_subdir Logical. When `TRUE`, creates a subdirectory per +#' session inside `target_dir`. +#' @param overwrite Logical. When `FALSE`, the function aborts if the target +#' directory already exists. +#' @param make_portable_fn Logical. When `TRUE`, filenames are sanitized via +#' `make_fn_portable()`. +#' @param timeout_secs Numeric. Timeout applied to each download request. +#' @param rq An optional `httr2` request object reused when requesting signed +#' links. #' -#' @returns Full file names to the downloaded assets or NULL. +#' @returns Character vector of downloaded file paths or `NULL` if the request +#' fails before any downloads start. #' #' @inheritParams options_params #' #' @examples #' \donttest{ #' \dontrun{ -#' download_session_assets_fr_df() # Downloads all of the files from session -#' 9807 in Databrary volume 1. -#' -#' # Just the CSVs -#' v1 <- list_session_assets() -#' v1_csv <- dplyr::filter(v1, format_extension == "csv") -#' download_session_assets_fr_df(v1_csv, vb = TRUE) +#' assets <- list_session_assets(vol_id = 1, session_id = 9807) +#' download_session_assets_fr_df(assets, vb = TRUE) #' } #' } #' @export @@ -47,61 +46,57 @@ download_session_assets_fr_df <- timeout_secs = REQUEST_TIMEOUT_VERY_LONG, vb = options::opt("vb"), rq = NULL) { - # Check parameters assertthat::assert_that(is.data.frame(session_df)) - assertthat::assert_that("session_id" %in% names(session_df)) - assertthat::assert_that("session_id" %in% names(session_df)) - assertthat::assert_that("asset_id" %in% names(session_df)) - assertthat::assert_that("format_extension" %in% names(session_df)) - assertthat::assert_that("asset_name" %in% names(session_df)) - + required_cols <- c("vol_id", "session_id", "asset_id", "asset_name") + missing_cols <- setdiff(required_cols, names(session_df)) + if (length(missing_cols) > 0) { + stop( + "session_df is missing required columns: ", + paste(missing_cols, collapse = ", "), + call. = FALSE + ) + } + assertthat::assert_that(length(target_dir) == 1) assertthat::assert_that(is.character(target_dir)) - if (!dir.exists(target_dir)) { - if (vb) { - message("Target directory not found: ", target_dir) - message("Creating: ", target_dir) - } - dir.create(target_dir, recursive = TRUE) - } else { - if (vb) - message("Target directory exists: ", target_dir) - if (overwrite) { - if (vb) - message("`overwrite` is TRUE. Overwriting directory: ", target_dir) - } else { - if (vb) + if (dir.exists(target_dir)) { + if (!overwrite) { + if (vb) { message("`overwrite` is FALSE. Cannot continue.") + } return(NULL) } + } else { + dir.create(target_dir, recursive = TRUE, showWarnings = FALSE) } assertthat::is.writeable(target_dir) - + assertthat::assert_that(length(add_session_subdir) == 1) assertthat::assert_that(is.logical(add_session_subdir)) - + assertthat::assert_that(length(overwrite) == 1) assertthat::assert_that(is.logical(overwrite)) - + assertthat::assert_that(length(make_portable_fn) == 1) assertthat::assert_that(is.logical(make_portable_fn)) - + assertthat::is.number(timeout_secs) assertthat::assert_that(length(timeout_secs) == 1) assertthat::assert_that(timeout_secs > 0) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - if (vb) - message("Downloading n=", dim(session_df)[1], " files to /", target_dir) + + assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) + + if (vb) { + message("Downloading n=", nrow(session_df), " files to ", target_dir) + } + purrr::map( - 1:dim(session_df)[1], + seq_len(nrow(session_df)), download_single_session_asset_fr_df, - session_df, + session_df = session_df, target_dir = target_dir, add_session_subdir = add_session_subdir, overwrite = overwrite, @@ -109,7 +104,7 @@ download_session_assets_fr_df <- timeout_secs = timeout_secs, vb = vb, rq = rq, - .progress = TRUE + .progress = vb ) |> purrr::list_c() } diff --git a/R/download_session_csv.R b/R/download_session_csv.R index 84dd9240..87e6f400 100644 --- a/R/download_session_csv.R +++ b/R/download_session_csv.R @@ -3,108 +3,61 @@ #' NULL -#' Download Session Spreadsheet As CSV +#' Request a Session or Volume CSV Export. #' -#' @description Databrary generates a CSV-formated spreadsheet that summarizes -#' information about individual sessions. This command downloads that CSV file -#' as a temporary file or with a name specified by the user. +#' @description +#' The Django API generates CSV reports asynchronously. This function queues a +#' CSV export for a specific session when `session_id` is supplied, or for the +#' entire volume when `session_id` is `NULL`. The API delivers the final signed +#' download link via email once the export is ready. #' -#' @param vol_id An integer. Target volume number. Default is 1. -#' @param file_name A character string. Name for the output file. -#' Default is 'test.csv'. -#' @param target_dir A character string. Directory to save downloaded file. -#' Default is `tempdir()`. -#' @param as_df A logical value. Convert the data from a list to a data frame. -#' Default is FALSE. -#' @param rq An `httr2` request object. Default is NULL. +#' @param vol_id Integer. Target volume identifier. Default is 1. +#' @param session_id Optional integer. When provided, requests a session-level +#' CSV export. When `NULL`, a volume-level CSV export is requested. +#' @param rq An `httr2` request object. Default is `NULL`, meaning a default +#' authenticated request is generated. #' -#' @returns A character string that is the name of the downloaded file or a -#' data frame if `as_df` is TRUE. +#' @returns A list describing the processing task (`status`, `message`, +#' `task_id`) or `NULL` if the request fails. #' #' @inheritParams options_params #' #' @examples #' \donttest{ #' \dontrun{ -#' download_session_csv() # Downloads "session" CSV for volume 1 +#' # Request a volume-wide CSV export +#' download_session_csv(vol_id = 1) +#' +#' # Request a session-specific CSV export +#' download_session_csv(vol_id = 1, session_id = 9807) #' } #' } #' #' @export download_session_csv <- function(vol_id = 1, - file_name = "test.csv", - target_dir = tempdir(), - as_df = FALSE, + session_id = NULL, vb = options::opt("vb"), rq = NULL) { - # Check parameters assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - - assertthat::assert_that(length(file_name) == 1) - assertthat::assert_that(is.character(file_name)) - - assertthat::assert_that(length(target_dir) == 1) - assertthat::assert_that(is.character(target_dir)) - - assertthat::assert_that(length(as_df) == 1) - assertthat::assert_that(is.logical(as_df)) - + + if (!is.null(session_id)) { + assertthat::assert_that(length(session_id) == 1) + assertthat::assert_that(is.numeric(session_id)) + assertthat::assert_that(session_id >= 1) + } + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - # Handle NULL request - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - this_rq <- rq %>% - httr2::req_url(sprintf(GET_SESSION_CSV, vol_id)) - - if (vb) - message(paste0("Downloading spreadsheet from vol_id ", vol_id, '.')) - resp <- tryCatch( - httr2::req_perform(this_rq), - httr2_error = function(cnd) { - if (vb) - message("Error retrieving spreadsheet from vol_id ", vol_id, ".") - NULL - } - ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } - - if (vb) - message("Valid CSV downloaded from ", sprintf(GET_SESSION_CSV, vol_id)) - - resp_txt <- httr2::resp_body_string(resp) - df <- - readr::read_csv( - resp_txt, - show_col_types = FALSE, - col_types = readr::cols(.default = readr::col_character()) - ) %>% - # Replace dashes in column names with underscores - dplyr::rename_with( ~ gsub("-", "_", .x, fixed = TRUE)) - if (as_df == TRUE) { - df + + assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) + + path <- if (is.null(session_id)) { + sprintf(API_VOLUME_CSV_DOWNLOAD_LINK, vol_id) } else { - if (vb) - message("Saving CSV.") - assertthat::is.writeable(target_dir) - full_fn <- file.path(target_dir, file_name) - assertthat::is.string(full_fn) - readr::write_csv(df, full_fn) - full_fn + sprintf(API_SESSION_CSV_DOWNLOAD_LINK, vol_id, session_id) } + + request_processing_task(path = path, rq = rq, vb = vb) } diff --git a/R/download_session_zip.R b/R/download_session_zip.R index 18f9a44b..440a1be3 100644 --- a/R/download_session_zip.R +++ b/R/download_session_zip.R @@ -3,125 +3,49 @@ #' NULL -#' Download Zip Archive From Databrary Session. +#' Request a Signed ZIP Download for a Session. #' -#' @param vol_id Volume number. -#' @param session_id Slot/session number. -#' @param out_dir Directory to save output file. -#' @param file_name Name for downloaded file, default is 'test.zip'. -#' @param rq An `httr2` request object. Default is NULL. +#' @description +#' The Django API prepares session-level ZIP archives asynchronously. Calling +#' `download_session_zip()` triggers the job and returns a processing task +#' summary. Once the archive is ready, Databrary emails a signed download link +#' to the authenticated user. #' -#' @returns Full filename of the downloaded file. +#' @param vol_id Volume identifier that owns the session. +#' @param session_id Session identifier within the volume. +#' @param rq An `httr2` request object. Default is `NULL`, in which case a +#' default authenticated request is generated. +#' +#' @returns A list describing the processing task (`status`, `message`, +#' `task_id`) or `NULL` when the request fails. #' #' @inheritParams options_params #' #' @examples #' \donttest{ #' \dontrun{ -#' download_session_zip() # Downloads Zip Archive from volume 31, session 9803 +#' download_session_zip(vol_id = 31, session_id = 9803) #' } #' } #' #' @export download_session_zip <- function(vol_id = 31, session_id = 9803, - out_dir = tempdir(), - file_name = "test.zip", vb = options::opt("vb"), rq = NULL) { - # Check parameters assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - + assertthat::assert_that(length(session_id) == 1) assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id >= 1) - - assertthat::assert_that(length(out_dir) == 1) - assertthat::assert_that(is.character(out_dir)) - - assertthat::assert_that(length(file_name) == 1) - assertthat::assert_that(is.character(file_name)) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - rq <- rq %>% - httr2::req_url(sprintf(GET_SESSION_ZIP, vol_id, session_id)) - - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) { - if (vb) - message("Error downloading zip from sprintf(GET_SESSION_ZIP, vol_id, - session_id)") - NULL - } - ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(NULL) - } - - bin <- NULL - bin <- httr2::resp_body_raw(resp) - - if (is.null(bin)) { - if (vb) - message("Null file returned") - return(NULL) - } - - if (file_name == "test.zip") { - if (vb) { - if (vb) - message("File name unspecified. Generating unique name.") - } - file_name <- make_zip_fn_sess(out_dir, vol_id, session_id) - } - if (vb) { - if (vb) - message(paste0("Downloading zip file as: \n'", file_name, "'.")) - } - writeBin(bin, file_name) - file_name -} -#------------------------------------------------------------------------------- -make_zip_fn_sess <- function(out_dir, vol_id, session_id) { - # Check parameters - assertthat::is.string(out_dir) - assertthat::is.writeable(out_dir) - assertthat::assert_that(length(out_dir) == 1) - - assertthat::assert_that(length(vol_id) == 1) - assertthat::assert_that(is.numeric(vol_id)) - assertthat::assert_that(vol_id >= 1) - - assertthat::assert_that(length(session_id) == 1) - assertthat::assert_that(is.numeric(session_id)) - assertthat::assert_that(session_id >= 1) - - paste0( - out_dir, - "/vol-", - vol_id, - "-sess-", - session_id, - "-", - format(Sys.time(), "%F-%H%M-%S"), - ".zip" - ) + assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) + + path <- sprintf(API_SESSION_DOWNLOAD_LINK, vol_id, session_id) + request_processing_task(path = path, rq = rq, vb = vb) } diff --git a/R/download_single_folder_asset_fr_df.R b/R/download_single_folder_asset_fr_df.R new file mode 100644 index 00000000..807c5945 --- /dev/null +++ b/R/download_single_folder_asset_fr_df.R @@ -0,0 +1,150 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Download a Single Folder Asset From a Data Frame Row. +#' +#' @description +#' Helper used by `download_folder_assets_fr_df()` to fetch a single asset via +#' the signed-download workflow. +#' +#' @param i Integer. Index of the asset within `folder_df`. +#' @param folder_df Data frame containing folder asset metadata. +#' @param target_dir Base directory for downloads. +#' @param add_folder_subdir Logical. When `TRUE`, creates a subdirectory per +#' folder inside `target_dir`. +#' @param overwrite Logical. When `FALSE`, existing files are saved with a +#' timestamped suffix. +#' @param make_portable_fn Logical. When `TRUE`, filenames are sanitized via +#' `make_fn_portable()`. +#' @param timeout_secs Numeric. Timeout applied to the signed download request. +#' @param rq Optional `httr2` request object reused to request signed links. +#' +#' @returns Path to the downloaded asset or `NULL` if the download fails. +#' +#' @inheritParams options_params +#' +#' @export +download_single_folder_asset_fr_df <- function(i = NULL, + folder_df = NULL, + target_dir = tempdir(), + add_folder_subdir = TRUE, + overwrite = TRUE, + make_portable_fn = FALSE, + timeout_secs = REQUEST_TIMEOUT_VERY_LONG, + vb = options::opt("vb"), + rq = NULL) { + assertthat::assert_that(length(i) == 1) + assertthat::is.number(i) + assertthat::assert_that(i > 0) + + assertthat::assert_that(is.data.frame(folder_df)) + required_cols <- c("vol_id", "folder_id", "asset_id", "asset_name") + missing_cols <- setdiff(required_cols, names(folder_df)) + if (length(missing_cols) > 0) { + stop( + "folder_df is missing required columns: ", + paste(missing_cols, collapse = ", "), + call. = FALSE + ) + } + + assertthat::assert_that(length(target_dir) == 1) + assertthat::is.string(target_dir) + assertthat::assert_that(dir.exists(target_dir) || dir.create(target_dir, recursive = TRUE, showWarnings = FALSE)) + assertthat::is.writeable(target_dir) + + assertthat::assert_that(length(add_folder_subdir) == 1) + assertthat::assert_that(is.logical(add_folder_subdir)) + + assertthat::assert_that(length(overwrite) == 1) + assertthat::assert_that(is.logical(overwrite)) + + assertthat::assert_that(length(make_portable_fn) == 1) + assertthat::assert_that(is.logical(make_portable_fn)) + + assertthat::is.number(timeout_secs) + assertthat::assert_that(length(timeout_secs) == 1) + assertthat::assert_that(timeout_secs > 0) + + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) + + this_asset <- folder_df[i, , drop = FALSE] + if (nrow(this_asset) == 0) { + if (vb) { + message("No asset for index ", i) + } + return(NULL) + } + + dest_dir <- if (isTRUE(add_folder_subdir)) { + file.path(target_dir, this_asset$folder_id) + } else { + target_dir + } + dir.create(dest_dir, recursive = TRUE, showWarnings = FALSE) + assertthat::assert_that(dir.exists(dest_dir)) + assertthat::is.writeable(dest_dir) + + base_name <- this_asset$asset_name + if (is.null(base_name) || is.na(base_name) || base_name == "") { + base_name <- paste0("asset-", this_asset$asset_id) + } + + extension <- "" + if ("format_extension" %in% names(this_asset)) { + ext_value <- this_asset$format_extension + if (!is.null(ext_value) && !is.na(ext_value) && nzchar(ext_value)) { + if (tools::file_ext(base_name) != ext_value) { + extension <- paste0(".", ext_value) + } + } + } + + candidate_name <- paste0(base_name, extension) + + if (make_portable_fn) { + if (vb) { + message("Making file name '", candidate_name, "' portable.") + } + candidate_name <- make_fn_portable(candidate_name, vb = vb) + } + + dest_file <- file.path(dest_dir, candidate_name) + if (file.exists(dest_file) && !overwrite) { + if (vb) { + message("Generating new unique (time-stamped) file name.") + } + candidate_name <- paste0( + this_asset$folder_id, + "-", + this_asset$asset_id, + "-", + format(Sys.time(), "%F-%H%M-%S"), + ifelse( + nzchar(tools::file_ext(candidate_name)), + paste0(".", tools::file_ext(candidate_name)), + "" + ) + ) + dest_file <- file.path(dest_dir, candidate_name) + } + + download_folder_asset( + vol_id = this_asset$vol_id, + folder_id = this_asset$folder_id, + asset_id = this_asset$asset_id, + file_name = candidate_name, + target_dir = dest_dir, + timeout_secs = timeout_secs, + vb = vb, + rq = rq + ) +} + + + diff --git a/R/download_single_session_asset_fr_df.R b/R/download_single_session_asset_fr_df.R index 8ace4fec..ce4fe68a 100644 --- a/R/download_single_session_asset_fr_df.R +++ b/R/download_single_session_asset_fr_df.R @@ -3,48 +3,28 @@ #' NULL -#' Download Single Asset From Databrary +#' Download a Single Asset From a Session Data Frame Row. #' -#' @description Databrary stores file types (assets) of many types. This -#' function downloads an asset based on its system-unique integer identifer -#' (asset_id) and system-unique session (slot) identifier (session_id). It -#' is designed to work with download_session_assets_fr_df() so that multiple -#' files can be downloaded simultaneously. +#' @description +#' Helper used by `download_session_assets_fr_df()` to fetch a single asset via +#' the signed-download workflow. #' -#' @param i An integer. Index into a row of the session asset data frame. -#' Default is NULL. -#' @param session_df A row from a data frame from `list_session_assets()` -#' or `list_volume_assets()`. Default is NULL> -#' @param target_dir A character string. Directory to save the downloaded file. -#' Default is a temporary directory given by a call to `tempdir()`. -#' @param add_session_subdir A logical value. Add add the session name to the -#' file path so that files are in a subdirectory specific to the session. Default -#' is TRUE. -#' @param overwrite A logical value. Overwrite an existing file. Default is TRUE. -#' @param make_portable_fn A logical value. Replace characters in file names -#' that are not broadly portable across file systems. Default is FALSE. -#' @param timeout_secs An integer. The seconds an httr2 request will run before -#' timing out. Default is 600 (10 min). This is to handle very large files. -#' @param rq A list in the form of an `httr2` request object. Default is NULL. +#' @param i Integer. Index of the asset within `session_df`. +#' @param session_df Data frame containing asset metadata. +#' @param target_dir Base directory for downloads. +#' @param add_session_subdir Logical. When `TRUE`, creates a subdirectory per +#' session inside `target_dir`. +#' @param overwrite Logical. When `FALSE`, existing files are saved with a +#' timestamped suffix. +#' @param make_portable_fn Logical. When `TRUE`, filenames are sanitized via +#' `make_fn_portable()`. +#' @param timeout_secs Numeric. Timeout applied to the signed download request. +#' @param rq Optional `httr2` request object reused to request signed links. #' -#' @returns Full file name to the asset or NULL. -#' -#' @inheritParams options_params +#' @returns Path to the downloaded asset or `NULL` if the download fails. #' -#' @examples -#' \donttest{ -#' \dontrun{ -#' vol_1 <- list_session_assets(session_id = 9807) -#' a_1 <- vol_1[1,] -#' tmp_dir <- tempdir() -#' fn <- file.path(tmp_dir, paste0(a_1$asset_name, ".", a_1$format_extension)) -#' download_single_session_asset_fr_df(a_1$asset_id, -#' fn, -#' session_id = a_1$session_id, -#' vb = TRUE) +#' @inheritParams options_params #' -#' } -#' } #' @export download_single_session_asset_fr_df <- function(i = NULL, session_df = NULL, @@ -55,183 +35,113 @@ download_single_session_asset_fr_df <- function(i = NULL, timeout_secs = REQUEST_TIMEOUT_VERY_LONG, vb = options::opt("vb"), rq = NULL) { - # Check parameters assertthat::assert_that(length(i) == 1) assertthat::is.number(i) assertthat::assert_that(i > 0) - + assertthat::assert_that(is.data.frame(session_df)) - assertthat::assert_that("session_id" %in% names(session_df)) - assertthat::assert_that("asset_id" %in% names(session_df)) - assertthat::assert_that("format_extension" %in% names(session_df)) - assertthat::assert_that("asset_name" %in% names(session_df)) - + required_cols <- c("vol_id", "session_id", "asset_id", "asset_name") + missing_cols <- setdiff(required_cols, names(session_df)) + if (length(missing_cols) > 0) { + stop( + "session_df is missing required columns: ", + paste(missing_cols, collapse = ", "), + call. = FALSE + ) + } + assertthat::assert_that(length(target_dir) == 1) assertthat::is.string(target_dir) + assertthat::assert_that(dir.exists(target_dir) || dir.create(target_dir, recursive = TRUE, showWarnings = FALSE)) assertthat::is.writeable(target_dir) - + assertthat::assert_that(length(add_session_subdir) == 1) assertthat::assert_that(is.logical(add_session_subdir)) - + assertthat::assert_that(length(overwrite) == 1) assertthat::assert_that(is.logical(overwrite)) - + assertthat::assert_that(length(make_portable_fn) == 1) assertthat::assert_that(is.logical(make_portable_fn)) - + assertthat::is.number(timeout_secs) assertthat::assert_that(length(timeout_secs) == 1) assertthat::assert_that(timeout_secs > 0) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - this_asset <- session_df[i, ] - if (is.null(this_asset)) { - if (vb) + + assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) + + this_asset <- session_df[i, , drop = FALSE] + if (nrow(this_asset) == 0) { + if (vb) { message("No asset for index ", i) + } return(NULL) } - - if (add_session_subdir) { - full_fn <- file.path( - target_dir, - this_asset$session_id, - paste0(this_asset$asset_name, ".", this_asset$format_extension) - ) - if (vb) - message("`add_session_subdir` is TRUE.") + + dest_dir <- if (isTRUE(add_session_subdir)) { + file.path(target_dir, this_asset$session_id) } else { - full_fn <- file.path(target_dir, - paste0(this_asset$asset_name, ".", this_asset$format_extension)) - if (vb) - message("`add_session_subdir` is FALSE.") + target_dir } - - if (file.exists(full_fn)) { - if (vb) - message("File exists: ", full_fn) - if (!overwrite) { - if (vb) - message("Generating new unique (time-stamped) file name.") - full_fn <- file.path( - dirname(full_fn), - paste0( - this_asset$session_id, - "-", - this_asset$asset_id, - "-", - format(Sys.time(), "%F-%H%M-%S"), - paste0(".", this_asset$format_extension) - ) - ) - } else { - if (vb) - message("Will overwrite existing file.") + dir.create(dest_dir, recursive = TRUE, showWarnings = FALSE) + assertthat::assert_that(dir.exists(dest_dir)) + assertthat::is.writeable(dest_dir) + + base_name <- this_asset$asset_name + if (is.null(base_name) || is.na(base_name) || base_name == "") { + base_name <- paste0("asset-", this_asset$asset_id) + } + + extension <- "" + if ("format_extension" %in% names(this_asset)) { + ext_value <- this_asset$format_extension + if (!is.null(ext_value) && !is.na(ext_value) && nzchar(ext_value)) { + if (tools::file_ext(base_name) != ext_value) { + extension <- paste0(".", ext_value) + } } } - + + candidate_name <- paste0(base_name, extension) + if (make_portable_fn) { - if (vb) - message("Making file name '", full_fn, "' portable.") - full_fn <- make_fn_portable(full_fn, vb = vb) - } - assertthat::is.string(full_fn) - - if (!dir.exists(dirname(full_fn))) { if (vb) { - message("Target directory not found: ", dirname(full_fn)) - message("Creating: ", dirname(full_fn)) - } - dir.create(dirname(full_fn), recursive = TRUE) - } else { - if (vb) - message("Target directory exists: ", dirname(full_fn)) - if (overwrite) { - if (vb) - message("Overwriting directory: ", dirname(full_fn)) - } else { - if (vb) - message("`overwrite` is FALSE. Skipping.") - return(NULL) + message("Making file name '", candidate_name, "' portable.") } + candidate_name <- make_fn_portable(candidate_name, vb = vb) } - assertthat::is.writeable(dirname(full_fn)) - - # Handle NULL rq - if (is.null(rq)) { + + dest_file <- file.path(dest_dir, candidate_name) + if (file.exists(dest_file) && !overwrite) { if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") + message("Generating new unique (time-stamped) file name.") } - rq <- databraryr::make_default_request() - } - - if (vb) - message( - "Downloading file with asset_id ", + candidate_name <- paste0( + this_asset$session_id, + "-", this_asset$asset_id, - " from session_id ", - this_asset$session_id + "-", + format(Sys.time(), "%F-%H%M-%S"), + ifelse( + nzchar(tools::file_ext(candidate_name)), + paste0(".", tools::file_ext(candidate_name)), + "" + ) ) - - # Up default timeout for possibly big files - rq <- - httr2::req_timeout(rq, seconds = timeout_secs) - - this_rq <- rq %>% - httr2::req_url(sprintf(DOWNLOAD_FILE, this_asset$session_id, this_asset$asset_id)) %>% - httr2::req_progress() - - resp <- tryCatch( - httr2::req_perform(this_rq), - httr2_error = function(cnd) - if (vb) - message( - "Error downloading asset ", - this_asset$asset_name, - " from session_id ", - this_asset$session_id - ), - NULL - ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) + dest_file <- file.path(dest_dir, candidate_name) } - - # if (is.null(resp)) { - # if (vb) - # message( - # "Download request for session ", - # this_asset$session_id, - # " asset ", - # this_asset$asset_id, - # " returned NULL. Skipping." - # ) - # return(NULL) - # } - - write_file <- tryCatch( - error = function(cnd) { - if (vb) - message("Failure writing file ", full_fn) - NULL - }, - { - file_con <- file(full_fn, "wb") - writeBin(resp$body, file_con) - close(file_con) - } + + download_session_asset( + vol_id = this_asset$vol_id, + session_id = this_asset$session_id, + asset_id = this_asset$asset_id, + file_name = candidate_name, + target_dir = dest_dir, + timeout_secs = timeout_secs, + vb = vb, + rq = rq ) - - if (!is.null(write_file)) { - full_fn - } else { - write_file - } } diff --git a/R/download_utils.R b/R/download_utils.R new file mode 100644 index 00000000..caea1b26 --- /dev/null +++ b/R/download_utils.R @@ -0,0 +1,101 @@ +# Internal helpers for the Django signed-download workflow. + +#' @noRd +request_processing_task <- function(path, rq = NULL, vb = FALSE) { + task <- perform_api_get( + path = path, + rq = rq, + vb = vb, + normalize = TRUE + ) + + if (is.null(task)) { + if (vb) { + message("Cannot access requested resource on Databrary. Exiting.") + } + return(NULL) + } + + if (vb && !is.null(task$message)) { + message(task$message) + } + + class(task) <- unique(c("databrary_processing_task", class(task))) + task +} + +#' @noRd +request_signed_download_link <- function(path, rq = NULL, vb = FALSE) { + link <- perform_api_get( + path = path, + rq = rq, + vb = vb, + normalize = TRUE + ) + + if (is.null(link)) { + if (vb) { + message("Cannot access requested resource on Databrary. Exiting.") + } + return(NULL) + } + + if (is.null(link$download_url)) { + if (vb) { + message("Download link payload missing 'download_url'.") + } + return(NULL) + } + + link$download_url <- ensure_absolute_url(link$download_url) + class(link) <- unique(c("databrary_signed_download", class(link))) + link +} + +#' @noRd +ensure_absolute_url <- function(url) { + assertthat::assert_that(assertthat::is.string(url)) + if (startsWith(url, "http://") || startsWith(url, "https://")) { + return(url) + } + paste0(DATABRARY_BASE_URL, ensure_leading_slash(url)) +} + +#' @noRd +download_signed_file <- function(download_url, + dest_path, + timeout_secs = REQUEST_TIMEOUT_VERY_LONG, + vb = FALSE) { + assertthat::assert_that(assertthat::is.string(download_url)) + assertthat::assert_that(assertthat::is.string(dest_path)) + assertthat::is.number(timeout_secs) + assertthat::assert_that(timeout_secs > 0) + + parent_dir <- dirname(dest_path) + if (!dir.exists(parent_dir)) { + dir.create(parent_dir, recursive = TRUE, showWarnings = FALSE) + } + assertthat::is.writeable(parent_dir) + + req <- httr2::request(download_url) | + httr2::req_timeout(seconds = timeout_secs) + + if (vb) { + message("Saving download to '", dest_path, "'.") + } + + tryCatch( + { + httr2::req_perform(req, path = dest_path) + dest_path + }, + httr2_error = function(cnd) { + if (vb) { + message("Download failed: ", conditionMessage(cnd)) + } + NULL + } + ) +} + + diff --git a/R/download_video.R b/R/download_video.R index d2a17118..8e24daec 100644 --- a/R/download_video.R +++ b/R/download_video.R @@ -3,119 +3,77 @@ #' NULL -#' Download Video From Databrary. +#' Download a Video Asset via Signed URL. #' -#' @param asset_id Asset id for target file. -#' @param session_id Slot/session number where target file is stored. -#' @param file_name Name for downloaded file. -#' @param target_dir Directory to save the downloaded file. -#' Default is a temporary directory given by a call to `tempdir()`. -#' @param rq An `httr2` request object. +#' @param vol_id Volume identifier containing the session. +#' @param session_id Session identifier containing the asset. +#' @param asset_id Asset identifier for the video file. +#' @param file_name Optional explicit file name. Defaults to the API-provided +#' value. +#' @param target_dir Directory to save the downloaded file. Defaults to +#' `tempdir()`. +#' @param rq Optional `httr2` request object reused when requesting the signed +#' link. #' -#' @returns Full file name to the asset. +#' @returns Path to the downloaded video or `NULL` on failure. #' #' @inheritParams options_params #' #' @examples #' \donttest{ #' \dontrun{ -#' download_video() # Download's 'numbers' file from volume 1. -#' download_video(asset_id = 11643, session_id = 9825, file_name = "rdk.mp4") -#' #' # Downloads a display with a random dot kinematogram (RDK). +#' download_video() # Default public video from volume 1 +#' download_video(vol_id = 1, session_id = 9825, asset_id = 11643, +#' file_name = "rdk.mp4") #' } #' } #' #' @export -download_video <- function(asset_id = 1, +download_video <- function(vol_id = 1, session_id = 9807, - file_name = tempfile(paste0(session_id, "_", - asset_id, "_"), - fileext = ".mp4"), + asset_id = 1, + file_name = NULL, target_dir = tempdir(), vb = options::opt("vb"), rq = NULL) { - # Check parameters assertthat::assert_that(length(asset_id) == 1) assertthat::assert_that(is.numeric(asset_id)) assertthat::assert_that(asset_id >= 1) - + assertthat::assert_that(length(session_id) == 1) assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id >= 1) - - assertthat::assert_that(length(file_name) == 1) - assertthat::assert_that(is.character(file_name)) - + + assertthat::assert_that(length(vol_id) == 1) + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(vol_id >= 1) + + if (!is.null(file_name)) { + assertthat::assert_that(length(file_name) == 1) + assertthat::assert_that(is.character(file_name)) + if (!endsWith(tolower(file_name), ".mp4")) { + stop("file_name must end with '.mp4' when provided.", call. = FALSE) + } + } + assertthat::assert_that(length(target_dir) == 1) assertthat::assert_that(is.character(target_dir)) - assertthat::assert_that(dir.exists(target_dir)) - + assertthat::assert_that(dir.exists(target_dir) || dir.create(target_dir, recursive = TRUE, showWarnings = FALSE)) + assertthat::is.writeable(target_dir) + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - - this_rq <- rq %>% - httr2::req_url(sprintf(DOWNLOAD_FILE, session_id, asset_id)) %>% - httr2::req_progress() - - if (file.exists(file_name)) { - if (vb) - message("File exists. Generating new unique name.\n") - file_name <- file.path(tempdir(), - paste0( - session_id, - "-", - asset_id, - "-", - format(Sys.time(), "%F-%H%M-%S"), - ".mp4" - )) - } - - if (vb) - message("Attempting to download video with asset_id ", - asset_id, - " from session_id ", - session_id) - - resp <- tryCatch( - httr2::req_perform(this_rq), - httr2_error = function(cnd) { - if (vb) - message( - message( - "Error retrieving video with asset_id ", - asset_id, - " from session_id ", - session_id - ) - ) - NULL - } + + assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) + + download_session_asset( + vol_id = vol_id, + session_id = session_id, + asset_id = asset_id, + file_name = file_name, + target_dir = target_dir, + vb = vb, + rq = rq, + timeout_secs = REQUEST_TIMEOUT_VERY_LONG ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } - - if (httr2::resp_content_type(resp) == "video/mp4") { - file_con <- file(file_name, "wb") - writeBin(resp$body, file_con) - close(file_con) - file_name - } else { - message("Content type is ", httr2::resp_content_type(resp)) - NULL - } } diff --git a/R/download_volume_zip.R b/R/download_volume_zip.R index a8bfcf19..8d44338c 100644 --- a/R/download_volume_zip.R +++ b/R/download_volume_zip.R @@ -3,112 +3,43 @@ #' NULL -#' Download Zip Archive of All Data in a Volume. +#' Request a Signed ZIP Download for a Volume. #' -#' @param vol_id Volume number. -#' @param out_dir Directory to save output file. -#' @param file_name Name for downloaded file, default is 'test.mp4'. -#' @param rq An `httr2` request object. Default is NULL. +#' @description +#' Volume-level ZIP archives are prepared asynchronously by the Django API. +#' Calling `download_volume_zip()` queues the job and returns a processing task +#' descriptor. When the archive is ready, Databrary emails a signed download +#' link to the authenticated user. +#' +#' @param vol_id Volume identifier. +#' @param rq An `httr2` request object. Default is `NULL`, in which case a +#' default authenticated request is generated. +#' +#' @returns A list describing the processing task (`status`, `message`, +#' `task_id`) or `NULL` when the request fails. #' -#' @returns Full filename of the downloaded file. -#' #' @inheritParams options_params -#' +#' #' @examples #' \donttest{ #' \dontrun{ -#' download_volume_zip() # Zip file of all data from volume 31, the default. +#' download_volume_zip(vol_id = 31) #' } #' } #' #' @export download_volume_zip <- function(vol_id = 31, - out_dir = tempdir(), - file_name = "test.zip", vb = options::opt("vb"), rq = NULL) { - # Check parameters assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - - assertthat::assert_that(length(out_dir) == 1) - assertthat::assert_that(is.character(out_dir)) - - assertthat::assert_that(length(file_name) == 1) - assertthat::assert_that(is.character(file_name)) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - # Handle NULL request - if (is.null(rq)) { - if (vb) { - message("\nNULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } - rq <- rq %>% - httr2::req_url(sprintf(GET_VOLUME_ZIP, vol_id)) - - resp <- tryCatch( - httr2::req_perform(rq), - httr2_error = function(cnd) { - if (vb) message("Error downloading zip archive from vol_id ", vol_id) - NULL - } - ) - - if (is.null(resp)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(resp) - } - - bin <- NULL - bin <- httr2::resp_body_raw(resp) - if (is.null(bin)) { - if (vb) message("Null file returned") - return(NULL) - } - - if (file_name == "test.zip") { - if (vb) { - if (vb) - message("File name unspecified. Generating unique name.") - } - file_name <- make_zip_fn_vol(out_dir, vol_id) - } - if (vb) { - if (vb) - message(paste0("Downloading zip file as: \n'", file_name, "'.")) - } - writeBin(bin, file_name) - file_name -} + assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) -#------------------------------------------------------------------------------- -make_zip_fn_vol <- function(out_dir, vol_id) { - - # Check parameters - assertthat::is.string(out_dir) - assertthat::is.writeable(out_dir) - assertthat::assert_that(length(out_dir) == 1) - - assertthat::assert_that(length(vol_id) == 1) - assertthat::assert_that(is.numeric(vol_id)) - assertthat::assert_that(vol_id >= 1) - - paste0( - out_dir, - "/vol-", - vol_id, - "-", - format(Sys.time(), "%F-%H%M-%S"), - ".zip" - ) + path <- sprintf(API_VOLUME_DOWNLOAD_LINK, vol_id) + request_processing_task(path = path, rq = rq, vb = vb) } diff --git a/R/list_folder_assets.R b/R/list_folder_assets.R index b701f33c..ccbac127 100644 --- a/R/list_folder_assets.R +++ b/R/list_folder_assets.R @@ -79,6 +79,7 @@ list_folder_assets <- function(folder_id = 1, asset_mime_type = format$mimetype, asset_format_id = format$id, asset_format_name = format$name, + format_extension = format$extension, asset_duration = file$duration, asset_created_at = file$created_at, asset_updated_at = file$updated_at, diff --git a/R/list_session_assets.R b/R/list_session_assets.R index dc24c69a..270658ec 100644 --- a/R/list_session_assets.R +++ b/R/list_session_assets.R @@ -84,6 +84,7 @@ list_session_assets <- function(session_id = 9807, asset_mime_type = format$mimetype, asset_format_id = format$id, asset_format_name = format$name, + format_extension = format$extension, asset_duration = file$duration, asset_created_at = file$created_at, asset_updated_at = file$updated_at, diff --git a/man/download_folder_asset.Rd b/man/download_folder_asset.Rd new file mode 100644 index 00000000..5c6e01ac --- /dev/null +++ b/man/download_folder_asset.Rd @@ -0,0 +1,57 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/download_folder_asset.R +\name{download_folder_asset} +\alias{download_folder_asset} +\title{Download a Folder Asset via Signed Link.} +\usage{ +download_folder_asset( + vol_id = 1, + folder_id = 1, + asset_id = 1, + file_name = NULL, + target_dir = tempdir(), + timeout_secs = REQUEST_TIMEOUT, + vb = options::opt("vb"), + rq = NULL +) +} +\arguments{ +\item{vol_id}{Integer. Volume identifier containing the folder. Default is 1.} + +\item{folder_id}{Integer. Folder identifier within the volume. Default is 1.} + +\item{asset_id}{Integer. Asset identifier within the folder. Default is 1.} + +\item{file_name}{Optional character string. File name to use when saving the +asset. Defaults to the API-provided file name.} + +\item{target_dir}{Character string. Directory where the file will be saved. +Default is \code{tempdir()}.} + +\item{timeout_secs}{Numeric. Timeout (seconds) applied to the download +request. Default is \code{REQUEST_TIMEOUT}.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Default is \code{NULL}, in which case a +default authenticated request is generated.} +} +\value{ +The path to the downloaded file (character string) or \code{NULL} if the +download fails. +} +\description{ +Databrary serves folder-scoped assets through signed URLs. This helper +requests the signed link for a folder asset and streams the file to the +specified directory. +} +\examples{ +\donttest{ +\dontrun{ +download_folder_asset() # Default public asset in folder 1 of volume 1 +download_folder_asset(vol_id = 1, folder_id = 2, asset_id = 3, + file_name = "example.mp4") +} +} + +} diff --git a/man/download_folder_assets_fr_df.Rd b/man/download_folder_assets_fr_df.Rd new file mode 100644 index 00000000..73992878 --- /dev/null +++ b/man/download_folder_assets_fr_df.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/download_folder_assets_fr_df.R +\name{download_folder_assets_fr_df} +\alias{download_folder_assets_fr_df} +\title{Download Multiple Assets From a Folder Data Frame.} +\usage{ +download_folder_assets_fr_df( + folder_df = list_folder_assets(vol_id = 1), + target_dir = tempdir(), + add_folder_subdir = TRUE, + overwrite = TRUE, + make_portable_fn = FALSE, + timeout_secs = REQUEST_TIMEOUT_VERY_LONG, + vb = options::opt("vb"), + rq = NULL +) +} +\arguments{ +\item{folder_df}{Data frame describing assets. Must include \code{vol_id}, +\code{folder_id}, \code{asset_id}, and \code{asset_name} columns.} + +\item{target_dir}{Character string. Base directory for downloads. Defaults to +\code{tempdir()}.} + +\item{add_folder_subdir}{Logical. When \code{TRUE}, creates a subdirectory per +folder inside \code{target_dir}.} + +\item{overwrite}{Logical. When \code{FALSE}, the function aborts if the target +directory already exists.} + +\item{make_portable_fn}{Logical. When \code{TRUE}, filenames are sanitized via +\code{make_fn_portable()}.} + +\item{timeout_secs}{Numeric. Timeout applied to each download request.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An optional \code{httr2} request object reused when requesting signed +links.} +} +\value{ +Character vector of downloaded file paths or \code{NULL} if the request +fails before any downloads start. +} +\description{ +Iterates over a data frame of folder assets, requesting signed download links +for each asset and saving them to disk. Designed to work with +\code{list_folder_assets()} output. +} +\examples{ +\donttest{ +\dontrun{ +assets <- list_folder_assets(folder_id = 1, vol_id = 1) +download_folder_assets_fr_df(assets, vb = TRUE) +} +} + +} diff --git a/man/download_folder_zip.Rd b/man/download_folder_zip.Rd new file mode 100644 index 00000000..84e1714a --- /dev/null +++ b/man/download_folder_zip.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/download_folder_zip.R +\name{download_folder_zip} +\alias{download_folder_zip} +\title{Request a Signed ZIP Download for a Folder.} +\usage{ +download_folder_zip( + vol_id = 1, + folder_id = 1, + vb = options::opt("vb"), + rq = NULL +) +} +\arguments{ +\item{vol_id}{Volume identifier for the folder.} + +\item{folder_id}{Folder identifier scoped within the specified volume.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Default is \code{NULL}, in which case a +default authenticated request is generated.} +} +\value{ +A list describing the processing task (\code{status}, \code{message}, +\code{task_id}) or \code{NULL} when the request fails. +} +\description{ +Folder-level ZIP archives are prepared asynchronously by the Django API. +Calling \code{download_folder_zip()} queues the job and returns a processing task +descriptor. When the archive is ready, Databrary emails a signed download +link to the authenticated user. +} +\examples{ +\donttest{ +\dontrun{ +download_folder_zip(vol_id = 1, folder_id = 1) +} +} + +} diff --git a/man/download_session_asset.Rd b/man/download_session_asset.Rd index 2c95e5a8..5f6369ba 100644 --- a/man/download_session_asset.Rd +++ b/man/download_session_asset.Rd @@ -2,11 +2,12 @@ % Please edit documentation in R/download_session_asset.R \name{download_session_asset} \alias{download_session_asset} -\title{Download Asset From Databrary.} +\title{Download an Asset via Signed Link.} \usage{ download_session_asset( - asset_id = 1, + vol_id = 1, session_id = 9807, + asset_id = 1, file_name = NULL, target_dir = tempdir(), timeout_secs = REQUEST_TIMEOUT, @@ -15,39 +16,41 @@ download_session_asset( ) } \arguments{ -\item{asset_id}{An integer. Asset id for target file. Default is 1.} +\item{vol_id}{Integer. Volume identifier. Default is 1.} + +\item{session_id}{Integer. Session identifier. Default is 9807.} -\item{session_id}{An integer. Slot/session number where target file is -stored. Default is 9807.} +\item{asset_id}{Integer. Asset identifier within the session. Default is 1.} -\item{file_name}{A character string. Name for downloaded file. Default is NULL.} +\item{file_name}{Optional character string. Target file name. Defaults to the +API-provided file name.} -\item{target_dir}{A character string. Directory to save the downloaded file. -Default is a temporary directory given by a call to \code{tempdir()}.} +\item{target_dir}{Character string. Directory where the file will be saved. +Default is \code{tempdir()}.} -\item{timeout_secs}{An integer constant. The default value, defined in -CONSTANTS.R is REQUEST_TIMEOUT. This value determines the default timeout -value for the httr2 request object. When downloading large files, it can be -useful to set this value to a large number.} +\item{timeout_secs}{Numeric. Timeout (seconds) applied to the download +request. Default is \code{REQUEST_TIMEOUT}.} \item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} -\item{rq}{A list in the form of an \code{httr2} request object. Default is NULL.} +\item{rq}{An \code{httr2} request object. Default is \code{NULL}, in which case a +default authenticated request is generated.} } \value{ -Full file name to the asset or NULL. +The path to the downloaded file (character string) or \code{NULL} if the +download fails. } \description{ -Databrary stores file types (assets) of many types. This -function downloads an asset based on its system-unique integer identifer -(asset_id) and system-unique session (slot) identifier (session_id). +Databrary serves assets through short-lived, signed URLs. This helper +requests the signed link for a session asset and streams the file to the +requested directory. } \examples{ \donttest{ \dontrun{ -download_session_asset() # Download's 'numbers' file from volume 1. -download_session_asset(asset_id = 11643, session_id = 9825, file_name = "rdk.mp4") -# Downloads a display with a random dot kinematogram (RDK). +download_session_asset() # Default public asset in volume 1 +download_session_asset(vol_id = 1, session_id = 9825, asset_id = 11643, + file_name = "rdk.mp4") } } } diff --git a/man/download_session_assets_fr_df.Rd b/man/download_session_assets_fr_df.Rd index f9548650..48c7b46f 100644 --- a/man/download_session_assets_fr_df.Rd +++ b/man/download_session_assets_fr_df.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/download_session_assets_fr_df.R \name{download_session_assets_fr_df} \alias{download_session_assets_fr_df} -\title{Download Asset From A Databrary Session.} +\title{Download Multiple Assets From a Session Data Frame.} \usage{ download_session_assets_fr_df( session_df = list_session_assets(), @@ -16,44 +16,42 @@ download_session_assets_fr_df( ) } \arguments{ -\item{session_df}{A data frame as generated by list_session_assets_2().} +\item{session_df}{Data frame describing assets. Must include \code{vol_id}, +\code{session_id}, \code{asset_id}, and \code{asset_name} columns.} -\item{target_dir}{A character string. Directory to save the downloaded file. -Default is directory named after the session_id.} +\item{target_dir}{Character string. Base directory for downloads. Defaults to +\code{tempdir()}.} -\item{add_session_subdir}{A logical value. Add add the session name to the -file path so that files are in a subdirectory specific to the session. Default -is TRUE.} +\item{add_session_subdir}{Logical. When \code{TRUE}, creates a subdirectory per +session inside \code{target_dir}.} -\item{overwrite}{A logical value. Overwrite an existing file. Default is TRUE.} +\item{overwrite}{Logical. When \code{FALSE}, the function aborts if the target +directory already exists.} -\item{make_portable_fn}{A logical value. Replace characters in file names -that are not broadly portable across file systems. Default is FALSE.} +\item{make_portable_fn}{Logical. When \code{TRUE}, filenames are sanitized via +\code{make_fn_portable()}.} -\item{timeout_secs}{An integer. The seconds an httr2 request will run before -timing out. Default is 600 (10 min). This is to handle very large files.} +\item{timeout_secs}{Numeric. Timeout applied to each download request.} \item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} -\item{rq}{A list in the form of an \code{httr2} request object. Default is NULL.} +\item{rq}{An optional \code{httr2} request object reused when requesting signed +links.} } \value{ -Full file names to the downloaded assets or NULL. +Character vector of downloaded file paths or \code{NULL} if the request +fails before any downloads start. } \description{ -Databrary stores file types (assets) of many types. This -function downloads assets in a data frame generated by list_session_assets(). +Iterates over a data frame of session assets, requesting signed download +links for each asset and saving them to disk. Designed to work with +\code{list_session_assets()} or \code{list_volume_session_assets()} output. } \examples{ \donttest{ \dontrun{ -download_session_assets_fr_df() # Downloads all of the files from session -9807 in Databrary volume 1. - -# Just the CSVs -v1 <- list_session_assets() -v1_csv <- dplyr::filter(v1, format_extension == "csv") -download_session_assets_fr_df(v1_csv, vb = TRUE) +assets <- list_session_assets(vol_id = 1, session_id = 9807) +download_session_assets_fr_df(assets, vb = TRUE) } } } diff --git a/man/download_session_csv.Rd b/man/download_session_csv.Rd index 039448f3..74eea14c 100644 --- a/man/download_session_csv.Rd +++ b/man/download_session_csv.Rd @@ -2,46 +2,44 @@ % Please edit documentation in R/download_session_csv.R \name{download_session_csv} \alias{download_session_csv} -\title{Download Session Spreadsheet As CSV} +\title{Request a Session or Volume CSV Export.} \usage{ download_session_csv( vol_id = 1, - file_name = "test.csv", - target_dir = tempdir(), - as_df = FALSE, + session_id = NULL, vb = options::opt("vb"), rq = NULL ) } \arguments{ -\item{vol_id}{An integer. Target volume number. Default is 1.} +\item{vol_id}{Integer. Target volume identifier. Default is 1.} -\item{file_name}{A character string. Name for the output file. -Default is 'test.csv'.} - -\item{target_dir}{A character string. Directory to save downloaded file. -Default is \code{tempdir()}.} - -\item{as_df}{A logical value. Convert the data from a list to a data frame. -Default is FALSE.} +\item{session_id}{Optional integer. When provided, requests a session-level +CSV export. When \code{NULL}, a volume-level CSV export is requested.} \item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} -\item{rq}{An \code{httr2} request object. Default is NULL.} +\item{rq}{An \code{httr2} request object. Default is \code{NULL}, meaning a default +authenticated request is generated.} } \value{ -A character string that is the name of the downloaded file or a -data frame if \code{as_df} is TRUE. +A list describing the processing task (\code{status}, \code{message}, +\code{task_id}) or \code{NULL} if the request fails. } \description{ -Databrary generates a CSV-formated spreadsheet that summarizes -information about individual sessions. This command downloads that CSV file -as a temporary file or with a name specified by the user. +The Django API generates CSV reports asynchronously. This function queues a +CSV export for a specific session when \code{session_id} is supplied, or for the +entire volume when \code{session_id} is \code{NULL}. The API delivers the final signed +download link via email once the export is ready. } \examples{ \donttest{ \dontrun{ -download_session_csv() # Downloads "session" CSV for volume 1 +# Request a volume-wide CSV export +download_session_csv(vol_id = 1) + +# Request a session-specific CSV export +download_session_csv(vol_id = 1, session_id = 9807) } } diff --git a/man/download_session_zip.Rd b/man/download_session_zip.Rd index c7c5c9b0..ab5bb17f 100644 --- a/man/download_session_zip.Rd +++ b/man/download_session_zip.Rd @@ -2,40 +2,39 @@ % Please edit documentation in R/download_session_zip.R \name{download_session_zip} \alias{download_session_zip} -\title{Download Zip Archive From Databrary Session.} +\title{Request a Signed ZIP Download for a Session.} \usage{ download_session_zip( vol_id = 31, session_id = 9803, - out_dir = tempdir(), - file_name = "test.zip", vb = options::opt("vb"), rq = NULL ) } \arguments{ -\item{vol_id}{Volume number.} +\item{vol_id}{Volume identifier that owns the session.} -\item{session_id}{Slot/session number.} - -\item{out_dir}{Directory to save output file.} - -\item{file_name}{Name for downloaded file, default is 'test.zip'.} +\item{session_id}{Session identifier within the volume.} \item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} -\item{rq}{An \code{httr2} request object. Default is NULL.} +\item{rq}{An \code{httr2} request object. Default is \code{NULL}, in which case a +default authenticated request is generated.} } \value{ -Full filename of the downloaded file. +A list describing the processing task (\code{status}, \code{message}, +\code{task_id}) or \code{NULL} when the request fails. } \description{ -Download Zip Archive From Databrary Session. +The Django API prepares session-level ZIP archives asynchronously. Calling +\code{download_session_zip()} triggers the job and returns a processing task +summary. Once the archive is ready, Databrary emails a signed download link +to the authenticated user. } \examples{ \donttest{ \dontrun{ -download_session_zip() # Downloads Zip Archive from volume 31, session 9803 +download_session_zip(vol_id = 31, session_id = 9803) } } diff --git a/man/download_single_folder_asset_fr_df.Rd b/man/download_single_folder_asset_fr_df.Rd new file mode 100644 index 00000000..ebf17e1d --- /dev/null +++ b/man/download_single_folder_asset_fr_df.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/download_single_folder_asset_fr_df.R +\name{download_single_folder_asset_fr_df} +\alias{download_single_folder_asset_fr_df} +\title{Download a Single Folder Asset From a Data Frame Row.} +\usage{ +download_single_folder_asset_fr_df( + i = NULL, + folder_df = NULL, + target_dir = tempdir(), + add_folder_subdir = TRUE, + overwrite = TRUE, + make_portable_fn = FALSE, + timeout_secs = REQUEST_TIMEOUT_VERY_LONG, + vb = options::opt("vb"), + rq = NULL +) +} +\arguments{ +\item{i}{Integer. Index of the asset within \code{folder_df}.} + +\item{folder_df}{Data frame containing folder asset metadata.} + +\item{target_dir}{Base directory for downloads.} + +\item{add_folder_subdir}{Logical. When \code{TRUE}, creates a subdirectory per +folder inside \code{target_dir}.} + +\item{overwrite}{Logical. When \code{FALSE}, existing files are saved with a +timestamped suffix.} + +\item{make_portable_fn}{Logical. When \code{TRUE}, filenames are sanitized via +\code{make_fn_portable()}.} + +\item{timeout_secs}{Numeric. Timeout applied to the signed download request.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{Optional \code{httr2} request object reused to request signed links.} +} +\value{ +Path to the downloaded asset or \code{NULL} if the download fails. +} +\description{ +Helper used by \code{download_folder_assets_fr_df()} to fetch a single asset via +the signed-download workflow. +} diff --git a/man/download_single_session_asset_fr_df.Rd b/man/download_single_session_asset_fr_df.Rd index 72d3a795..0bdd37ad 100644 --- a/man/download_single_session_asset_fr_df.Rd +++ b/man/download_single_session_asset_fr_df.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/download_single_session_asset_fr_df.R \name{download_single_session_asset_fr_df} \alias{download_single_session_asset_fr_df} -\title{Download Single Asset From Databrary} +\title{Download a Single Asset From a Session Data Frame Row.} \usage{ download_single_session_asset_fr_df( i = NULL, @@ -17,53 +17,31 @@ download_single_session_asset_fr_df( ) } \arguments{ -\item{i}{An integer. Index into a row of the session asset data frame. -Default is NULL.} +\item{i}{Integer. Index of the asset within \code{session_df}.} -\item{session_df}{A row from a data frame from \code{list_session_assets()} -or \code{list_volume_assets()}. Default is NULL>} +\item{session_df}{Data frame containing asset metadata.} -\item{target_dir}{A character string. Directory to save the downloaded file. -Default is a temporary directory given by a call to \code{tempdir()}.} +\item{target_dir}{Base directory for downloads.} -\item{add_session_subdir}{A logical value. Add add the session name to the -file path so that files are in a subdirectory specific to the session. Default -is TRUE.} +\item{add_session_subdir}{Logical. When \code{TRUE}, creates a subdirectory per +session inside \code{target_dir}.} -\item{overwrite}{A logical value. Overwrite an existing file. Default is TRUE.} +\item{overwrite}{Logical. When \code{FALSE}, existing files are saved with a +timestamped suffix.} -\item{make_portable_fn}{A logical value. Replace characters in file names -that are not broadly portable across file systems. Default is FALSE.} +\item{make_portable_fn}{Logical. When \code{TRUE}, filenames are sanitized via +\code{make_fn_portable()}.} -\item{timeout_secs}{An integer. The seconds an httr2 request will run before -timing out. Default is 600 (10 min). This is to handle very large files.} +\item{timeout_secs}{Numeric. Timeout applied to the signed download request.} \item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} -\item{rq}{A list in the form of an \code{httr2} request object. Default is NULL.} +\item{rq}{Optional \code{httr2} request object reused to request signed links.} } \value{ -Full file name to the asset or NULL. +Path to the downloaded asset or \code{NULL} if the download fails. } \description{ -Databrary stores file types (assets) of many types. This -function downloads an asset based on its system-unique integer identifer -(asset_id) and system-unique session (slot) identifier (session_id). It -is designed to work with download_session_assets_fr_df() so that multiple -files can be downloaded simultaneously. -} -\examples{ -\donttest{ -\dontrun{ -vol_1 <- list_session_assets(session_id = 9807) -a_1 <- vol_1[1,] -tmp_dir <- tempdir() -fn <- file.path(tmp_dir, paste0(a_1$asset_name, ".", a_1$format_extension)) -download_single_session_asset_fr_df(a_1$asset_id, - fn, - session_id = a_1$session_id, - vb = TRUE) - -} -} +Helper used by \code{download_session_assets_fr_df()} to fetch a single asset via +the signed-download workflow. } diff --git a/man/download_video.Rd b/man/download_video.Rd index f958cf82..a7796623 100644 --- a/man/download_video.Rd +++ b/man/download_video.Rd @@ -2,43 +2,48 @@ % Please edit documentation in R/download_video.R \name{download_video} \alias{download_video} -\title{Download Video From Databrary.} +\title{Download a Video Asset via Signed URL.} \usage{ download_video( - asset_id = 1, + vol_id = 1, session_id = 9807, - file_name = tempfile(paste0(session_id, "_", asset_id, "_"), fileext = ".mp4"), + asset_id = 1, + file_name = NULL, target_dir = tempdir(), vb = options::opt("vb"), rq = NULL ) } \arguments{ -\item{asset_id}{Asset id for target file.} +\item{vol_id}{Volume identifier containing the session.} + +\item{session_id}{Session identifier containing the asset.} -\item{session_id}{Slot/session number where target file is stored.} +\item{asset_id}{Asset identifier for the video file.} -\item{file_name}{Name for downloaded file.} +\item{file_name}{Optional explicit file name. Defaults to the API-provided +value.} -\item{target_dir}{Directory to save the downloaded file. -Default is a temporary directory given by a call to \code{tempdir()}.} +\item{target_dir}{Directory to save the downloaded file. Defaults to +\code{tempdir()}.} \item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} -\item{rq}{An \code{httr2} request object.} +\item{rq}{Optional \code{httr2} request object reused when requesting the signed +link.} } \value{ -Full file name to the asset. +Path to the downloaded video or \code{NULL} on failure. } \description{ -Download Video From Databrary. +Download a Video Asset via Signed URL. } \examples{ \donttest{ \dontrun{ -download_video() # Download's 'numbers' file from volume 1. -download_video(asset_id = 11643, session_id = 9825, file_name = "rdk.mp4") -#' # Downloads a display with a random dot kinematogram (RDK). +download_video() # Default public video from volume 1 +download_video(vol_id = 1, session_id = 9825, asset_id = 11643, + file_name = "rdk.mp4") } } diff --git a/man/download_volume_zip.Rd b/man/download_volume_zip.Rd index 180a1cb3..c6034724 100644 --- a/man/download_volume_zip.Rd +++ b/man/download_volume_zip.Rd @@ -2,37 +2,32 @@ % Please edit documentation in R/download_volume_zip.R \name{download_volume_zip} \alias{download_volume_zip} -\title{Download Zip Archive of All Data in a Volume.} +\title{Request a Signed ZIP Download for a Volume.} \usage{ -download_volume_zip( - vol_id = 31, - out_dir = tempdir(), - file_name = "test.zip", - vb = options::opt("vb"), - rq = NULL -) +download_volume_zip(vol_id = 31, vb = options::opt("vb"), rq = NULL) } \arguments{ -\item{vol_id}{Volume number.} - -\item{out_dir}{Directory to save output file.} - -\item{file_name}{Name for downloaded file, default is 'test.mp4'.} +\item{vol_id}{Volume identifier.} \item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} -\item{rq}{An \code{httr2} request object. Default is NULL.} +\item{rq}{An \code{httr2} request object. Default is \code{NULL}, in which case a +default authenticated request is generated.} } \value{ -Full filename of the downloaded file. +A list describing the processing task (\code{status}, \code{message}, +\code{task_id}) or \code{NULL} when the request fails. } \description{ -Download Zip Archive of All Data in a Volume. +Volume-level ZIP archives are prepared asynchronously by the Django API. +Calling \code{download_volume_zip()} queues the job and returns a processing task +descriptor. When the archive is ready, Databrary emails a signed download +link to the authenticated user. } \examples{ \donttest{ \dontrun{ -download_volume_zip() # Zip file of all data from volume 31, the default. +download_volume_zip(vol_id = 31) } } diff --git a/tests/testthat/test-download_folder_asset.R b/tests/testthat/test-download_folder_asset.R new file mode 100644 index 00000000..279a2b6d --- /dev/null +++ b/tests/testthat/test-download_folder_asset.R @@ -0,0 +1,70 @@ +# download_folder_asset ------------------------------------------------------- +test_that("download_folder_asset rejects bad input parameters", { + expect_error(download_folder_asset(vol_id = -1)) + expect_error(download_folder_asset(vol_id = 0)) + expect_error(download_folder_asset(vol_id = "a")) + expect_error(download_folder_asset(vol_id = list(a = 1, b = 2))) + expect_error(download_folder_asset(vol_id = TRUE)) + + expect_error(download_folder_asset(folder_id = -1)) + expect_error(download_folder_asset(folder_id = 0)) + expect_error(download_folder_asset(folder_id = "a")) + expect_error(download_folder_asset(folder_id = list(a = 1, b = 2))) + expect_error(download_folder_asset(folder_id = TRUE)) + + expect_error(download_folder_asset(asset_id = -1)) + expect_error(download_folder_asset(asset_id = 0)) + expect_error(download_folder_asset(asset_id = "a")) + expect_error(download_folder_asset(asset_id = list(a = 1, b = 2))) + expect_error(download_folder_asset(asset_id = TRUE)) + + expect_error(download_folder_asset(file_name = 3)) + expect_error(download_folder_asset(file_name = list(a = 1, b = 2))) + expect_error(download_folder_asset(file_name = TRUE)) + + expect_error(download_folder_asset(target_dir = 3)) + expect_error(download_folder_asset(target_dir = list(a = 1, b = 2))) + expect_error(download_folder_asset(target_dir = TRUE)) + + expect_error(download_folder_asset(timeout_secs = -1)) + expect_error(download_folder_asset(timeout_secs = 0)) + expect_error(download_folder_asset(timeout_secs = list(1, 2))) + + expect_error(download_folder_asset(vb = -1)) + expect_error(download_folder_asset(vb = 3)) + expect_error(download_folder_asset(vb = "a")) + expect_error(download_folder_asset(vb = list(a = 1, b = 2))) + + expect_error(download_folder_asset(rq = "a")) + expect_error(download_folder_asset(rq = -1)) + expect_error(download_folder_asset(rq = c(2, 3))) + expect_error(download_folder_asset(rq = list(a = 1, b = 2))) +}) + +test_that("download_folder_asset fetches signed link", { + tmp_dir <- tempdir() + fake_link <- list(download_url = "https://example.com/file.bin", file_name = "example.bin") + class(fake_link) <- c("databrary_signed_download", "list") + + captured_path <- NULL + captured_dest <- NULL + + result <- with_mocked_bindings( + download_folder_asset(vol_id = 1, folder_id = 2, asset_id = 3, target_dir = tmp_dir), + request_signed_download_link = function(path, rq = NULL, vb = FALSE) { + captured_path <<- path + fake_link + }, + download_signed_file = function(download_url, dest_path, timeout_secs = REQUEST_TIMEOUT, vb = FALSE) { + captured_dest <<- dest_path + dest_path + } + ) + + expect_true(grepl("example.bin$", result)) + expect_equal(result, captured_dest) + expect_equal(captured_path, sprintf("/volumes/%s/folders/%s/files/%s/download-link/", 1, 2, 3)) +}) + + + diff --git a/tests/testthat/test-download_folder_assets_fr_df.R b/tests/testthat/test-download_folder_assets_fr_df.R new file mode 100644 index 00000000..ccb4485e --- /dev/null +++ b/tests/testthat/test-download_folder_assets_fr_df.R @@ -0,0 +1,65 @@ +# download_folder_assets_fr_df ----------------------------------------------- +test_that("download_folder_assets_fr_df rejects bad input parameters", { + expect_error(download_folder_assets_fr_df(folder_df = 3)) + expect_error(download_folder_assets_fr_df(folder_df = "a")) + expect_error(download_folder_assets_fr_df(folder_df = TRUE)) + + missing_cols <- data.frame(vol_id = 1, folder_id = 1, asset_id = 1) + expect_error(download_folder_assets_fr_df(folder_df = missing_cols)) + + expect_error(download_folder_assets_fr_df(target_dir = 3)) + expect_error(download_folder_assets_fr_df(target_dir = list(a = 1, b = 2))) + expect_error(download_folder_assets_fr_df(target_dir = TRUE)) + + expect_error(download_folder_assets_fr_df(add_folder_subdir = -1)) + expect_error(download_folder_assets_fr_df(add_folder_subdir = 3)) + expect_error(download_folder_assets_fr_df(add_folder_subdir = "a")) + expect_error(download_folder_assets_fr_df(add_folder_subdir = list(a = 1, b = 2))) + + expect_error(download_folder_assets_fr_df(overwrite = -1)) + expect_error(download_folder_assets_fr_df(overwrite = 3)) + expect_error(download_folder_assets_fr_df(overwrite = "a")) + expect_error(download_folder_assets_fr_df(overwrite = list(a = 1, b = 2))) + + expect_error(download_folder_assets_fr_df(make_portable_fn = -1)) + expect_error(download_folder_assets_fr_df(make_portable_fn = 3)) + expect_error(download_folder_assets_fr_df(make_portable_fn = "a")) + expect_error(download_folder_assets_fr_df(make_portable_fn = list(a = 1, b = 2))) + + expect_error(download_folder_assets_fr_df(timeout_secs = -1)) + expect_error(download_folder_assets_fr_df(timeout_secs = TRUE)) + expect_error(download_folder_assets_fr_df(timeout_secs = "a")) + expect_error(download_folder_assets_fr_df(timeout_secs = list(a = 1, b = 2))) + + expect_error(download_folder_assets_fr_df(vb = -1)) + expect_error(download_folder_assets_fr_df(vb = 3)) + expect_error(download_folder_assets_fr_df(vb = "a")) + expect_error(download_folder_assets_fr_df(vb = list(a = 1, b = 2))) + + expect_error(download_folder_assets_fr_df(rq = "a")) + expect_error(download_folder_assets_fr_df(rq = -1)) + expect_error(download_folder_assets_fr_df(rq = c(1, 2))) + expect_error(download_folder_assets_fr_df(rq = list(a = 1, b = 2))) +}) + +test_that("download_folder_assets_fr_df iterates rows", { + folder_df <- tibble::tibble( + vol_id = c(1, 1), + folder_id = c(2, 2), + asset_id = c(3, 4), + asset_name = c("file_a", "file_b") + ) + + calls <- list() + results <- with_mocked_bindings( + download_folder_assets_fr_df(folder_df = folder_df, target_dir = tempdir(), vb = FALSE), + download_single_folder_asset_fr_df = function(i, folder_df, ...) { + calls[[length(calls) + 1]] <<- list(i = i, folder_df = folder_df) + paste0("path-", i) + } + ) + + expect_equal(results, c("path-1", "path-2")) + expect_equal(vapply(calls, function(x) x$i, numeric(1)), c(1, 2)) +}) + diff --git a/tests/testthat/test-download_folder_zip.R b/tests/testthat/test-download_folder_zip.R new file mode 100644 index 00000000..519da6c0 --- /dev/null +++ b/tests/testthat/test-download_folder_zip.R @@ -0,0 +1,41 @@ +# download_folder_zip --------------------------------------------------------- +test_that("download_folder_zip rejects bad input parameters", { + expect_error(download_folder_zip(vol_id = -1)) + expect_error(download_folder_zip(vol_id = 0)) + expect_error(download_folder_zip(vol_id = "a")) + expect_error(download_folder_zip(vol_id = list(a = 1, b = 2))) + expect_error(download_folder_zip(vol_id = TRUE)) + + expect_error(download_folder_zip(folder_id = -1)) + expect_error(download_folder_zip(folder_id = 0)) + expect_error(download_folder_zip(folder_id = "a")) + expect_error(download_folder_zip(folder_id = list(a = 1, b = 2))) + expect_error(download_folder_zip(folder_id = TRUE)) + + expect_error(download_folder_zip(vb = -1)) + expect_error(download_folder_zip(vb = 3)) + expect_error(download_folder_zip(vb = "a")) + expect_error(download_folder_zip(vb = list(a = 1, b = 2))) + + expect_error(download_folder_zip(rq = "a")) + expect_error(download_folder_zip(rq = -1)) + expect_error(download_folder_zip(rq = c(1, 2))) +}) + +test_that("download_folder_zip returns processing task", { + captured_path <- NULL + fake_task <- list(status = "processing", message = "queued", task_id = "xyz") + task <- with_mocked_bindings( + download_folder_zip(vol_id = 2, folder_id = 5), + request_processing_task = function(path, rq = NULL, vb = FALSE) { + captured_path <<- path + fake_task + } + ) + + expect_identical(task, fake_task) + expect_equal(captured_path, sprintf("/volumes/%s/folders/%s/download-link/", 2, 5)) +}) + + + diff --git a/tests/testthat/test-download_session_asset.R b/tests/testthat/test-download_session_asset.R index ec241871..b61aa708 100644 --- a/tests/testthat/test-download_session_asset.R +++ b/tests/testthat/test-download_session_asset.R @@ -1,32 +1,42 @@ # download_session_asset --------------------------------------------------------- test_that("download_session_asset rejects bad input parameters", { + expect_error(download_session_asset(vol_id = -1)) + expect_error(download_session_asset(vol_id = 0)) + expect_error(download_session_asset(vol_id = "a")) + expect_error(download_session_asset(vol_id = list(a = 1, b = 2))) + expect_error(download_session_asset(vol_id = TRUE)) + expect_error(download_session_asset(asset_id = -1)) expect_error(download_session_asset(asset_id = 0)) expect_error(download_session_asset(asset_id = "a")) - expect_error(download_session_asset(asset_id = list(a=1, b=2))) + expect_error(download_session_asset(asset_id = list(a = 1, b = 2))) expect_error(download_session_asset(asset_id = TRUE)) - + expect_error(download_session_asset(session_id = -1)) expect_error(download_session_asset(session_id = 0)) expect_error(download_session_asset(session_id = "a")) - expect_error(download_session_asset(session_id = list(a=1, b=2))) + expect_error(download_session_asset(session_id = list(a = 1, b = 2))) expect_error(download_session_asset(session_id = TRUE)) - + expect_error(download_session_asset(file_name = 3)) - expect_error(download_session_asset(file_name = list(a=1, b=2))) + expect_error(download_session_asset(file_name = list(a = 1, b = 2))) expect_error(download_session_asset(file_name = TRUE)) - + expect_error(download_session_asset(target_dir = 3)) - expect_error(download_session_asset(target_dir = list(a=1, b=2))) + expect_error(download_session_asset(target_dir = list(a = 1, b = 2))) expect_error(download_session_asset(target_dir = TRUE)) - + + expect_error(download_session_asset(timeout_secs = -1)) + expect_error(download_session_asset(timeout_secs = 0)) + expect_error(download_session_asset(timeout_secs = list(1, 2))) + expect_error(download_session_asset(vb = -1)) expect_error(download_session_asset(vb = 3)) expect_error(download_session_asset(vb = "a")) - expect_error(download_session_asset(vb = list(a=1, b=2))) - + expect_error(download_session_asset(vb = list(a = 1, b = 2))) + expect_error(download_session_asset(rq = "a")) expect_error(download_session_asset(rq = -1)) - expect_error(download_session_asset(rq = c(2,3))) - expect_error(download_session_asset(rq = list(a=1, b=2))) + expect_error(download_session_asset(rq = c(2, 3))) + expect_error(download_session_asset(rq = list(a = 1, b = 2))) }) diff --git a/tests/testthat/test-download_session_assets_fr_df.R b/tests/testthat/test-download_session_assets_fr_df.R index 275f3937..fed17e64 100644 --- a/tests/testthat/test-download_session_assets_fr_df.R +++ b/tests/testthat/test-download_session_assets_fr_df.R @@ -1,43 +1,43 @@ # download_session_assets_fr_df --------------------------------------------------------- -test_that("download_session_assets_fr_df rejects bad input parameters", - { - expect_error(download_session_assets_fr_df(session_asset_entry = 3)) - expect_error(download_session_assets_fr_df(session_asset_entry = "a")) - expect_error(download_session_assets_fr_df(session_asset_entry = TRUE)) - expect_error(download_session_assets_fr_df(session_asset_entry = list(a = 1, b = - 2))) - expect_error(download_session_assets_fr_df(target_dir = 3)) - expect_error(download_session_assets_fr_df(target_dir = list(a = 1, b = - 2))) - expect_error(download_session_assets_fr_df(target_dir = TRUE)) - - expect_error(download_session_assets_fr_df(add_session_subdir = -1)) - expect_error(download_session_assets_fr_df(add_session_subdir = 3)) - expect_error(download_session_assets_fr_df(add_session_subdir = "a")) - expect_error(download_session_assets_fr_df(add_session_subdir = list(a = 1, b = 2))) - - expect_error(download_session_assets_fr_df(overwrite = -1)) - expect_error(download_session_assets_fr_df(overwrite = 3)) - expect_error(download_session_assets_fr_df(overwrite = "a")) - expect_error(download_session_assets_fr_df(overwrite = list(a = 1, b = 2))) - - expect_error(download_session_assets_fr_df(make_portable_fn = -1)) - expect_error(download_session_assets_fr_df(make_portable_fn = 3)) - expect_error(download_session_assets_fr_df(make_portable_fn = "a")) - expect_error(download_session_assets_fr_df(make_portable_fn = list(a = 1, b = 2))) - - expect_error(download_session_assets_fr_df(timeout_secs = -1)) - expect_error(download_session_assets_fr_df(timeout_secs = TRUE)) - expect_error(download_session_assest_fr_df(timeout_secs = "a")) - expect_error(download_session_assets_fr_df(timeout_secs = list(a = 1, b = 2))) - - expect_error(download_session_assets_fr_df(vb = -1)) - expect_error(download_session_assets_fr_df(vb = 3)) - expect_error(download_session_assets_fr_df(vb = "a")) - expect_error(download_session_assets_fr_df(vb = list(a = 1, b = 2))) - - expect_error(download_session_assets_fr_df(rq = "a")) - expect_error(download_session_assets_fr_df(rq = -1)) - expect_error(download_session_assets_fr_df(rq = c(2, 3))) - expect_error(download_session_assets_fr_df(rq = list(a = 1, b = 2))) - }) +test_that("download_session_assets_fr_df rejects bad input parameters", { + expect_error(download_session_assets_fr_df(session_df = 3)) + expect_error(download_session_assets_fr_df(session_df = "a")) + expect_error(download_session_assets_fr_df(session_df = TRUE)) + + missing_cols <- data.frame(vol_id = 1, session_id = 1, asset_id = 1) + expect_error(download_session_assets_fr_df(session_df = missing_cols)) + + expect_error(download_session_assets_fr_df(target_dir = 3)) + expect_error(download_session_assets_fr_df(target_dir = list(a = 1, b = 2))) + expect_error(download_session_assets_fr_df(target_dir = TRUE)) + + expect_error(download_session_assets_fr_df(add_session_subdir = -1)) + expect_error(download_session_assets_fr_df(add_session_subdir = 3)) + expect_error(download_session_assets_fr_df(add_session_subdir = "a")) + expect_error(download_session_assets_fr_df(add_session_subdir = list(a = 1, b = 2))) + + expect_error(download_session_assets_fr_df(overwrite = -1)) + expect_error(download_session_assets_fr_df(overwrite = 3)) + expect_error(download_session_assets_fr_df(overwrite = "a")) + expect_error(download_session_assets_fr_df(overwrite = list(a = 1, b = 2))) + + expect_error(download_session_assets_fr_df(make_portable_fn = -1)) + expect_error(download_session_assets_fr_df(make_portable_fn = 3)) + expect_error(download_session_assets_fr_df(make_portable_fn = "a")) + expect_error(download_session_assets_fr_df(make_portable_fn = list(a = 1, b = 2))) + + expect_error(download_session_assets_fr_df(timeout_secs = -1)) + expect_error(download_session_assets_fr_df(timeout_secs = TRUE)) + expect_error(download_session_assets_fr_df(timeout_secs = "a")) + expect_error(download_session_assets_fr_df(timeout_secs = list(a = 1, b = 2))) + + expect_error(download_session_assets_fr_df(vb = -1)) + expect_error(download_session_assets_fr_df(vb = 3)) + expect_error(download_session_assets_fr_df(vb = "a")) + expect_error(download_session_assets_fr_df(vb = list(a = 1, b = 2))) + + expect_error(download_session_assets_fr_df(rq = "a")) + expect_error(download_session_assets_fr_df(rq = -1)) + expect_error(download_session_assets_fr_df(rq = c(2, 3))) + expect_error(download_session_assets_fr_df(rq = list(a = 1, b = 2))) +}) diff --git a/tests/testthat/test-download_session_csv.R b/tests/testthat/test-download_session_csv.R index 2ee07590..8e7eaa09 100644 --- a/tests/testthat/test-download_session_csv.R +++ b/tests/testthat/test-download_session_csv.R @@ -3,24 +3,51 @@ test_that("download_session_csv rejects bad input parameters", { expect_error(download_session_csv(vol_id = -1)) expect_error(download_session_csv(vol_id = 0)) expect_error(download_session_csv(vol_id = "a")) - expect_error(download_session_csv(vol_id = list(a=1, b=2))) + expect_error(download_session_csv(vol_id = list(a = 1, b = 2))) expect_error(download_session_csv(vol_id = TRUE)) - - expect_error(download_session_csv(file_name = 3)) - expect_error(download_session_csv(file_name = list(a=1, b=2))) - expect_error(download_session_csv(file_name = TRUE)) - - expect_error(download_session_csv(target_dir = 3)) - expect_error(download_session_csv(target_dir = list(a=1, b=2))) - expect_error(download_session_csv(target_dir = TRUE)) - expect_error(download_session_csv(as_df = -1)) - expect_error(download_session_csv(as_df = 3)) - expect_error(download_session_csv(as_df = "a")) - expect_error(download_session_csv(as_df = list(a=1, b=2))) - + expect_error(download_session_csv(session_id = -1)) + expect_error(download_session_csv(session_id = 0)) + expect_error(download_session_csv(session_id = "a")) + expect_error(download_session_csv(session_id = list(a = 1, b = 2))) + expect_error(download_session_csv(session_id = TRUE)) + expect_error(download_session_csv(vb = -1)) expect_error(download_session_csv(vb = 3)) expect_error(download_session_csv(vb = "a")) - expect_error(download_session_csv(vb = list(a=1, b=2))) + expect_error(download_session_csv(vb = list(a = 1, b = 2))) + + expect_error(download_session_csv(rq = "a")) + expect_error(download_session_csv(rq = -1)) + expect_error(download_session_csv(rq = c(1, 2))) +}) + +test_that("download_session_csv returns volume processing task", { + captured_path <- NULL + fake_task <- list(status = "processing", message = "queued", task_id = "abc") + task <- with_mocked_bindings( + download_session_csv(), + request_processing_task = function(path, rq = NULL, vb = FALSE) { + captured_path <<- path + fake_task + } + ) + + expect_identical(task, fake_task) + expect_equal(captured_path, sprintf("/volumes/%s/csv-download-link/", 1)) +}) + +test_that("download_session_csv returns session processing task", { + captured_path <- NULL + fake_task <- list(status = "processing", message = "queued", task_id = "def") + task <- with_mocked_bindings( + download_session_csv(vol_id = 2, session_id = 11), + request_processing_task = function(path, rq = NULL, vb = FALSE) { + captured_path <<- path + fake_task + } + ) + + expect_identical(task, fake_task) + expect_equal(captured_path, sprintf("/volumes/%s/sessions/%s/csv-download-link/", 2, 11)) }) diff --git a/tests/testthat/test-download_session_zip.R b/tests/testthat/test-download_session_zip.R index 91bd6f68..34038857 100644 --- a/tests/testthat/test-download_session_zip.R +++ b/tests/testthat/test-download_session_zip.R @@ -2,29 +2,38 @@ test_that("download_session_zip rejects bad input parameters", { expect_error(download_session_zip(vol_id = -1)) expect_error(download_session_zip(vol_id = "a")) - expect_error(download_session_zip(vol_id = list(a=1, b=2))) + expect_error(download_session_zip(vol_id = list(a = 1, b = 2))) expect_error(download_session_zip(vol_id = TRUE)) - + expect_error(download_session_zip(session_id = -1)) expect_error(download_session_zip(session_id = "a")) - expect_error(download_session_zip(session_id = list(a=1, b=2))) + expect_error(download_session_zip(session_id = list(a = 1, b = 2))) expect_error(download_session_zip(session_id = TRUE)) - - expect_error(download_session_zip(out_dir = -1)) - expect_error(download_session_zip(out_dir = list(a=1, b=2))) - expect_error(download_session_zip(out_dir = TRUE)) - - expect_error(download_session_zip(file_name = -1)) - expect_error(download_session_zip(file_name = list(a=1, b=2))) - expect_error(download_session_zip(file_name = TRUE)) - + expect_error(download_session_zip(vb = -1)) expect_error(download_session_zip(vb = 3)) expect_error(download_session_zip(vb = "a")) - expect_error(download_session_zip(vb = list(a=1, b=2))) + expect_error(download_session_zip(vb = list(a = 1, b = 2))) + + expect_error(download_session_zip(rq = "a")) + expect_error(download_session_zip(rq = -1)) + expect_error(download_session_zip(rq = c(1, 2))) }) -test_that("download_session_zip returns string", { - testthat::skip("Download route still under migration to Django signed-link workflow") - expect_true(is.character(download_session_zip())) +test_that("download_session_zip returns processing task", { + captured_path <- NULL + fake_task <- list(status = "processing", message = "queued", task_id = "abc") + task <- with_mocked_bindings( + download_session_zip(), + request_processing_task = function(path, rq = NULL, vb = FALSE) { + captured_path <<- path + fake_task + } + ) + + expect_identical(task, fake_task) + expect_equal( + captured_path, + sprintf("/volumes/%s/sessions/%s/download-link/", 31, 9803) + ) }) diff --git a/tests/testthat/test-download_single_folder_asset_fr_df.R b/tests/testthat/test-download_single_folder_asset_fr_df.R new file mode 100644 index 00000000..91b31a25 --- /dev/null +++ b/tests/testthat/test-download_single_folder_asset_fr_df.R @@ -0,0 +1,79 @@ +# download_single_folder_asset_fr_df ---------------------------------------- +test_that("download_single_folder_asset_fr_df rejects bad input parameters", { + expect_error(download_single_folder_asset_fr_df(i = 0)) + expect_error(download_single_folder_asset_fr_df(i = -1)) + expect_error(download_single_folder_asset_fr_df(i = "a")) + + expect_error(download_single_folder_asset_fr_df(i = 1, folder_df = 3)) + expect_error(download_single_folder_asset_fr_df(i = 1, folder_df = "a")) + expect_error(download_single_folder_asset_fr_df(i = 1, folder_df = TRUE)) + + missing_cols <- data.frame(vol_id = 1, folder_id = 1, asset_id = 1) + expect_error(download_single_folder_asset_fr_df(i = 1, folder_df = missing_cols)) + + expect_error(download_single_folder_asset_fr_df(i = 1, target_dir = 3)) + expect_error(download_single_folder_asset_fr_df(i = 1, target_dir = list(a = 1, b = 2))) + expect_error(download_single_folder_asset_fr_df(i = 1, target_dir = TRUE)) + + expect_error(download_single_folder_asset_fr_df(i = 1, add_folder_subdir = -1)) + expect_error(download_single_folder_asset_fr_df(i = 1, add_folder_subdir = 3)) + expect_error(download_single_folder_asset_fr_df(i = 1, add_folder_subdir = "a")) + expect_error(download_single_folder_asset_fr_df(i = 1, add_folder_subdir = list(a = 1, b = 2))) + + expect_error(download_single_folder_asset_fr_df(i = 1, overwrite = -1)) + expect_error(download_single_folder_asset_fr_df(i = 1, overwrite = 3)) + expect_error(download_single_folder_asset_fr_df(i = 1, overwrite = "a")) + expect_error(download_single_folder_asset_fr_df(i = 1, overwrite = list(a = 1, b = 2))) + + expect_error(download_single_folder_asset_fr_df(i = 1, make_portable_fn = -1)) + expect_error(download_single_folder_asset_fr_df(i = 1, make_portable_fn = 3)) + expect_error(download_single_folder_asset_fr_df(i = 1, make_portable_fn = "a")) + expect_error(download_single_folder_asset_fr_df(i = 1, make_portable_fn = list(a = 1, b = 2))) + + expect_error(download_single_folder_asset_fr_df(i = 1, timeout_secs = -1)) + expect_error(download_single_folder_asset_fr_df(i = 1, timeout_secs = TRUE)) + expect_error(download_single_folder_asset_fr_df(i = 1, timeout_secs = "a")) + expect_error(download_single_folder_asset_fr_df(i = 1, timeout_secs = list(a = 1, b = 2))) + + expect_error(download_single_folder_asset_fr_df(i = 1, vb = -1)) + expect_error(download_single_folder_asset_fr_df(i = 1, vb = 3)) + expect_error(download_single_folder_asset_fr_df(i = 1, vb = "a")) + expect_error(download_single_folder_asset_fr_df(i = 1, vb = list(a = 1, b = 2))) + + expect_error(download_single_folder_asset_fr_df(i = 1, rq = "a")) + expect_error(download_single_folder_asset_fr_df(i = 1, rq = -1)) + expect_error(download_single_folder_asset_fr_df(i = 1, rq = c(2, 3))) + expect_error(download_single_folder_asset_fr_df(i = 1, rq = list(a = 1, b = 2))) +}) + +test_that("download_single_folder_asset_fr_df delegates to download_folder_asset", { + folder_df <- tibble::tibble( + vol_id = 1, + folder_id = 2, + asset_id = 3, + asset_name = "demo", + format_extension = "txt" + ) + + captured <- NULL + result <- with_mocked_bindings( + download_single_folder_asset_fr_df(i = 1, folder_df = folder_df, target_dir = tempdir()), + download_folder_asset = function(vol_id, folder_id, asset_id, file_name, target_dir, ...) { + captured <<- list( + vol_id = vol_id, + folder_id = folder_id, + asset_id = asset_id, + file_name = file_name, + target_dir = target_dir + ) + "downloaded-path" + } + ) + + expect_equal(result, "downloaded-path") + expect_equal(captured$vol_id, 1) + expect_equal(captured$folder_id, 2) + expect_equal(captured$asset_id, 3) + expect_true(grepl("demo.txt$", captured$file_name)) +}) + diff --git a/tests/testthat/test-download_single_session_asset_fr_df.R b/tests/testthat/test-download_single_session_asset_fr_df.R index 8cec8e34..263cccb8 100644 --- a/tests/testthat/test-download_single_session_asset_fr_df.R +++ b/tests/testthat/test-download_single_session_asset_fr_df.R @@ -1,44 +1,47 @@ # download_single_session_asset_fr_df --------------------------------------------------------- -test_that("download_single_session_asset_fr_df rejects bad input parameters", - { - expect_error(download_single_session_asset_fr_df(session_asset_entry = 3)) - expect_error(download_single_session_asset_fr_df(session_asset_entry = "a")) - expect_error(download_single_session_asset_fr_df(session_asset_entry = TRUE)) - expect_error(download_single_session_asset_fr_df(session_asset_entry = list(a = 1, b = - 2))) - - expect_error(download_single_session_asset_fr_df(target_dir = 3)) - expect_error(download_single_session_asset_fr_df(target_dir = list(a = 1, b = - 2))) - expect_error(download_single_session_asset_fr_df(target_dir = TRUE)) - - expect_error(download_single_session_asset_fr_df(add_session_subdir = -1)) - expect_error(download_single_session_asset_fr_df(add_session_subdir = 3)) - expect_error(download_single_session_asset_fr_df(add_session_subdir = "a")) - expect_error(download_single_session_asset_fr_df(add_session_subdir = list(a = 1, b = 2))) - - expect_error(download_single_session_asset_fr_df(overwrite = -1)) - expect_error(download_single_session_asset_fr_df(overwrite = 3)) - expect_error(download_single_session_asset_fr_df(overwrite = "a")) - expect_error(download_single_session_asset_fr_df(overwrite = list(a = 1, b = 2))) - - expect_error(download_single_session_asset_fr_df(make_portable_fn = -1)) - expect_error(download_single_session_asset_fr_df(make_portable_fn = 3)) - expect_error(download_single_session_asset_fr_df(make_portable_fn = "a")) - expect_error(download_single_session_asset_fr_df(make_portable_fn = list(a = 1, b = 2))) - - expect_error(download_single_session_asset_fr_df(timeout_secs = -1)) - expect_error(download_single_session_asset_fr_df(timeout_secs = TRUE)) - expect_error(download_single_session_asset_fr_df(timeout_secs = "a")) - expect_error(download_single_session_asset_fr_df(timeout_secs = list(a = 1, b = 2))) - - expect_error(download_single_session_asset_fr_df(vb = -1)) - expect_error(download_single_session_asset_fr_df(vb = 3)) - expect_error(download_single_session_asset_fr_df(vb = "a")) - expect_error(download_single_session_asset_fr_df(vb = list(a = 1, b = 2))) - - expect_error(download_single_session_asset_fr_df(rq = "a")) - expect_error(download_single_session_asset_fr_df(rq = -1)) - expect_error(download_single_session_asset_fr_df(rq = c(2, 3))) - expect_error(download_single_session_asset_fr_df(rq = list(a = 1, b = 2))) - }) +test_that("download_single_session_asset_fr_df rejects bad input parameters", { + expect_error(download_single_session_asset_fr_df(i = 0)) + expect_error(download_single_session_asset_fr_df(i = -1)) + expect_error(download_single_session_asset_fr_df(i = "a")) + + expect_error(download_single_session_asset_fr_df(session_df = 3)) + expect_error(download_single_session_asset_fr_df(session_df = "a")) + expect_error(download_single_session_asset_fr_df(session_df = TRUE)) + + missing_cols <- data.frame(vol_id = 1, session_id = 1, asset_id = 1) + expect_error(download_single_session_asset_fr_df(i = 1, session_df = missing_cols)) + + expect_error(download_single_session_asset_fr_df(i = 1, target_dir = 3)) + expect_error(download_single_session_asset_fr_df(i = 1, target_dir = list(a = 1, b = 2))) + expect_error(download_single_session_asset_fr_df(i = 1, target_dir = TRUE)) + + expect_error(download_single_session_asset_fr_df(i = 1, add_session_subdir = -1)) + expect_error(download_single_session_asset_fr_df(i = 1, add_session_subdir = 3)) + expect_error(download_single_session_asset_fr_df(i = 1, add_session_subdir = "a")) + expect_error(download_single_session_asset_fr_df(i = 1, add_session_subdir = list(a = 1, b = 2))) + + expect_error(download_single_session_asset_fr_df(i = 1, overwrite = -1)) + expect_error(download_single_session_asset_fr_df(i = 1, overwrite = 3)) + expect_error(download_single_session_asset_fr_df(i = 1, overwrite = "a")) + expect_error(download_single_session_asset_fr_df(i = 1, overwrite = list(a = 1, b = 2))) + + expect_error(download_single_session_asset_fr_df(i = 1, make_portable_fn = -1)) + expect_error(download_single_session_asset_fr_df(i = 1, make_portable_fn = 3)) + expect_error(download_single_session_asset_fr_df(i = 1, make_portable_fn = "a")) + expect_error(download_single_session_asset_fr_df(i = 1, make_portable_fn = list(a = 1, b = 2))) + + expect_error(download_single_session_asset_fr_df(i = 1, timeout_secs = -1)) + expect_error(download_single_session_asset_fr_df(i = 1, timeout_secs = TRUE)) + expect_error(download_single_session_asset_fr_df(i = 1, timeout_secs = "a")) + expect_error(download_single_session_asset_fr_df(i = 1, timeout_secs = list(a = 1, b = 2))) + + expect_error(download_single_session_asset_fr_df(i = 1, vb = -1)) + expect_error(download_single_session_asset_fr_df(i = 1, vb = 3)) + expect_error(download_single_session_asset_fr_df(i = 1, vb = "a")) + expect_error(download_single_session_asset_fr_df(i = 1, vb = list(a = 1, b = 2))) + + expect_error(download_single_session_asset_fr_df(i = 1, rq = "a")) + expect_error(download_single_session_asset_fr_df(i = 1, rq = -1)) + expect_error(download_single_session_asset_fr_df(i = 1, rq = c(2, 3))) + expect_error(download_single_session_asset_fr_df(i = 1, rq = list(a = 1, b = 2))) +}) diff --git a/tests/testthat/test-download_video.R b/tests/testthat/test-download_video.R index 90af42ee..41f11d70 100644 --- a/tests/testthat/test-download_video.R +++ b/tests/testthat/test-download_video.R @@ -1,29 +1,41 @@ # download_video --------------------------------------------------------- test_that("download_video rejects bad input parameters", { - expect_error(download_asset(asset_id = -1)) - expect_error(download_asset(asset_id = 0)) - expect_error(download_asset(asset_id = "a")) - expect_error(download_asset(asset_id = list(a=1, b=2))) - expect_error(download_asset(asset_id = TRUE)) - - expect_error(download_asset(session_id = -1)) - expect_error(download_asset(session_id = 0)) - expect_error(download_asset(session_id = "a")) - expect_error(download_asset(session_id = list(a=1, b=2))) - expect_error(download_asset(session_id = TRUE)) + expect_error(download_video(vol_id = -1)) + expect_error(download_video(vol_id = 0)) + expect_error(download_video(vol_id = "a")) + expect_error(download_video(vol_id = list(a = 1, b = 2))) + expect_error(download_video(vol_id = TRUE)) + + expect_error(download_video(asset_id = -1)) + expect_error(download_video(asset_id = 0)) + expect_error(download_video(asset_id = "a")) + expect_error(download_video(asset_id = list(a = 1, b = 2))) + expect_error(download_video(asset_id = TRUE)) + + expect_error(download_video(session_id = -1)) + expect_error(download_video(session_id = 0)) + expect_error(download_video(session_id = "a")) + expect_error(download_video(session_id = list(a = 1, b = 2))) + expect_error(download_video(session_id = TRUE)) expect_error(download_video(file_name = 3)) - expect_error(download_video(file_name = list(a=1, b=2))) + expect_error(download_video(file_name = list(a = 1, b = 2))) expect_error(download_video(file_name = TRUE)) - + expect_error(download_video(file_name = "not_mp3")) + expect_error(download_video(target_dir = 3)) - expect_error(download_video(target_dir = list(a=1, b=2))) + expect_error(download_video(target_dir = list(a = 1, b = 2))) expect_error(download_video(target_dir = TRUE)) - + expect_error(download_video(vb = -1)) expect_error(download_video(vb = 3)) expect_error(download_video(vb = "a")) - expect_error(download_video(vb = list(a=1, b=2))) + expect_error(download_video(vb = list(a = 1, b = 2))) + + expect_error(download_video(rq = "a")) + expect_error(download_video(rq = -1)) + expect_error(download_video(rq = c(1, 2))) + expect_error(download_video(rq = list(a = 1, b = 2))) }) # Removing 2023-10-09 until Databrary system responds more quickly diff --git a/tests/testthat/test-download_volume_zip.R b/tests/testthat/test-download_volume_zip.R index 8c0bc589..35c5e254 100644 --- a/tests/testthat/test-download_volume_zip.R +++ b/tests/testthat/test-download_volume_zip.R @@ -2,25 +2,31 @@ test_that("download_volume_zip rejects bad input parameters", { expect_error(download_volume_zip(vol_id = -1)) expect_error(download_volume_zip(vol_id = "a")) - expect_error(download_volume_zip(vol_id = list(a=1, b=2))) + expect_error(download_volume_zip(vol_id = list(a = 1, b = 2))) expect_error(download_volume_zip(vol_id = TRUE)) - - expect_error(download_volume_zip(out_dir = -1)) - expect_error(download_volume_zip(out_dir = list(a=1, b=2))) - expect_error(download_volume_zip(out_dir = TRUE)) - - expect_error(download_volume_zip(file_name = -1)) - expect_error(download_volume_zip(file_name = list(a=1, b=2))) - expect_error(download_volume_zip(file_name = TRUE)) - + expect_error(download_volume_zip(vb = -1)) expect_error(download_volume_zip(vb = 3)) expect_error(download_volume_zip(vb = "a")) - expect_error(download_volume_zip(vb = list(a=1, b=2))) + expect_error(download_volume_zip(vb = list(a = 1, b = 2))) + + expect_error(download_volume_zip(rq = "a")) + expect_error(download_volume_zip(rq = -1)) + expect_error(download_volume_zip(rq = c(1, 2))) }) -test_that("download_volume_zip returns string", { - testthat::skip("Download route still under migration to Django signed-link workflow") - expect_true(is.character(download_volume_zip())) +test_that("download_volume_zip returns processing task", { + captured_path <- NULL + fake_task <- list(status = "processing", message = "queued", task_id = "abc") + task <- with_mocked_bindings( + download_volume_zip(), + request_processing_task = function(path, rq = NULL, vb = FALSE) { + captured_path <<- path + fake_task + } + ) + + expect_identical(task, fake_task) + expect_equal(captured_path, sprintf("/volumes/%s/download-link/", 31)) }) From b4e3e3dacad97ce7b69a2fdc46de516371cad0bd Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Mon, 8 Dec 2025 13:57:37 +0100 Subject: [PATCH 04/27] fix(api): update get_db_stats to match new API response structure The Databrary API now returns different field names (institutions, affiliates, investigators, hours_of_recordings) instead of the legacy fields (authorized_users, total_volumes, etc.). Updated the function to map new fields while keeping legacy fields as NA for backwards compatibility. --- R/get_db_stats.R | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/R/get_db_stats.R b/R/get_db_stats.R index c42b7c14..239ac0f2 100644 --- a/R/get_db_stats.R +++ b/R/get_db_stats.R @@ -70,16 +70,23 @@ get_db_stats <- function(type = "stats", } if (type %in% c("stats", "numbers")) { + # Map new API field names to output tibble::tibble( date = Sys.time(), - investors = stats$authorized_users, - datasets_total = stats$total_volumes, - datasets_shared = stats$public_volumes, - n_files = stats$total_files, - hours = stats$total_duration_hours, - TB = stats$total_storage_tb + institutions = if (!is.null(stats$institutions)) stats$institutions else NA_integer_, + affiliates = if (!is.null(stats$affiliates)) stats$affiliates else NA_integer_, + investigators = if (!is.null(stats$investigators)) stats$investigators else NA_integer_, + hours_of_recordings = if (!is.null(stats$hours_of_recordings)) stats$hours_of_recordings else NA_integer_, + # Legacy fields (may not be present in new API) + authorized_users = if (!is.null(stats$authorized_users)) stats$authorized_users else NA_integer_, + total_volumes = if (!is.null(stats$total_volumes)) stats$total_volumes else NA_integer_, + public_volumes = if (!is.null(stats$public_volumes)) stats$public_volumes else NA_integer_, + total_files = if (!is.null(stats$total_files)) stats$total_files else NA_integer_, + total_duration_hours = if (!is.null(stats$total_duration_hours)) stats$total_duration_hours else NA_real_, + total_storage_tb = if (!is.null(stats$total_storage_tb)) stats$total_storage_tb else NA_real_ ) } else { - tibble::as_tibble(stats$recent_activity) + # For other types, return the raw stats as a tibble + tibble::as_tibble(stats) } } From 82366c6a7f8d9ed4cd0144a5aa101c8cf49d31df Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Wed, 10 Dec 2025 10:00:47 +0100 Subject: [PATCH 05/27] feat: add get_funder_by_id() for direct funder lookup by ID - Add API constant for funder detail endpoint - Implement get_funder_by_id() function - Add test suite (11 test cases) - Add function documentation --- NAMESPACE | 1 + R/CONSTANTS.R | 1 + R/get_funder_by_id.R | 67 +++++++++++++++ man/get_funder_by_id.Rd | 34 ++++++++ tests/testthat/test-get_funder_by_id.R | 111 +++++++++++++++++++++++++ 5 files changed, 214 insertions(+) create mode 100644 R/get_funder_by_id.R create mode 100644 man/get_funder_by_id.Rd create mode 100644 tests/testthat/test-get_funder_by_id.R diff --git a/NAMESPACE b/NAMESPACE index 765a14b6..d96b6c2e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,6 +18,7 @@ export(download_volume_zip) export(get_db_stats) export(get_file_duration) export(get_folder_by_id) +export(get_funder_by_id) export(get_institution_by_id) export(get_permission_levels) export(get_release_levels) diff --git a/R/CONSTANTS.R b/R/CONSTANTS.R index f6d676be..6f07bd57 100644 --- a/R/CONSTANTS.R +++ b/R/CONSTANTS.R @@ -40,6 +40,7 @@ API_SEARCH_VOLUMES <- "/search/volumes/" API_SEARCH_USERS <- "/search/users/" API_SEARCH_INSTITUTIONS <- "/search/institutions/" API_FUNDERS <- "/funders/" +API_FUNDER_DETAIL <- "/funders/%s/" RETRY_LIMIT <- 3 RETRY_WAIT_TIME <- 1 # seconds diff --git a/R/get_funder_by_id.R b/R/get_funder_by_id.R new file mode 100644 index 00000000..01c688ed --- /dev/null +++ b/R/get_funder_by_id.R @@ -0,0 +1,67 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Get Funder Information By ID +#' +#' @description Retrieve detailed information about a specific funder from +#' Databrary using its unique identifier. +#' +#' @param funder_id Numeric funder identifier. Must be a positive integer. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A list with the funder's metadata including id, name, and approval +#' status, or `NULL` if the funder is not found or inaccessible. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' # Get details for a specific funder +#' get_funder_by_id(funder_id = 1) +#' +#' # Get funder information with verbose output +#' get_funder_by_id(funder_id = 1, vb = TRUE) +#' } +#' } +#' @export +get_funder_by_id <- function(funder_id = 1, + vb = options::opt("vb"), + rq = NULL) { + # Validate funder_id + assertthat::assert_that(is.numeric(funder_id)) + assertthat::assert_that(length(funder_id) == 1) + assertthat::assert_that(funder_id > 0) + assertthat::assert_that(funder_id == floor(funder_id), + msg = "funder_id must be an integer") + + # Validate vb + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + # Validate rq + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + # Perform API call + funder <- perform_api_get( + path = sprintf(API_FUNDER_DETAIL, funder_id), + rq = rq, + vb = vb + ) + + if (is.null(funder)) { + if (vb) { + message("Funder ", funder_id, " not found or inaccessible.") + } + return(NULL) + } + + # Return structured list + list( + funder_id = funder$id, + funder_name = funder$name, + funder_is_approved = funder$is_approved + ) +} \ No newline at end of file diff --git a/man/get_funder_by_id.Rd b/man/get_funder_by_id.Rd new file mode 100644 index 00000000..70c66bd5 --- /dev/null +++ b/man/get_funder_by_id.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_funder_by_id.R +\name{get_funder_by_id} +\alias{get_funder_by_id} +\title{Get Funder Information By ID} +\usage{ +get_funder_by_id(funder_id = 1, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{funder_id}{Numeric funder identifier. Must be a positive integer.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A list with the funder's metadata including id, name, and approval +status, or \code{NULL} if the funder is not found or inaccessible. +} +\description{ +Retrieve detailed information about a specific funder from +Databrary using its unique identifier. +} +\examples{ +\donttest{ +\dontrun{ +# Get details for a specific funder +get_funder_by_id(funder_id = 1) + +# Get funder information with verbose output +get_funder_by_id(funder_id = 1, vb = TRUE) +} +} +} diff --git a/tests/testthat/test-get_funder_by_id.R b/tests/testthat/test-get_funder_by_id.R new file mode 100644 index 00000000..95fe7cd4 --- /dev/null +++ b/tests/testthat/test-get_funder_by_id.R @@ -0,0 +1,111 @@ +# get_funder_by_id() --------------------------------------------------- +login_test_account() + +test_that("get_funder_by_id retrieves valid funder", { + # Test with a known funder ID (assuming ID 1 exists in test environment) + result <- get_funder_by_id(funder_id = 1) + skip_if_null_response(result, "get_funder_by_id(1)") + + expect_type(result, "list") + expect_named(result, c("funder_id", "funder_name", "funder_is_approved")) + expect_equal(result$funder_id, 1) + expect_type(result$funder_name, "character") + expect_type(result$funder_is_approved, "logical") +}) + +test_that("get_funder_by_id returns NULL for non-existent funder", { + # Use a very large ID that likely doesn't exist + result <- get_funder_by_id(funder_id = 999999, vb = FALSE) + expect_null(result) +}) + +test_that("get_funder_by_id works with verbose mode", { + result <- get_funder_by_id(funder_id = 1, vb = TRUE) + skip_if_null_response(result, "get_funder_by_id(1, vb = TRUE)") + + expect_type(result, "list") + expect_true(!is.null(result$funder_id)) +}) + +test_that("get_funder_by_id rejects invalid funder_id", { + # Negative ID + expect_error(get_funder_by_id(funder_id = -1)) + + # Zero ID + expect_error(get_funder_by_id(funder_id = 0)) + + # Non-numeric ID + expect_error(get_funder_by_id(funder_id = "1")) + expect_error(get_funder_by_id(funder_id = TRUE)) + expect_error(get_funder_by_id(funder_id = list(a = 1))) + + # Multiple values + expect_error(get_funder_by_id(funder_id = c(1, 2))) + + # Decimal/non-integer + expect_error(get_funder_by_id(funder_id = 1.5)) + expect_error(get_funder_by_id(funder_id = 2.7)) + + # NULL + expect_error(get_funder_by_id(funder_id = NULL)) + + # NA + expect_error(get_funder_by_id(funder_id = NA)) +}) + +test_that("get_funder_by_id rejects invalid vb parameter", { + expect_error(get_funder_by_id(funder_id = 1, vb = -1)) + expect_error(get_funder_by_id(funder_id = 1, vb = 3)) + expect_error(get_funder_by_id(funder_id = 1, vb = "a")) + expect_error(get_funder_by_id(funder_id = 1, vb = list(a = 1, b = 2))) + expect_error(get_funder_by_id(funder_id = 1, vb = c(TRUE, FALSE))) + expect_error(get_funder_by_id(funder_id = 1, vb = NULL)) +}) + +test_that("get_funder_by_id rejects invalid rq parameter", { + expect_error(get_funder_by_id(funder_id = 1, rq = "a")) + expect_error(get_funder_by_id(funder_id = 1, rq = -1)) + expect_error(get_funder_by_id(funder_id = 1, rq = c(2, 3))) + expect_error(get_funder_by_id(funder_id = 1, rq = list(a = 1, b = 2))) + expect_error(get_funder_by_id(funder_id = 1, rq = TRUE)) +}) + +test_that("get_funder_by_id result structure is consistent", { + result <- get_funder_by_id(funder_id = 1) + skip_if_null_response(result, "get_funder_by_id(1)") + + # Check that all expected fields exist + expect_true(all(c("funder_id", "funder_name", "funder_is_approved") %in% names(result))) + + # Check field types + expect_true(is.numeric(result$funder_id) || is.integer(result$funder_id)) + expect_true(is.character(result$funder_name)) + expect_true(is.logical(result$funder_is_approved)) + + # Check that funder_id matches the requested ID + expect_equal(result$funder_id, 1) +}) + +test_that("get_funder_by_id can retrieve multiple different funders", { + result1 <- get_funder_by_id(funder_id = 1, vb = FALSE) + skip_if_null_response(result1, "get_funder_by_id(1)") + + # Try to get another funder (if available) + result2 <- get_funder_by_id(funder_id = 2, vb = FALSE) + + # If both exist, they should be different + if (!is.null(result2)) { + expect_false(identical(result1$funder_name, result2$funder_name)) + expect_equal(result1$funder_id, 1) + expect_equal(result2$funder_id, 2) + } +}) + +test_that("get_funder_by_id works with custom request object", { + custom_rq <- databraryr::make_default_request() + result <- get_funder_by_id(funder_id = 1, rq = custom_rq) + skip_if_null_response(result, "get_funder_by_id(1, rq = custom_rq)") + + expect_type(result, "list") + expect_equal(result$funder_id, 1) +}) \ No newline at end of file From 79355a8464b5c2ffa875c51d893a41b7bb5d0ca7 Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Wed, 10 Dec 2025 10:21:08 +0100 Subject: [PATCH 06/27] feat: add get_tag_by_id() for direct tag lookup by ID - Add API constant for tag detail endpoint - Implement get_tag_by_id() function - Add test suite (12 test cases) - Add function documentation --- NAMESPACE | 1 + R/CONSTANTS.R | 1 + R/get_tag_by_id.R | 66 +++++++++++++++ man/get_tag_by_id.Rd | 34 ++++++++ tests/testthat/test-get_tag_by_id.R | 122 ++++++++++++++++++++++++++++ 5 files changed, 224 insertions(+) create mode 100644 R/get_tag_by_id.R create mode 100644 man/get_tag_by_id.Rd create mode 100644 tests/testthat/test-get_tag_by_id.R diff --git a/NAMESPACE b/NAMESPACE index d96b6c2e..c522432b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,6 +25,7 @@ export(get_release_levels) export(get_session_by_id) export(get_session_by_name) export(get_supported_file_types) +export(get_tag_by_id) export(get_user_by_id) export(get_volume_by_id) export(list_asset_formats) diff --git a/R/CONSTANTS.R b/R/CONSTANTS.R index 6f07bd57..6f32d68e 100644 --- a/R/CONSTANTS.R +++ b/R/CONSTANTS.R @@ -41,6 +41,7 @@ API_SEARCH_USERS <- "/search/users/" API_SEARCH_INSTITUTIONS <- "/search/institutions/" API_FUNDERS <- "/funders/" API_FUNDER_DETAIL <- "/funders/%s/" +API_TAG_DETAIL <- "/tags/%s/" RETRY_LIMIT <- 3 RETRY_WAIT_TIME <- 1 # seconds diff --git a/R/get_tag_by_id.R b/R/get_tag_by_id.R new file mode 100644 index 00000000..6f303145 --- /dev/null +++ b/R/get_tag_by_id.R @@ -0,0 +1,66 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Get Tag Information By ID +#' +#' @description Retrieve detailed information about a specific tag from +#' Databrary using its unique identifier. +#' +#' @param tag_id Numeric tag identifier. Must be a positive integer. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A list with the tag's metadata including id and name, +#' or `NULL` if the tag is not found or inaccessible. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' # Get details for a specific tag +#' get_tag_by_id(tag_id = 1) +#' +#' # Get tag information with verbose output +#' get_tag_by_id(tag_id = 1, vb = TRUE) +#' } +#' } +#' @export +get_tag_by_id <- function(tag_id = 1, + vb = options::opt("vb"), + rq = NULL) { + # Validate tag_id + assertthat::assert_that(is.numeric(tag_id)) + assertthat::assert_that(length(tag_id) == 1) + assertthat::assert_that(tag_id > 0) + assertthat::assert_that(tag_id == floor(tag_id), + msg = "tag_id must be an integer") + + # Validate vb + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + # Validate rq + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + # Perform API call + tag <- perform_api_get( + path = sprintf(API_TAG_DETAIL, tag_id), + rq = rq, + vb = vb + ) + + if (is.null(tag)) { + if (vb) { + message("Tag ", tag_id, " not found or inaccessible.") + } + return(NULL) + } + + # Return structured list + list( + tag_id = tag$id, + tag_name = tag$name + ) +} diff --git a/man/get_tag_by_id.Rd b/man/get_tag_by_id.Rd new file mode 100644 index 00000000..4c0d0e3a --- /dev/null +++ b/man/get_tag_by_id.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_tag_by_id.R +\name{get_tag_by_id} +\alias{get_tag_by_id} +\title{Get Tag Information By ID} +\usage{ +get_tag_by_id(tag_id = 1, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{tag_id}{Numeric tag identifier. Must be a positive integer.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A list with the tag's metadata including id and name, +or \code{NULL} if the tag is not found or inaccessible. +} +\description{ +Retrieve detailed information about a specific tag from +Databrary using its unique identifier. +} +\examples{ +\donttest{ +\dontrun{ +# Get details for a specific tag +get_tag_by_id(tag_id = 1) + +# Get tag information with verbose output +get_tag_by_id(tag_id = 1, vb = TRUE) +} +} +} diff --git a/tests/testthat/test-get_tag_by_id.R b/tests/testthat/test-get_tag_by_id.R new file mode 100644 index 00000000..4008c665 --- /dev/null +++ b/tests/testthat/test-get_tag_by_id.R @@ -0,0 +1,122 @@ +# get_tag_by_id() --------------------------------------------------- +login_test_account() + +test_that("get_tag_by_id retrieves valid tag", { + # Test with a known tag ID (assuming ID 1 exists in test environment) + result <- get_tag_by_id(tag_id = 1) + skip_if_null_response(result, "get_tag_by_id(1)") + + expect_type(result, "list") + expect_named(result, c("tag_id", "tag_name")) + expect_equal(result$tag_id, 1) + expect_type(result$tag_name, "character") + expect_true(nchar(result$tag_name) > 0) +}) + +test_that("get_tag_by_id returns NULL for non-existent tag", { + # Use a very large ID that likely doesn't exist + result <- get_tag_by_id(tag_id = 999999, vb = FALSE) + expect_null(result) +}) + +test_that("get_tag_by_id works with verbose mode", { + result <- get_tag_by_id(tag_id = 1, vb = TRUE) + skip_if_null_response(result, "get_tag_by_id(1, vb = TRUE)") + + expect_type(result, "list") + expect_true(!is.null(result$tag_id)) +}) + +test_that("get_tag_by_id rejects invalid tag_id", { + # Negative ID + expect_error(get_tag_by_id(tag_id = -1)) + + # Zero ID + expect_error(get_tag_by_id(tag_id = 0)) + + # Non-numeric ID + expect_error(get_tag_by_id(tag_id = "1")) + expect_error(get_tag_by_id(tag_id = TRUE)) + expect_error(get_tag_by_id(tag_id = list(a = 1))) + + # Multiple values + expect_error(get_tag_by_id(tag_id = c(1, 2))) + + # Decimal/non-integer + expect_error(get_tag_by_id(tag_id = 1.5)) + expect_error(get_tag_by_id(tag_id = 2.7)) + + # NULL + expect_error(get_tag_by_id(tag_id = NULL)) + + # NA + expect_error(get_tag_by_id(tag_id = NA)) +}) + +test_that("get_tag_by_id rejects invalid vb parameter", { + expect_error(get_tag_by_id(tag_id = 1, vb = -1)) + expect_error(get_tag_by_id(tag_id = 1, vb = 3)) + expect_error(get_tag_by_id(tag_id = 1, vb = "a")) + expect_error(get_tag_by_id(tag_id = 1, vb = list(a = 1, b = 2))) + expect_error(get_tag_by_id(tag_id = 1, vb = c(TRUE, FALSE))) + expect_error(get_tag_by_id(tag_id = 1, vb = NULL)) +}) + +test_that("get_tag_by_id rejects invalid rq parameter", { + expect_error(get_tag_by_id(tag_id = 1, rq = "a")) + expect_error(get_tag_by_id(tag_id = 1, rq = -1)) + expect_error(get_tag_by_id(tag_id = 1, rq = c(2, 3))) + expect_error(get_tag_by_id(tag_id = 1, rq = list(a = 1, b = 2))) + expect_error(get_tag_by_id(tag_id = 1, rq = TRUE)) +}) + +test_that("get_tag_by_id result structure is consistent", { + result <- get_tag_by_id(tag_id = 1) + skip_if_null_response(result, "get_tag_by_id(1)") + + # Check that all expected fields exist + expect_true(all(c("tag_id", "tag_name") %in% names(result))) + + # Check field types + expect_true(is.numeric(result$tag_id) || is.integer(result$tag_id)) + expect_true(is.character(result$tag_name)) + + # Check that tag_id matches the requested ID + expect_equal(result$tag_id, 1) + + # Check that tag_name is not empty + expect_true(nchar(result$tag_name) > 0) +}) + +test_that("get_tag_by_id can retrieve multiple different tags", { + result1 <- get_tag_by_id(tag_id = 1, vb = FALSE) + skip_if_null_response(result1, "get_tag_by_id(1)") + + # Try to get another tag (if available) + result2 <- get_tag_by_id(tag_id = 2, vb = FALSE) + + # If both exist, they should be different + if (!is.null(result2)) { + expect_false(identical(result1$tag_name, result2$tag_name)) + expect_equal(result1$tag_id, 1) + expect_equal(result2$tag_id, 2) + } +}) + +test_that("get_tag_by_id works with custom request object", { + custom_rq <- databraryr::make_default_request() + result <- get_tag_by_id(tag_id = 1, rq = custom_rq) + skip_if_null_response(result, "get_tag_by_id(1, rq = custom_rq)") + + expect_type(result, "list") + expect_equal(result$tag_id, 1) +}) + +test_that("get_tag_by_id returns simple structure with only id and name", { + result <- get_tag_by_id(tag_id = 1) + skip_if_null_response(result, "get_tag_by_id(1)") + + # Tag should only have id and name fields + expect_length(result, 2) + expect_named(result, c("tag_id", "tag_name")) +}) From 9a9bec5655fd6f12208daaa9194b088e1d9eab63 Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Wed, 10 Dec 2025 10:43:17 +0100 Subject: [PATCH 07/27] feat: add get_category_by_id() function with tests - Added API_CATEGORY_DETAIL constant - Implemented get_category_by_id() to retrieve category by ID - Add test suite (12 test cases) - Add function documentation --- NAMESPACE | 1 + R/CONSTANTS.R | 1 + R/get_category_by_id.R | 86 ++++++++++++++ man/get_category_by_id.Rd | 35 ++++++ tests/testthat/test-get_category_by_id.R | 145 +++++++++++++++++++++++ 5 files changed, 268 insertions(+) create mode 100644 R/get_category_by_id.R create mode 100644 man/get_category_by_id.Rd create mode 100644 tests/testthat/test-get_category_by_id.R diff --git a/NAMESPACE b/NAMESPACE index c522432b..4cff29c7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,6 +15,7 @@ export(download_single_folder_asset_fr_df) export(download_single_session_asset_fr_df) export(download_video) export(download_volume_zip) +export(get_category_by_id) export(get_db_stats) export(get_file_duration) export(get_folder_by_id) diff --git a/R/CONSTANTS.R b/R/CONSTANTS.R index 6f32d68e..bea05d8a 100644 --- a/R/CONSTANTS.R +++ b/R/CONSTANTS.R @@ -42,6 +42,7 @@ API_SEARCH_INSTITUTIONS <- "/search/institutions/" API_FUNDERS <- "/funders/" API_FUNDER_DETAIL <- "/funders/%s/" API_TAG_DETAIL <- "/tags/%s/" +API_CATEGORY_DETAIL <- "/categories/%s/" RETRY_LIMIT <- 3 RETRY_WAIT_TIME <- 1 # seconds diff --git a/R/get_category_by_id.R b/R/get_category_by_id.R new file mode 100644 index 00000000..1b137692 --- /dev/null +++ b/R/get_category_by_id.R @@ -0,0 +1,86 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Get Category Information By ID +#' +#' @description Retrieve detailed information about a specific category from +#' Databrary using its unique identifier. Categories include nested metrics +#' that define data collection fields. +#' +#' @param category_id Numeric category identifier. Must be a positive integer. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A list with the category's metadata including id, name, description, +#' and nested metrics, or `NULL` if the category is not found or inaccessible. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' # Get details for a specific category +#' get_category_by_id(category_id = 1) +#' +#' # Get category information with verbose output +#' get_category_by_id(category_id = 1, vb = TRUE) +#' } +#' } +#' @export +get_category_by_id <- function(category_id = 1, + vb = options::opt("vb"), + rq = NULL) { + # Validate category_id + assertthat::assert_that(is.numeric(category_id)) + assertthat::assert_that(length(category_id) == 1) + assertthat::assert_that(category_id > 0) + assertthat::assert_that(category_id == floor(category_id), + msg = "category_id must be an integer") + + # Validate vb + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + # Validate rq + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + # Perform API call + category <- perform_api_get( + path = sprintf(API_CATEGORY_DETAIL, category_id), + rq = rq, + vb = vb + ) + + if (is.null(category)) { + if (vb) { + message("Category ", category_id, " not found or inaccessible.") + } + return(NULL) + } + + # Process metrics if present + metrics <- NULL + if (!is.null(category$metrics) && length(category$metrics) > 0) { + metrics <- lapply(category$metrics, function(metric) { + list( + metric_id = metric$id, + metric_name = metric$name, + metric_type = metric$type, + metric_release = metric$release, + metric_options = metric$options, + metric_assumed = metric$assumed, + metric_description = metric$description, + metric_required = metric$required + ) + }) + } + + # Return structured list + list( + category_id = category$id, + category_name = category$name, + category_description = category$description, + metrics = metrics + ) +} \ No newline at end of file diff --git a/man/get_category_by_id.Rd b/man/get_category_by_id.Rd new file mode 100644 index 00000000..a5c08edc --- /dev/null +++ b/man/get_category_by_id.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_category_by_id.R +\name{get_category_by_id} +\alias{get_category_by_id} +\title{Get Category Information By ID} +\usage{ +get_category_by_id(category_id = 1, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{category_id}{Numeric category identifier. Must be a positive integer.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A list with the category's metadata including id, name, description, +and nested metrics, or \code{NULL} if the category is not found or inaccessible. +} +\description{ +Retrieve detailed information about a specific category from +Databrary using its unique identifier. Categories include nested metrics +that define data collection fields. +} +\examples{ +\donttest{ +\dontrun{ +# Get details for a specific category +get_category_by_id(category_id = 1) + +# Get category information with verbose output +get_category_by_id(category_id = 1, vb = TRUE) +} +} +} diff --git a/tests/testthat/test-get_category_by_id.R b/tests/testthat/test-get_category_by_id.R new file mode 100644 index 00000000..2b29034e --- /dev/null +++ b/tests/testthat/test-get_category_by_id.R @@ -0,0 +1,145 @@ +# get_category_by_id() --------------------------------------------------- +login_test_account() + +test_that("get_category_by_id retrieves valid category", { + # Test with a known category ID (assuming ID 1 exists in test environment) + result <- get_category_by_id(category_id = 1) + skip_if_null_response(result, "get_category_by_id(1)") + + expect_type(result, "list") + expect_named(result, c("category_id", "category_name", "category_description", "metrics")) + expect_equal(result$category_id, 1) + expect_type(result$category_name, "character") + expect_true(nchar(result$category_name) > 0) +}) + +test_that("get_category_by_id returns NULL for non-existent category", { + # Use a very large ID that likely doesn't exist + result <- get_category_by_id(category_id = 999999, vb = FALSE) + expect_null(result) +}) + +test_that("get_category_by_id works with verbose mode", { + result <- get_category_by_id(category_id = 1, vb = TRUE) + skip_if_null_response(result, "get_category_by_id(1, vb = TRUE)") + + expect_type(result, "list") + expect_true(!is.null(result$category_id)) +}) + +test_that("get_category_by_id rejects invalid category_id", { + # Negative ID + expect_error(get_category_by_id(category_id = -1)) + + # Zero ID + expect_error(get_category_by_id(category_id = 0)) + + # Non-numeric ID + expect_error(get_category_by_id(category_id = "1")) + expect_error(get_category_by_id(category_id = TRUE)) + expect_error(get_category_by_id(category_id = list(a = 1))) + + # Multiple values + expect_error(get_category_by_id(category_id = c(1, 2))) + + # Decimal/non-integer + expect_error(get_category_by_id(category_id = 1.5)) + expect_error(get_category_by_id(category_id = 2.7)) + + # NULL + expect_error(get_category_by_id(category_id = NULL)) + + # NA + expect_error(get_category_by_id(category_id = NA)) +}) + +test_that("get_category_by_id rejects invalid vb parameter", { + expect_error(get_category_by_id(category_id = 1, vb = -1)) + expect_error(get_category_by_id(category_id = 1, vb = 3)) + expect_error(get_category_by_id(category_id = 1, vb = "a")) + expect_error(get_category_by_id(category_id = 1, vb = list(a = 1, b = 2))) + expect_error(get_category_by_id(category_id = 1, vb = c(TRUE, FALSE))) + expect_error(get_category_by_id(category_id = 1, vb = NULL)) +}) + +test_that("get_category_by_id rejects invalid rq parameter", { + expect_error(get_category_by_id(category_id = 1, rq = "a")) + expect_error(get_category_by_id(category_id = 1, rq = -1)) + expect_error(get_category_by_id(category_id = 1, rq = c(2, 3))) + expect_error(get_category_by_id(category_id = 1, rq = list(a = 1, b = 2))) + expect_error(get_category_by_id(category_id = 1, rq = TRUE)) +}) + +test_that("get_category_by_id result structure is consistent", { + result <- get_category_by_id(category_id = 1) + skip_if_null_response(result, "get_category_by_id(1)") + + # Check that all expected fields exist + expect_true(all(c("category_id", "category_name", "category_description", "metrics") %in% names(result))) + + # Check field types + expect_true(is.numeric(result$category_id) || is.integer(result$category_id)) + expect_true(is.character(result$category_name)) + expect_true(is.character(result$category_description) || is.null(result$category_description)) + expect_true(is.list(result$metrics) || is.null(result$metrics)) + + # Check that category_id matches the requested ID + expect_equal(result$category_id, 1) + + # Check that category_name is not empty + expect_true(nchar(result$category_name) > 0) +}) + +test_that("get_category_by_id can retrieve multiple different categories", { + result1 <- get_category_by_id(category_id = 1, vb = FALSE) + skip_if_null_response(result1, "get_category_by_id(1)") + + # Try to get another category (if available) + result2 <- get_category_by_id(category_id = 2, vb = FALSE) + + # If both exist, they should be different + if (!is.null(result2)) { + expect_false(identical(result1$category_name, result2$category_name)) + expect_equal(result1$category_id, 1) + expect_equal(result2$category_id, 2) + } +}) + +test_that("get_category_by_id works with custom request object", { + custom_rq <- databraryr::make_default_request() + result <- get_category_by_id(category_id = 1, rq = custom_rq) + skip_if_null_response(result, "get_category_by_id(1, rq = custom_rq)") + + expect_type(result, "list") + expect_equal(result$category_id, 1) +}) + +test_that("get_category_by_id handles metrics properly", { + result <- get_category_by_id(category_id = 1) + skip_if_null_response(result, "get_category_by_id(1)") + + # If metrics exist, check their structure + if (!is.null(result$metrics) && length(result$metrics) > 0) { + expect_type(result$metrics, "list") + + # Check first metric structure + first_metric <- result$metrics[[1]] + expected_fields <- c("metric_id", "metric_name", "metric_type", "metric_release", + "metric_options", "metric_assumed", "metric_description", "metric_required") + expect_true(all(expected_fields %in% names(first_metric))) + + # Check that metric_id and metric_name are not NULL + expect_true(!is.null(first_metric$metric_id)) + expect_true(!is.null(first_metric$metric_name)) + expect_true(!is.null(first_metric$metric_type)) + } +}) + +test_that("get_category_by_id returns expected structure with all fields", { + result <- get_category_by_id(category_id = 1) + skip_if_null_response(result, "get_category_by_id(1)") + + # Category should have id, name, description, and metrics fields + expect_length(result, 4) + expect_named(result, c("category_id", "category_name", "category_description", "metrics")) +}) \ No newline at end of file From 4f10d6f90f50961453acc4790e81757b09cc1aac Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Wed, 10 Dec 2025 11:00:30 +0100 Subject: [PATCH 08/27] feat: add list_categories() function with tests - Added API_CATEGORIES constant - Implemented list_categories() to retrieve all categories - Add test suite (10 test cases) - Add function documentation --- NAMESPACE | 1 + R/CONSTANTS.R | 1 + R/list_categories.R | 79 ++++++++++++++++++ man/list_categories.Rd | 33 ++++++++ tests/testthat/test-list_categories.R | 110 ++++++++++++++++++++++++++ 5 files changed, 224 insertions(+) create mode 100644 R/list_categories.R create mode 100644 man/list_categories.Rd create mode 100644 tests/testthat/test-list_categories.R diff --git a/NAMESPACE b/NAMESPACE index 4cff29c7..bbefb667 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -31,6 +31,7 @@ export(get_user_by_id) export(get_volume_by_id) export(list_asset_formats) export(list_authorized_investigators) +export(list_categories) export(list_folder_assets) export(list_institution_affiliates) export(list_session_activity) diff --git a/R/CONSTANTS.R b/R/CONSTANTS.R index bea05d8a..9837f777 100644 --- a/R/CONSTANTS.R +++ b/R/CONSTANTS.R @@ -42,6 +42,7 @@ API_SEARCH_INSTITUTIONS <- "/search/institutions/" API_FUNDERS <- "/funders/" API_FUNDER_DETAIL <- "/funders/%s/" API_TAG_DETAIL <- "/tags/%s/" +API_CATEGORIES <- "/categories/" API_CATEGORY_DETAIL <- "/categories/%s/" RETRY_LIMIT <- 3 diff --git a/R/list_categories.R b/R/list_categories.R new file mode 100644 index 00000000..338a8b84 --- /dev/null +++ b/R/list_categories.R @@ -0,0 +1,79 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' List Databrary Categories +#' +#' @description Retrieve all available categories from Databrary. Categories +#' define different types of data collection sessions and include nested +#' metrics that specify the data fields collected for each category. +#' +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A tibble containing metadata for each category including id, name, +#' description, and nested metrics, or `NULL` when no results are available. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' # List all categories +#' list_categories() +#' +#' # List with verbose output +#' list_categories(vb = TRUE) +#' } +#' } +#' @export +list_categories <- function(vb = options::opt("vb"), + rq = NULL) { + # Validate vb + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + # Validate rq + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + # Perform API call + categories <- perform_api_get( + path = API_CATEGORIES, + rq = rq, + vb = vb + ) + + if (is.null(categories) || length(categories) == 0) { + if (vb) { + message("No categories available.") + } + return(NULL) + } + + # Process categories into tibble + purrr::map_dfr(categories, function(category) { + # Process metrics if present + metrics <- NULL + if (!is.null(category$metrics) && length(category$metrics) > 0) { + metrics <- lapply(category$metrics, function(metric) { + list( + metric_id = metric$id, + metric_name = metric$name, + metric_type = metric$type, + metric_release = metric$release, + metric_options = metric$options, + metric_assumed = metric$assumed, + metric_description = metric$description, + metric_required = metric$required + ) + }) + } + + tibble::tibble( + category_id = category$id, + category_name = category$name, + category_description = if (is.null(category$description)) NA_character_ else category$description, + metrics = list(metrics) + ) + }) +} diff --git a/man/list_categories.Rd b/man/list_categories.Rd new file mode 100644 index 00000000..1bce307c --- /dev/null +++ b/man/list_categories.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_categories.R +\name{list_categories} +\alias{list_categories} +\title{List Databrary Categories} +\usage{ +list_categories(vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A tibble containing metadata for each category including id, name, +description, and nested metrics, or \code{NULL} when no results are available. +} +\description{ +Retrieve all available categories from Databrary. Categories +define different types of data collection sessions and include nested +metrics that specify the data fields collected for each category. +} +\examples{ +\donttest{ +\dontrun{ +# List all categories +list_categories() + +# List with verbose output +list_categories(vb = TRUE) +} +} +} diff --git a/tests/testthat/test-list_categories.R b/tests/testthat/test-list_categories.R new file mode 100644 index 00000000..a88170a8 --- /dev/null +++ b/tests/testthat/test-list_categories.R @@ -0,0 +1,110 @@ +# list_categories ------------------------------------------------------------- +login_test_account() + +test_that("list_categories returns tibble with categories", { + result <- list_categories() + skip_if_null_response(result, "list_categories()") + + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) + expect_true(all(c("category_id", "category_name", "category_description", "metrics") %in% names(result))) +}) + +test_that("list_categories returns valid category structure", { + result <- list_categories(vb = FALSE) + skip_if_null_response(result, "list_categories()") + + # Check column types + expect_true(is.numeric(result$category_id) || is.integer(result$category_id)) + expect_type(result$category_name, "character") + expect_type(result$category_description, "character") + expect_type(result$metrics, "list") + + # Check that category_ids are positive + expect_true(all(result$category_id > 0)) + + # Check that category names are not empty + expect_true(all(nchar(result$category_name) > 0)) +}) + +test_that("list_categories works with verbose mode", { + result <- list_categories(vb = TRUE) + skip_if_null_response(result, "list_categories(vb = TRUE)") + + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) +}) + +test_that("list_categories rejects invalid vb parameter", { + expect_error(list_categories(vb = -1)) + expect_error(list_categories(vb = 3)) + expect_error(list_categories(vb = "a")) + expect_error(list_categories(vb = list(a = 1, b = 2))) + expect_error(list_categories(vb = c(TRUE, FALSE))) + expect_error(list_categories(vb = NULL)) +}) + +test_that("list_categories rejects invalid rq parameter", { + expect_error(list_categories(rq = "a")) + expect_error(list_categories(rq = -1)) + expect_error(list_categories(rq = c(2, 3))) + expect_error(list_categories(rq = list(a = 1, b = 2))) + expect_error(list_categories(rq = TRUE)) +}) + +test_that("list_categories handles metrics correctly", { + result <- list_categories() + skip_if_null_response(result, "list_categories()") + + # Check that metrics column exists and is a list + expect_true("metrics" %in% names(result)) + expect_type(result$metrics, "list") + + # If any category has metrics, check their structure + has_metrics <- sapply(result$metrics, function(m) !is.null(m) && length(m) > 0) + if (any(has_metrics)) { + # Get first category with metrics + first_with_metrics <- which(has_metrics)[1] + metrics <- result$metrics[[first_with_metrics]] + + expect_type(metrics, "list") + expect_gt(length(metrics), 0) + + # Check first metric structure + first_metric <- metrics[[1]] + expected_fields <- c("metric_id", "metric_name", "metric_type", "metric_release", + "metric_options", "metric_assumed", "metric_description", "metric_required") + expect_true(all(expected_fields %in% names(first_metric))) + expect_true(!is.null(first_metric$metric_id)) + expect_true(!is.null(first_metric$metric_name)) + expect_true(!is.null(first_metric$metric_type)) + } +}) + +test_that("list_categories works with custom request object", { + custom_rq <- databraryr::make_default_request() + result <- list_categories(rq = custom_rq) + skip_if_null_response(result, "list_categories(rq = custom_rq)") + + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) +}) + +test_that("list_categories returns consistent number of rows across calls", { + result1 <- list_categories(vb = FALSE) + skip_if_null_response(result1, "list_categories() first call") + + result2 <- list_categories(vb = FALSE) + skip_if_null_response(result2, "list_categories() second call") + + # Number of categories should be stable + expect_equal(nrow(result1), nrow(result2)) +}) + +test_that("list_categories has unique category IDs", { + result <- list_categories() + skip_if_null_response(result, "list_categories()") + + # All category IDs should be unique + expect_equal(length(unique(result$category_id)), nrow(result)) +}) From 92ab1181d0ef7786ec74f7317db67fa5c65a84f0 Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Wed, 10 Dec 2025 11:44:01 +0100 Subject: [PATCH 09/27] feat: add list_volume_records() function with tests - Added API_VOLUME_RECORDS constant - Implemented list_volume_records() to retrieve participant records from volumes - Add test suite (14 test cases) - Add function documentation --- NAMESPACE | 1 + R/CONSTANTS.R | 1 + R/list_volume_records.R | 121 +++++++++++++++++ man/list_volume_records.Rd | 47 +++++++ tests/testthat/test-list_volume_records.R | 157 ++++++++++++++++++++++ 5 files changed, 327 insertions(+) create mode 100644 R/list_volume_records.R create mode 100644 man/list_volume_records.Rd create mode 100644 tests/testthat/test-list_volume_records.R diff --git a/NAMESPACE b/NAMESPACE index bbefb667..1b98e87e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -48,6 +48,7 @@ export(list_volume_folders) export(list_volume_funding) export(list_volume_info) export(list_volume_links) +export(list_volume_records) export(list_volume_session_assets) export(list_volume_sessions) export(list_volume_tags) diff --git a/R/CONSTANTS.R b/R/CONSTANTS.R index 9837f777..a6bb8a30 100644 --- a/R/CONSTANTS.R +++ b/R/CONSTANTS.R @@ -24,6 +24,7 @@ API_VOLUME_COLLABORATORS <- "/volumes/%s/collaborators/" API_VOLUME_HISTORY <- "/volumes/%s/history/" API_VOLUME_SESSIONS <- "/volumes/%s/sessions/" API_VOLUME_FOLDERS <- "/volumes/%s/folders/" +API_VOLUME_RECORDS <- "/volumes/%s/records/" API_SESSION_DETAIL <- "/volumes/%s/sessions/%s/" API_SESSION_FILES <- "/volumes/%s/sessions/%s/files/" API_SESSION_FILE_DETAIL <- "/volumes/%s/sessions/%s/files/%s/" diff --git a/R/list_volume_records.R b/R/list_volume_records.R new file mode 100644 index 00000000..c67ffdf3 --- /dev/null +++ b/R/list_volume_records.R @@ -0,0 +1,121 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' List Records in Databrary Volume +#' +#' @description Retrieve all records (participant data with measures) from a +#' specific Databrary volume. Records contain participant information including +#' age, birthday, category, and associated measures collected during sessions. +#' +#' @param vol_id Target volume number. Must be a positive integer. +#' @param category_id Optional numeric category identifier to filter records +#' by category type. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A tibble containing metadata for each record including id, volume, +#' category_id, measures, birthday, and age information, or `NULL` when no +#' records are available. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' # List all records in volume 1 +#' list_volume_records(vol_id = 1) +#' +#' # Filter records by category +#' list_volume_records(vol_id = 1, category_id = 2) +#' +#' # With verbose output +#' list_volume_records(vol_id = 1, vb = TRUE) +#' } +#' } +#' @export +list_volume_records <- function(vol_id = 1, + category_id = NULL, + vb = options::opt("vb"), + rq = NULL) { + # Validate vol_id + assertthat::assert_that(length(vol_id) == 1) + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(vol_id >= 1) + assertthat::assert_that(vol_id == floor(vol_id), + msg = "vol_id must be an integer") + + # Validate category_id + if (!is.null(category_id)) { + assertthat::assert_that(length(category_id) == 1) + assertthat::assert_that(is.numeric(category_id)) + assertthat::assert_that(category_id > 0) + assertthat::assert_that(category_id == floor(category_id), + msg = "category_id must be an integer") + } + + # Validate vb + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + # Validate rq + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + # Build params list + params <- list() + if (!is.null(category_id)) { + params$category_id <- category_id + } + + # Perform API call + records <- collect_paginated_get( + path = sprintf(API_VOLUME_RECORDS, vol_id), + params = params, + rq = rq, + vb = vb + ) + + if (is.null(records) || length(records) == 0) { + if (vb) { + message("No records found for volume ", vol_id) + } + return(NULL) + } + + # Process records into tibble + purrr::map_dfr(records, function(record) { + # Process age if present + age_years <- NA_integer_ + age_months <- NA_integer_ + age_days <- NA_integer_ + age_total_days <- NA_integer_ + age_formatted <- NA_character_ + age_is_estimated <- NA + age_is_blurred <- NA + + if (!is.null(record$age)) { + age_years <- if (!is.null(record$age$years)) record$age$years else NA_integer_ + age_months <- if (!is.null(record$age$months)) record$age$months else NA_integer_ + age_days <- if (!is.null(record$age$days)) record$age$days else NA_integer_ + age_total_days <- if (!is.null(record$age$total_days)) record$age$total_days else NA_integer_ + age_formatted <- if (!is.null(record$age$formatted_value)) record$age$formatted_value else NA_character_ + age_is_estimated <- if (!is.null(record$age$is_estimated)) record$age$is_estimated else NA + age_is_blurred <- if (!is.null(record$age$is_blurred)) record$age$is_blurred else NA + } + + tibble::tibble( + record_id = record$id, + record_volume = record$volume, + record_category_id = record$category_id, + record_measures = list(record$measures), + record_birthday = if (is.null(record$birthday)) NA_character_ else as.character(record$birthday), + age_years = age_years, + age_months = age_months, + age_days = age_days, + age_total_days = age_total_days, + age_formatted = age_formatted, + age_is_estimated = age_is_estimated, + age_is_blurred = age_is_blurred + ) + }) +} diff --git a/man/list_volume_records.Rd b/man/list_volume_records.Rd new file mode 100644 index 00000000..c195131f --- /dev/null +++ b/man/list_volume_records.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_volume_records.R +\name{list_volume_records} +\alias{list_volume_records} +\title{List Records in Databrary Volume} +\usage{ +list_volume_records( + vol_id = 1, + category_id = NULL, + vb = options::opt("vb"), + rq = NULL +) +} +\arguments{ +\item{vol_id}{Target volume number. Must be a positive integer.} + +\item{category_id}{Optional numeric category identifier to filter records +by category type.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A tibble containing metadata for each record including id, volume, +category_id, measures, birthday, and age information, or \code{NULL} when no +records are available. +} +\description{ +Retrieve all records (participant data with measures) from a +specific Databrary volume. Records contain participant information including +age, birthday, category, and associated measures collected during sessions. +} +\examples{ +\donttest{ +\dontrun{ +# List all records in volume 1 +list_volume_records(vol_id = 1) + +# Filter records by category +list_volume_records(vol_id = 1, category_id = 2) + +# With verbose output +list_volume_records(vol_id = 1, vb = TRUE) +} +} +} diff --git a/tests/testthat/test-list_volume_records.R b/tests/testthat/test-list_volume_records.R new file mode 100644 index 00000000..79f07aaa --- /dev/null +++ b/tests/testthat/test-list_volume_records.R @@ -0,0 +1,157 @@ +# list_volume_records --------------------------------------------------------- +login_test_account() + +test_that("list_volume_records returns tibble given valid vol_id", { + result <- list_volume_records(vol_id = 1) + skip_if_null_response(result, "list_volume_records(vol_id = 1)") + + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) + expect_true(all(c("record_id", "record_volume", "record_category_id") %in% names(result))) +}) + +test_that("list_volume_records returns valid record structure", { + result <- list_volume_records(vol_id = 1, vb = FALSE) + skip_if_null_response(result, "list_volume_records(vol_id = 1)") + + # Check column types + expect_true(is.numeric(result$record_id) || is.integer(result$record_id)) + expect_true(is.numeric(result$record_volume) || is.integer(result$record_volume)) + expect_true(is.numeric(result$record_category_id) || is.integer(result$record_category_id)) + expect_type(result$record_measures, "list") + + # Check that record_ids are positive + expect_true(all(result$record_id > 0)) + + # Check that record_volume matches requested volume + expect_true(all(result$record_volume == 1)) +}) + +test_that("list_volume_records returns NULL for non-existent volume", { + result <- list_volume_records(vol_id = 999999, vb = FALSE) + expect_null(result) +}) + +test_that("list_volume_records works with category_id filter", { + # First get all records to find a valid category_id + all_records <- list_volume_records(vol_id = 1, vb = FALSE) + skip_if_null_response(all_records, "list_volume_records(vol_id = 1)") + + if (nrow(all_records) > 0) { + # Get unique category_id from results + test_category <- all_records$record_category_id[1] + + # Filter by that category + filtered_records <- list_volume_records(vol_id = 1, category_id = test_category, vb = FALSE) + skip_if_null_response(filtered_records, sprintf("list_volume_records(vol_id = 1, category_id = %d)", test_category)) + + # All records should have the specified category_id + expect_true(all(filtered_records$record_category_id == test_category)) + } +}) + +test_that("list_volume_records works with verbose mode", { + result <- list_volume_records(vol_id = 1, vb = TRUE) + skip_if_null_response(result, "list_volume_records(vol_id = 1, vb = TRUE)") + + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) +}) + +test_that("list_volume_records rejects invalid vol_id", { + # Negative ID + expect_error(list_volume_records(vol_id = -1)) + + # Zero ID + expect_error(list_volume_records(vol_id = 0)) + + # Non-numeric ID + expect_error(list_volume_records(vol_id = "1")) + expect_error(list_volume_records(vol_id = TRUE)) + expect_error(list_volume_records(vol_id = list(a = 1))) + + # Multiple values + expect_error(list_volume_records(vol_id = c(1, 2))) + + # Decimal/non-integer + expect_error(list_volume_records(vol_id = 1.5)) +}) + +test_that("list_volume_records rejects invalid category_id", { + # Negative ID + expect_error(list_volume_records(vol_id = 1, category_id = -1)) + + # Zero ID + expect_error(list_volume_records(vol_id = 1, category_id = 0)) + + # Non-numeric ID + expect_error(list_volume_records(vol_id = 1, category_id = "1")) + expect_error(list_volume_records(vol_id = 1, category_id = TRUE)) + + # Multiple values + expect_error(list_volume_records(vol_id = 1, category_id = c(1, 2))) + + # Decimal/non-integer + expect_error(list_volume_records(vol_id = 1, category_id = 1.5)) +}) + +test_that("list_volume_records rejects invalid vb parameter", { + expect_error(list_volume_records(vol_id = 1, vb = -1)) + expect_error(list_volume_records(vol_id = 1, vb = 3)) + expect_error(list_volume_records(vol_id = 1, vb = "a")) + expect_error(list_volume_records(vol_id = 1, vb = list(a = 1, b = 2))) + expect_error(list_volume_records(vol_id = 1, vb = c(TRUE, FALSE))) + expect_error(list_volume_records(vol_id = 1, vb = NULL)) +}) + +test_that("list_volume_records rejects invalid rq parameter", { + expect_error(list_volume_records(vol_id = 1, rq = "a")) + expect_error(list_volume_records(vol_id = 1, rq = -1)) + expect_error(list_volume_records(vol_id = 1, rq = c(2, 3))) + expect_error(list_volume_records(vol_id = 1, rq = list(a = 1, b = 2))) + expect_error(list_volume_records(vol_id = 1, rq = TRUE)) +}) + +test_that("list_volume_records includes age fields", { + result <- list_volume_records(vol_id = 1) + skip_if_null_response(result, "list_volume_records(vol_id = 1)") + + # Check that age fields exist + age_fields <- c("age_years", "age_months", "age_days", "age_total_days", + "age_formatted", "age_is_estimated", "age_is_blurred") + expect_true(all(age_fields %in% names(result))) +}) + +test_that("list_volume_records includes measures as list column", { + result <- list_volume_records(vol_id = 1) + skip_if_null_response(result, "list_volume_records(vol_id = 1)") + + # Check that measures column is a list + expect_true("record_measures" %in% names(result)) + expect_type(result$record_measures, "list") +}) + +test_that("list_volume_records works with custom request object", { + custom_rq <- databraryr::make_default_request() + result <- list_volume_records(vol_id = 1, rq = custom_rq) + skip_if_null_response(result, "list_volume_records(vol_id = 1, rq = custom_rq)") + + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) +}) + +test_that("list_volume_records returns for different volumes", { + result1 <- list_volume_records(vol_id = 1, vb = FALSE) + skip_if_null_response(result1, "list_volume_records(vol_id = 1)") + + result2 <- list_volume_records(vol_id = 2, vb = FALSE) + skip_if_null_response(result2, "list_volume_records(vol_id = 2)") + + # Both should be tibbles + expect_s3_class(result1, "tbl_df") + expect_s3_class(result2, "tbl_df") + + # Records should have different volume IDs + expect_true(all(result1$record_volume == 1)) + expect_true(all(result2$record_volume == 2)) +}) From 6d6c0cdbce7c768b0fac48bfcd96202b1b53307e Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Wed, 10 Dec 2025 12:00:25 +0100 Subject: [PATCH 10/27] feat: add get_volume_record_by_id() function with tests - Added API_VOLUME_RECORD_DETAIL constant - Implemented get_volume_record_by_id() to retrieve single record by ID - Created test suite (14 test cases) --- NAMESPACE | 1 + R/CONSTANTS.R | 1 + R/get_volume_record_by_id.R | 96 ++++++++ man/get_volume_record_by_id.Rd | 44 ++++ tests/testthat/test-get_volume_record_by_id.R | 224 ++++++++++++++++++ 5 files changed, 366 insertions(+) create mode 100644 R/get_volume_record_by_id.R create mode 100644 man/get_volume_record_by_id.Rd create mode 100644 tests/testthat/test-get_volume_record_by_id.R diff --git a/NAMESPACE b/NAMESPACE index 1b98e87e..b4206150 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -29,6 +29,7 @@ export(get_supported_file_types) export(get_tag_by_id) export(get_user_by_id) export(get_volume_by_id) +export(get_volume_record_by_id) export(list_asset_formats) export(list_authorized_investigators) export(list_categories) diff --git a/R/CONSTANTS.R b/R/CONSTANTS.R index a6bb8a30..5025634f 100644 --- a/R/CONSTANTS.R +++ b/R/CONSTANTS.R @@ -25,6 +25,7 @@ API_VOLUME_HISTORY <- "/volumes/%s/history/" API_VOLUME_SESSIONS <- "/volumes/%s/sessions/" API_VOLUME_FOLDERS <- "/volumes/%s/folders/" API_VOLUME_RECORDS <- "/volumes/%s/records/" +API_VOLUME_RECORD_DETAIL <- "/volumes/%s/records/%s/" API_SESSION_DETAIL <- "/volumes/%s/sessions/%s/" API_SESSION_FILES <- "/volumes/%s/sessions/%s/files/" API_SESSION_FILE_DETAIL <- "/volumes/%s/sessions/%s/files/%s/" diff --git a/R/get_volume_record_by_id.R b/R/get_volume_record_by_id.R new file mode 100644 index 00000000..5638cef8 --- /dev/null +++ b/R/get_volume_record_by_id.R @@ -0,0 +1,96 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Get Volume Record By ID +#' +#' @description Retrieve detailed information about a specific record +#' (participant data) from a Databrary volume using its unique identifier. +#' Records contain participant information including age, birthday, category, +#' and associated measures collected during sessions. +#' +#' @param vol_id Target volume number. Must be a positive integer. +#' @param record_id Numeric record identifier. Must be a positive integer. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A list with the record's metadata including id, volume, category_id, +#' measures, birthday, and age information, or `NULL` if the record is not +#' found or inaccessible. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' # Get details for a specific record +#' get_volume_record_by_id(vol_id = 1, record_id = 123) +#' +#' # Get record information with verbose output +#' get_volume_record_by_id(vol_id = 1, record_id = 123, vb = TRUE) +#' } +#' } +#' @export +get_volume_record_by_id <- function(vol_id = 1, + record_id = 1, + vb = options::opt("vb"), + rq = NULL) { + # Validate vol_id + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(length(vol_id) == 1) + assertthat::assert_that(vol_id >= 1) + assertthat::assert_that(vol_id == floor(vol_id), + msg = "vol_id must be an integer") + + # Validate record_id + assertthat::assert_that(is.numeric(record_id)) + assertthat::assert_that(length(record_id) == 1) + assertthat::assert_that(record_id > 0) + assertthat::assert_that(record_id == floor(record_id), + msg = "record_id must be an integer") + + # Validate vb + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + # Validate rq + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + # Perform API call + record <- perform_api_get( + path = sprintf(API_VOLUME_RECORD_DETAIL, vol_id, record_id), + rq = rq, + vb = vb + ) + + if (is.null(record)) { + if (vb) { + message("Record ", record_id, " in volume ", vol_id, " not found or inaccessible.") + } + return(NULL) + } + + # Process age if present + age <- NULL + if (!is.null(record$age)) { + age <- list( + years = record$age$years, + months = record$age$months, + days = record$age$days, + total_days = record$age$total_days, + formatted_value = record$age$formatted_value, + is_estimated = record$age$is_estimated, + is_blurred = record$age$is_blurred + ) + } + + # Return structured list + list( + record_id = record$id, + record_volume = record$volume, + record_category_id = record$category_id, + measures = record$measures, + birthday = record$birthday, + age = age + ) +} diff --git a/man/get_volume_record_by_id.Rd b/man/get_volume_record_by_id.Rd new file mode 100644 index 00000000..9ed51ad8 --- /dev/null +++ b/man/get_volume_record_by_id.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_volume_record_by_id.R +\name{get_volume_record_by_id} +\alias{get_volume_record_by_id} +\title{Get Volume Record By ID} +\usage{ +get_volume_record_by_id( + vol_id = 1, + record_id = 1, + vb = options::opt("vb"), + rq = NULL +) +} +\arguments{ +\item{vol_id}{Target volume number. Must be a positive integer.} + +\item{record_id}{Numeric record identifier. Must be a positive integer.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A list with the record's metadata including id, volume, category_id, +measures, birthday, and age information, or \code{NULL} if the record is not +found or inaccessible. +} +\description{ +Retrieve detailed information about a specific record +(participant data) from a Databrary volume using its unique identifier. +Records contain participant information including age, birthday, category, +and associated measures collected during sessions. +} +\examples{ +\donttest{ +\dontrun{ +# Get details for a specific record +get_volume_record_by_id(vol_id = 1, record_id = 123) + +# Get record information with verbose output +get_volume_record_by_id(vol_id = 1, record_id = 123, vb = TRUE) +} +} +} diff --git a/tests/testthat/test-get_volume_record_by_id.R b/tests/testthat/test-get_volume_record_by_id.R new file mode 100644 index 00000000..d402a597 --- /dev/null +++ b/tests/testthat/test-get_volume_record_by_id.R @@ -0,0 +1,224 @@ +# get_volume_record_by_id() -------------------------------------------------- +login_test_account() + +test_that("get_volume_record_by_id retrieves valid record", { + # First get a list of records to find a valid record_id + records <- list_volume_records(vol_id = 1, vb = FALSE) + skip_if_null_response(records, "list_volume_records(vol_id = 1)") + + if (nrow(records) > 0) { + test_record_id <- records$record_id[1] + + result <- get_volume_record_by_id(vol_id = 1, record_id = test_record_id) + skip_if_null_response(result, sprintf("get_volume_record_by_id(vol_id = 1, record_id = %d)", test_record_id)) + + expect_type(result, "list") + expect_named(result, c("record_id", "record_volume", "record_category_id", "measures", "birthday", "age")) + expect_equal(result$record_id, test_record_id) + expect_equal(result$record_volume, 1) + expect_true(is.numeric(result$record_category_id) || is.integer(result$record_category_id)) + } +}) + +test_that("get_volume_record_by_id returns NULL for non-existent record", { + # Use a very large ID that likely doesn't exist + result <- get_volume_record_by_id(vol_id = 1, record_id = 999999, vb = FALSE) + expect_null(result) +}) + +test_that("get_volume_record_by_id returns NULL for non-existent volume", { + result <- get_volume_record_by_id(vol_id = 999999, record_id = 1, vb = FALSE) + expect_null(result) +}) + +test_that("get_volume_record_by_id works with verbose mode", { + records <- list_volume_records(vol_id = 1, vb = FALSE) + skip_if_null_response(records, "list_volume_records(vol_id = 1)") + + if (nrow(records) > 0) { + test_record_id <- records$record_id[1] + result <- get_volume_record_by_id(vol_id = 1, record_id = test_record_id, vb = TRUE) + skip_if_null_response(result, sprintf("get_volume_record_by_id(vol_id = 1, record_id = %d, vb = TRUE)", test_record_id)) + + expect_type(result, "list") + expect_true(!is.null(result$record_id)) + } +}) + +test_that("get_volume_record_by_id rejects invalid vol_id", { + # Negative ID + expect_error(get_volume_record_by_id(vol_id = -1, record_id = 1)) + + # Zero ID + expect_error(get_volume_record_by_id(vol_id = 0, record_id = 1)) + + # Non-numeric ID + expect_error(get_volume_record_by_id(vol_id = "1", record_id = 1)) + expect_error(get_volume_record_by_id(vol_id = TRUE, record_id = 1)) + expect_error(get_volume_record_by_id(vol_id = list(a = 1), record_id = 1)) + + # Multiple values + expect_error(get_volume_record_by_id(vol_id = c(1, 2), record_id = 1)) + + # Decimal/non-integer + expect_error(get_volume_record_by_id(vol_id = 1.5, record_id = 1)) + expect_error(get_volume_record_by_id(vol_id = 2.7, record_id = 1)) + + # NULL + expect_error(get_volume_record_by_id(vol_id = NULL, record_id = 1)) + + # NA + expect_error(get_volume_record_by_id(vol_id = NA, record_id = 1)) +}) + +test_that("get_volume_record_by_id rejects invalid record_id", { + # Negative ID + expect_error(get_volume_record_by_id(vol_id = 1, record_id = -1)) + + # Zero ID + expect_error(get_volume_record_by_id(vol_id = 1, record_id = 0)) + + # Non-numeric ID + expect_error(get_volume_record_by_id(vol_id = 1, record_id = "1")) + expect_error(get_volume_record_by_id(vol_id = 1, record_id = TRUE)) + expect_error(get_volume_record_by_id(vol_id = 1, record_id = list(a = 1))) + + # Multiple values + expect_error(get_volume_record_by_id(vol_id = 1, record_id = c(1, 2))) + + # Decimal/non-integer + expect_error(get_volume_record_by_id(vol_id = 1, record_id = 1.5)) + expect_error(get_volume_record_by_id(vol_id = 1, record_id = 2.7)) + + # NULL + expect_error(get_volume_record_by_id(vol_id = 1, record_id = NULL)) + + # NA + expect_error(get_volume_record_by_id(vol_id = 1, record_id = NA)) +}) + +test_that("get_volume_record_by_id rejects invalid vb parameter", { + expect_error(get_volume_record_by_id(vol_id = 1, record_id = 1, vb = -1)) + expect_error(get_volume_record_by_id(vol_id = 1, record_id = 1, vb = 3)) + expect_error(get_volume_record_by_id(vol_id = 1, record_id = 1, vb = "a")) + expect_error(get_volume_record_by_id(vol_id = 1, record_id = 1, vb = list(a = 1, b = 2))) + expect_error(get_volume_record_by_id(vol_id = 1, record_id = 1, vb = c(TRUE, FALSE))) + expect_error(get_volume_record_by_id(vol_id = 1, record_id = 1, vb = NULL)) +}) + +test_that("get_volume_record_by_id rejects invalid rq parameter", { + expect_error(get_volume_record_by_id(vol_id = 1, record_id = 1, rq = "a")) + expect_error(get_volume_record_by_id(vol_id = 1, record_id = 1, rq = -1)) + expect_error(get_volume_record_by_id(vol_id = 1, record_id = 1, rq = c(2, 3))) + expect_error(get_volume_record_by_id(vol_id = 1, record_id = 1, rq = list(a = 1, b = 2))) + expect_error(get_volume_record_by_id(vol_id = 1, record_id = 1, rq = TRUE)) +}) + +test_that("get_volume_record_by_id result structure is consistent", { + records <- list_volume_records(vol_id = 1, vb = FALSE) + skip_if_null_response(records, "list_volume_records(vol_id = 1)") + + if (nrow(records) > 0) { + test_record_id <- records$record_id[1] + result <- get_volume_record_by_id(vol_id = 1, record_id = test_record_id) + skip_if_null_response(result, sprintf("get_volume_record_by_id(vol_id = 1, record_id = %d)", test_record_id)) + + # Check that all expected fields exist + expect_true(all(c("record_id", "record_volume", "record_category_id", "measures", "birthday", "age") %in% names(result))) + + # Check field types + expect_true(is.numeric(result$record_id) || is.integer(result$record_id)) + expect_true(is.numeric(result$record_volume) || is.integer(result$record_volume)) + expect_true(is.numeric(result$record_category_id) || is.integer(result$record_category_id)) + expect_true(is.list(result$measures) || is.null(result$measures)) + + # Check that record_id matches the requested ID + expect_equal(result$record_id, test_record_id) + + # Check that record_volume matches requested volume + expect_equal(result$record_volume, 1) + } +}) + +test_that("get_volume_record_by_id handles age structure correctly", { + records <- list_volume_records(vol_id = 1, vb = FALSE) + skip_if_null_response(records, "list_volume_records(vol_id = 1)") + + if (nrow(records) > 0) { + test_record_id <- records$record_id[1] + result <- get_volume_record_by_id(vol_id = 1, record_id = test_record_id) + skip_if_null_response(result, sprintf("get_volume_record_by_id(vol_id = 1, record_id = %d)", test_record_id)) + + # If age exists, check its structure + if (!is.null(result$age)) { + expect_type(result$age, "list") + expected_fields <- c("years", "months", "days", "total_days", "formatted_value", "is_estimated", "is_blurred") + expect_true(all(expected_fields %in% names(result$age))) + } + } +}) + +test_that("get_volume_record_by_id handles measures correctly", { + records <- list_volume_records(vol_id = 1, vb = FALSE) + skip_if_null_response(records, "list_volume_records(vol_id = 1)") + + if (nrow(records) > 0) { + test_record_id <- records$record_id[1] + result <- get_volume_record_by_id(vol_id = 1, record_id = test_record_id) + skip_if_null_response(result, sprintf("get_volume_record_by_id(vol_id = 1, record_id = %d)", test_record_id)) + + # Measures should be a list (can be empty) + expect_true(is.list(result$measures) || is.null(result$measures)) + } +}) + +test_that("get_volume_record_by_id works with custom request object", { + records <- list_volume_records(vol_id = 1, vb = FALSE) + skip_if_null_response(records, "list_volume_records(vol_id = 1)") + + if (nrow(records) > 0) { + test_record_id <- records$record_id[1] + custom_rq <- databraryr::make_default_request() + result <- get_volume_record_by_id(vol_id = 1, record_id = test_record_id, rq = custom_rq) + skip_if_null_response(result, sprintf("get_volume_record_by_id(vol_id = 1, record_id = %d, rq = custom_rq)", test_record_id)) + + expect_type(result, "list") + expect_equal(result$record_id, test_record_id) + } +}) + +test_that("get_volume_record_by_id can retrieve multiple different records", { + records <- list_volume_records(vol_id = 1, vb = FALSE) + skip_if_null_response(records, "list_volume_records(vol_id = 1)") + + if (nrow(records) >= 2) { + record_id_1 <- records$record_id[1] + record_id_2 <- records$record_id[2] + + result1 <- get_volume_record_by_id(vol_id = 1, record_id = record_id_1, vb = FALSE) + result2 <- get_volume_record_by_id(vol_id = 1, record_id = record_id_2, vb = FALSE) + + skip_if_null_response(result1, sprintf("get_volume_record_by_id(vol_id = 1, record_id = %d)", record_id_1)) + skip_if_null_response(result2, sprintf("get_volume_record_by_id(vol_id = 1, record_id = %d)", record_id_2)) + + # If both exist, they should be different + expect_false(identical(result1$record_id, result2$record_id)) + expect_equal(result1$record_id, record_id_1) + expect_equal(result2$record_id, record_id_2) + } +}) + +test_that("get_volume_record_by_id returns complete structure with all fields", { + records <- list_volume_records(vol_id = 1, vb = FALSE) + skip_if_null_response(records, "list_volume_records(vol_id = 1)") + + if (nrow(records) > 0) { + test_record_id <- records$record_id[1] + result <- get_volume_record_by_id(vol_id = 1, record_id = test_record_id) + skip_if_null_response(result, sprintf("get_volume_record_by_id(vol_id = 1, record_id = %d)", test_record_id)) + + # Record should have all expected fields + expect_length(result, 6) + expect_named(result, c("record_id", "record_volume", "record_category_id", "measures", "birthday", "age")) + } +}) From d0ef941896676845a04f884a9f1883b3f97c0f02 Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Wed, 10 Dec 2025 12:38:47 +0100 Subject: [PATCH 11/27] feat: add get_volume_collaborator_by_id() function with tests - Added API_VOLUME_COLLABORATOR_DETAIL constant - Implemented get_volume_collaborator_by_id() to retrieve single collaborator by ID - Returns detailed collaborator data with user, sponsor, and sponsorship info - Created test suite (15 test cases) --- NAMESPACE | 1 + R/CONSTANTS.R | 1 + R/get_volume_collaborator_by_id.R | 134 ++++++++++ man/get_volume_collaborator_by_id.Rd | 45 ++++ .../test-get_volume_collaborator_by_id.R | 250 ++++++++++++++++++ 5 files changed, 431 insertions(+) create mode 100644 R/get_volume_collaborator_by_id.R create mode 100644 man/get_volume_collaborator_by_id.Rd create mode 100644 tests/testthat/test-get_volume_collaborator_by_id.R diff --git a/NAMESPACE b/NAMESPACE index b4206150..84852ff0 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -29,6 +29,7 @@ export(get_supported_file_types) export(get_tag_by_id) export(get_user_by_id) export(get_volume_by_id) +export(get_volume_collaborator_by_id) export(get_volume_record_by_id) export(list_asset_formats) export(list_authorized_investigators) diff --git a/R/CONSTANTS.R b/R/CONSTANTS.R index 5025634f..7afef603 100644 --- a/R/CONSTANTS.R +++ b/R/CONSTANTS.R @@ -21,6 +21,7 @@ API_VOLUME_TAGS <- "/volumes/%s/tags/" API_VOLUME_LINKS <- "/volumes/%s/links/" API_VOLUME_FUNDINGS <- "/volumes/%s/fundings/" API_VOLUME_COLLABORATORS <- "/volumes/%s/collaborators/" +API_VOLUME_COLLABORATOR_DETAIL <- "/volumes/%s/collaborators/%s/" API_VOLUME_HISTORY <- "/volumes/%s/history/" API_VOLUME_SESSIONS <- "/volumes/%s/sessions/" API_VOLUME_FOLDERS <- "/volumes/%s/folders/" diff --git a/R/get_volume_collaborator_by_id.R b/R/get_volume_collaborator_by_id.R new file mode 100644 index 00000000..8137eea0 --- /dev/null +++ b/R/get_volume_collaborator_by_id.R @@ -0,0 +1,134 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Get Volume Collaborator By ID +#' +#' @description Retrieve detailed information about a specific collaborator +#' on a Databrary volume using their unique collaborator identifier. Returns +#' collaborator details including user information, sponsor details, access +#' level, and visibility settings. +#' +#' @param vol_id Target volume number. Must be a positive integer. +#' @param collaborator_id Numeric collaborator identifier. Must be a positive integer. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A list with the collaborator's metadata including id, volume, user +#' details, sponsor information (if applicable), access level, visibility +#' settings, and expiration date, or `NULL` if the collaborator is not found +#' or inaccessible. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' # Get details for a specific collaborator +#' get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 5) +#' +#' # Get collaborator information with verbose output +#' get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 5, vb = TRUE) +#' } +#' } +#' @export +get_volume_collaborator_by_id <- function(vol_id = 1, + collaborator_id = 1, + vb = options::opt("vb"), + rq = NULL) { + # Validate vol_id + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(length(vol_id) == 1) + assertthat::assert_that(vol_id >= 1) + assertthat::assert_that(vol_id == floor(vol_id), + msg = "vol_id must be an integer") + + # Validate collaborator_id + assertthat::assert_that(is.numeric(collaborator_id)) + assertthat::assert_that(length(collaborator_id) == 1) + assertthat::assert_that(collaborator_id > 0) + assertthat::assert_that(collaborator_id == floor(collaborator_id), + msg = "collaborator_id must be an integer") + + # Validate vb + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + # Validate rq + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + # Perform API call + collaborator <- perform_api_get( + path = sprintf(API_VOLUME_COLLABORATOR_DETAIL, vol_id, collaborator_id), + rq = rq, + vb = vb + ) + + if (is.null(collaborator)) { + if (vb) { + message("Collaborator ", collaborator_id, " in volume ", vol_id, " not found or inaccessible.") + } + return(NULL) + } + + # Process user information + user <- NULL + if (!is.null(collaborator$user)) { + user <- list( + user_id = collaborator$user$id, + first_name = collaborator$user$first_name, + last_name = collaborator$user$last_name, + email = collaborator$user$email, + is_authorized_investigator = collaborator$user$is_authorized_investigator, + has_avatar = collaborator$user$has_avatar + ) + } + + # Process sponsor information + sponsor <- NULL + if (!is.null(collaborator$sponsor)) { + sponsor <- list( + sponsor_id = collaborator$sponsor$id, + first_name = collaborator$sponsor$first_name, + last_name = collaborator$sponsor$last_name, + email = collaborator$sponsor$email + ) + } + + # Process sponsorship information + sponsorship <- NULL + if (!is.null(collaborator$sponsorship)) { + sponsorship <- list( + sponsorship_id = collaborator$sponsorship$id, + sponsor_id = collaborator$sponsorship$sponsor, + sponsored_user_id = collaborator$sponsorship$sponsored_user, + status = collaborator$sponsorship$status + ) + } + + # Process sponsored_users if present + sponsored_users <- NULL + if (!is.null(collaborator$sponsored_users) && length(collaborator$sponsored_users) > 0) { + sponsored_users <- lapply(collaborator$sponsored_users, function(u) { + list( + user_id = u$id, + first_name = u$first_name, + last_name = u$last_name, + email = u$email + ) + }) + } + + # Return structured list + list( + collaborator_id = collaborator$id, + volume = collaborator$volume, + user = user, + sponsor = sponsor, + sponsorship = sponsorship, + is_publicly_visible = collaborator$is_publicly_visible, + access_level = collaborator$access_level, + expiration_date = collaborator$expiration_date, + sponsored_users = sponsored_users + ) +} \ No newline at end of file diff --git a/man/get_volume_collaborator_by_id.Rd b/man/get_volume_collaborator_by_id.Rd new file mode 100644 index 00000000..a79fd428 --- /dev/null +++ b/man/get_volume_collaborator_by_id.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_volume_collaborator_by_id.R +\name{get_volume_collaborator_by_id} +\alias{get_volume_collaborator_by_id} +\title{Get Volume Collaborator By ID} +\usage{ +get_volume_collaborator_by_id( + vol_id = 1, + collaborator_id = 1, + vb = options::opt("vb"), + rq = NULL +) +} +\arguments{ +\item{vol_id}{Target volume number. Must be a positive integer.} + +\item{collaborator_id}{Numeric collaborator identifier. Must be a positive integer.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A list with the collaborator's metadata including id, volume, user +details, sponsor information (if applicable), access level, visibility +settings, and expiration date, or \code{NULL} if the collaborator is not found +or inaccessible. +} +\description{ +Retrieve detailed information about a specific collaborator +on a Databrary volume using their unique collaborator identifier. Returns +collaborator details including user information, sponsor details, access +level, and visibility settings. +} +\examples{ +\donttest{ +\dontrun{ +# Get details for a specific collaborator +get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 5) + +# Get collaborator information with verbose output +get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 5, vb = TRUE) +} +} +} diff --git a/tests/testthat/test-get_volume_collaborator_by_id.R b/tests/testthat/test-get_volume_collaborator_by_id.R new file mode 100644 index 00000000..78753195 --- /dev/null +++ b/tests/testthat/test-get_volume_collaborator_by_id.R @@ -0,0 +1,250 @@ +# get_volume_collaborator_by_id() -------------------------------------------- +login_test_account() + +test_that("get_volume_collaborator_by_id retrieves valid collaborator", { + # First get a list of collaborators to find a valid collaborator_id + collaborators <- list_volume_collaborators(vol_id = 1, vb = FALSE) + skip_if_null_response(collaborators, "list_volume_collaborators(vol_id = 1)") + + if (nrow(collaborators) > 0) { + test_collaborator_id <- collaborators$collaborator_id[1] + + result <- get_volume_collaborator_by_id(vol_id = 1, collaborator_id = test_collaborator_id) + skip_if_null_response(result, sprintf("get_volume_collaborator_by_id(vol_id = 1, collaborator_id = %d)", test_collaborator_id)) + + expect_type(result, "list") + expect_named(result, c("collaborator_id", "volume", "user", "sponsor", "sponsorship", "is_publicly_visible", "access_level", "expiration_date", "sponsored_users")) + expect_equal(result$collaborator_id, test_collaborator_id) + expect_equal(result$volume, 1) + } +}) + +test_that("get_volume_collaborator_by_id returns NULL for non-existent collaborator", { + # Use a very large ID that likely doesn't exist + result <- get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 999999, vb = FALSE) + expect_null(result) +}) + +test_that("get_volume_collaborator_by_id returns NULL for non-existent volume", { + result <- get_volume_collaborator_by_id(vol_id = 999999, collaborator_id = 1, vb = FALSE) + expect_null(result) +}) + +test_that("get_volume_collaborator_by_id works with verbose mode", { + collaborators <- list_volume_collaborators(vol_id = 1, vb = FALSE) + skip_if_null_response(collaborators, "list_volume_collaborators(vol_id = 1)") + + if (nrow(collaborators) > 0) { + test_collaborator_id <- collaborators$collaborator_id[1] + result <- get_volume_collaborator_by_id(vol_id = 1, collaborator_id = test_collaborator_id, vb = TRUE) + skip_if_null_response(result, sprintf("get_volume_collaborator_by_id(vol_id = 1, collaborator_id = %d, vb = TRUE)", test_collaborator_id)) + + expect_type(result, "list") + expect_true(!is.null(result$collaborator_id)) + } +}) + +test_that("get_volume_collaborator_by_id rejects invalid vol_id", { + # Negative ID + expect_error(get_volume_collaborator_by_id(vol_id = -1, collaborator_id = 1)) + + # Zero ID + expect_error(get_volume_collaborator_by_id(vol_id = 0, collaborator_id = 1)) + + # Non-numeric ID + expect_error(get_volume_collaborator_by_id(vol_id = "1", collaborator_id = 1)) + expect_error(get_volume_collaborator_by_id(vol_id = TRUE, collaborator_id = 1)) + expect_error(get_volume_collaborator_by_id(vol_id = list(a = 1), collaborator_id = 1)) + + # Multiple values + expect_error(get_volume_collaborator_by_id(vol_id = c(1, 2), collaborator_id = 1)) + + # Decimal/non-integer + expect_error(get_volume_collaborator_by_id(vol_id = 1.5, collaborator_id = 1)) + expect_error(get_volume_collaborator_by_id(vol_id = 2.7, collaborator_id = 1)) + + # NULL + expect_error(get_volume_collaborator_by_id(vol_id = NULL, collaborator_id = 1)) + + # NA + expect_error(get_volume_collaborator_by_id(vol_id = NA, collaborator_id = 1)) +}) + +test_that("get_volume_collaborator_by_id rejects invalid collaborator_id", { + # Negative ID + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = -1)) + + # Zero ID + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 0)) + + # Non-numeric ID + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = "1")) + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = TRUE)) + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = list(a = 1))) + + # Multiple values + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = c(1, 2))) + + # Decimal/non-integer + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 1.5)) + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 2.7)) + + # NULL + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = NULL)) + + # NA + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = NA)) +}) + +test_that("get_volume_collaborator_by_id rejects invalid vb parameter", { + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 1, vb = -1)) + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 1, vb = 3)) + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 1, vb = "a")) + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 1, vb = list(a = 1, b = 2))) + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 1, vb = c(TRUE, FALSE))) + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 1, vb = NULL)) +}) + +test_that("get_volume_collaborator_by_id rejects invalid rq parameter", { + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 1, rq = "a")) + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 1, rq = -1)) + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 1, rq = c(2, 3))) + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 1, rq = list(a = 1, b = 2))) + expect_error(get_volume_collaborator_by_id(vol_id = 1, collaborator_id = 1, rq = TRUE)) +}) + +test_that("get_volume_collaborator_by_id result structure is consistent", { + collaborators <- list_volume_collaborators(vol_id = 1, vb = FALSE) + skip_if_null_response(collaborators, "list_volume_collaborators(vol_id = 1)") + + if (nrow(collaborators) > 0) { + test_collaborator_id <- collaborators$collaborator_id[1] + result <- get_volume_collaborator_by_id(vol_id = 1, collaborator_id = test_collaborator_id) + skip_if_null_response(result, sprintf("get_volume_collaborator_by_id(vol_id = 1, collaborator_id = %d)", test_collaborator_id)) + + # Check that all expected fields exist + expect_true(all(c("collaborator_id", "volume", "user", "sponsor", "sponsorship", "is_publicly_visible", "access_level", "expiration_date", "sponsored_users") %in% names(result))) + + # Check field types + expect_true(is.numeric(result$collaborator_id) || is.integer(result$collaborator_id)) + expect_true(is.numeric(result$volume) || is.integer(result$volume)) + expect_true(is.list(result$user) || is.null(result$user)) + expect_true(is.logical(result$is_publicly_visible)) + expect_true(is.character(result$access_level)) + + # Check that collaborator_id matches the requested ID + expect_equal(result$collaborator_id, test_collaborator_id) + + # Check that volume matches requested volume + expect_equal(result$volume, 1) + } +}) + +test_that("get_volume_collaborator_by_id handles user structure correctly", { + collaborators <- list_volume_collaborators(vol_id = 1, vb = FALSE) + skip_if_null_response(collaborators, "list_volume_collaborators(vol_id = 1)") + + if (nrow(collaborators) > 0) { + test_collaborator_id <- collaborators$collaborator_id[1] + result <- get_volume_collaborator_by_id(vol_id = 1, collaborator_id = test_collaborator_id) + skip_if_null_response(result, sprintf("get_volume_collaborator_by_id(vol_id = 1, collaborator_id = %d)", test_collaborator_id)) + + # If user exists, check its structure + if (!is.null(result$user)) { + expect_type(result$user, "list") + expected_fields <- c("user_id", "first_name", "last_name", "email", "is_authorized_investigator", "has_avatar") + expect_true(all(expected_fields %in% names(result$user))) + expect_true(!is.null(result$user$user_id)) + } + } +}) + +test_that("get_volume_collaborator_by_id handles sponsor structure correctly", { + collaborators <- list_volume_collaborators(vol_id = 1, vb = FALSE) + skip_if_null_response(collaborators, "list_volume_collaborators(vol_id = 1)") + + if (nrow(collaborators) > 0) { + test_collaborator_id <- collaborators$collaborator_id[1] + result <- get_volume_collaborator_by_id(vol_id = 1, collaborator_id = test_collaborator_id) + skip_if_null_response(result, sprintf("get_volume_collaborator_by_id(vol_id = 1, collaborator_id = %d)", test_collaborator_id)) + + # If sponsor exists, check its structure + if (!is.null(result$sponsor)) { + expect_type(result$sponsor, "list") + expected_fields <- c("sponsor_id", "first_name", "last_name", "email") + expect_true(all(expected_fields %in% names(result$sponsor))) + expect_true(!is.null(result$sponsor$sponsor_id)) + } + } +}) + +test_that("get_volume_collaborator_by_id handles access_level correctly", { + collaborators <- list_volume_collaborators(vol_id = 1, vb = FALSE) + skip_if_null_response(collaborators, "list_volume_collaborators(vol_id = 1)") + + if (nrow(collaborators) > 0) { + test_collaborator_id <- collaborators$collaborator_id[1] + result <- get_volume_collaborator_by_id(vol_id = 1, collaborator_id = test_collaborator_id) + skip_if_null_response(result, sprintf("get_volume_collaborator_by_id(vol_id = 1, collaborator_id = %d)", test_collaborator_id)) + + # access_level should be a character string + expect_type(result$access_level, "character") + expect_true(nchar(result$access_level) > 0) + } +}) + +test_that("get_volume_collaborator_by_id works with custom request object", { + collaborators <- list_volume_collaborators(vol_id = 1, vb = FALSE) + skip_if_null_response(collaborators, "list_volume_collaborators(vol_id = 1)") + + if (nrow(collaborators) > 0) { + test_collaborator_id <- collaborators$collaborator_id[1] + custom_rq <- databraryr::make_default_request() + result <- get_volume_collaborator_by_id(vol_id = 1, collaborator_id = test_collaborator_id, rq = custom_rq) + skip_if_null_response(result, sprintf("get_volume_collaborator_by_id(vol_id = 1, collaborator_id = %d, rq = custom_rq)", test_collaborator_id)) + + expect_type(result, "list") + expect_equal(result$collaborator_id, test_collaborator_id) + } +}) + +test_that("get_volume_collaborator_by_id can retrieve multiple different collaborators", { + collaborators <- list_volume_collaborators(vol_id = 1, vb = FALSE) + skip_if_null_response(collaborators, "list_volume_collaborators(vol_id = 1)") + + if (nrow(collaborators) >= 2) { + # Filter out NA values and ensure we have valid IDs + valid_ids <- collaborators$collaborator_id[!is.na(collaborators$collaborator_id) & collaborators$collaborator_id > 0] + + if (length(valid_ids) >= 2) { + collaborator_id_1 <- valid_ids[1] + collaborator_id_2 <- valid_ids[2] + + result1 <- get_volume_collaborator_by_id(vol_id = 1, collaborator_id = collaborator_id_1, vb = FALSE) + result2 <- get_volume_collaborator_by_id(vol_id = 1, collaborator_id = collaborator_id_2, vb = FALSE) + + skip_if_null_response(result1, sprintf("get_volume_collaborator_by_id(vol_id = 1, collaborator_id = %d)", collaborator_id_1)) + skip_if_null_response(result2, sprintf("get_volume_collaborator_by_id(vol_id = 1, collaborator_id = %d)", collaborator_id_2)) + + # If both exist, they should be different + expect_false(identical(result1$collaborator_id, result2$collaborator_id)) + expect_equal(result1$collaborator_id, collaborator_id_1) + expect_equal(result2$collaborator_id, collaborator_id_2) + } + } +}) + +test_that("get_volume_collaborator_by_id returns complete structure with all fields", { + collaborators <- list_volume_collaborators(vol_id = 1, vb = FALSE) + skip_if_null_response(collaborators, "list_volume_collaborators(vol_id = 1)") + + if (nrow(collaborators) > 0) { + test_collaborator_id <- collaborators$collaborator_id[1] + result <- get_volume_collaborator_by_id(vol_id = 1, collaborator_id = test_collaborator_id) + skip_if_null_response(result, sprintf("get_volume_collaborator_by_id(vol_id = 1, collaborator_id = %d)", test_collaborator_id)) + + # Collaborator should have all expected fields + expect_length(result, 9) + expect_named(result, c("collaborator_id", "volume", "user", "sponsor", "sponsorship", "is_publicly_visible", "access_level", "expiration_date", "sponsored_users")) + } +}) \ No newline at end of file From 905368c0c60247c65ca2528bab767c42a01edcf8 Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Wed, 10 Dec 2025 14:24:40 +0100 Subject: [PATCH 12/27] feat: add get_institution_avatar() function with tests --- NAMESPACE | 1 + R/get_institution_avatar.R | 163 ++++++++++++++++ man/get_institution_avatar.Rd | 60 ++++++ tests/testthat/test-get_institution_avatar.R | 189 +++++++++++++++++++ 4 files changed, 413 insertions(+) create mode 100644 R/get_institution_avatar.R create mode 100644 man/get_institution_avatar.Rd create mode 100644 tests/testthat/test-get_institution_avatar.R diff --git a/NAMESPACE b/NAMESPACE index 84852ff0..cacbeefe 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,6 +20,7 @@ export(get_db_stats) export(get_file_duration) export(get_folder_by_id) export(get_funder_by_id) +export(get_institution_avatar) export(get_institution_by_id) export(get_permission_levels) export(get_release_levels) diff --git a/R/get_institution_avatar.R b/R/get_institution_avatar.R new file mode 100644 index 00000000..2ce3535e --- /dev/null +++ b/R/get_institution_avatar.R @@ -0,0 +1,163 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Download Institution Avatar Image +#' +#' @description Download an institution's avatar image from Databrary. The +#' image can be saved to a file or returned as raw bytes for further +#' processing. +#' +#' @param institution_id Numeric institution identifier. Must be a positive +#' integer. +#' @param dest_path Optional character string specifying the destination file +#' path or directory where the avatar should be saved. If a directory is +#' provided, the filename will be determined from the response headers or +#' will default to `institution__avatar.jpg`. If `NULL` (the default), +#' the raw image bytes are returned instead of being saved to disk. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return If `dest_path` is provided, returns the full path to the saved +#' file (character string). If `dest_path` is `NULL`, returns the raw +#' image bytes. Returns `NULL` if the avatar is not found or inaccessible. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' # Download avatar as raw bytes +#' avatar_bytes <- get_institution_avatar(institution_id = 1) +#' +#' # Download and save avatar to specific file +#' avatar_path <- get_institution_avatar( +#' institution_id = 1, +#' dest_path = "institution_1_avatar.jpg" +#' ) +#' +#' # Download and save to directory (filename auto-determined) +#' avatar_path <- get_institution_avatar( +#' institution_id = 1, +#' dest_path = "avatars/" +#' ) +#' +#' # With verbose output +#' get_institution_avatar(institution_id = 1, vb = TRUE) +#' } +#' } +#' @export +get_institution_avatar <- function(institution_id = 1, + dest_path = NULL, + vb = options::opt("vb"), + rq = NULL) { + # Validate institution_id + assertthat::assert_that(is.numeric(institution_id)) + assertthat::assert_that(length(institution_id) == 1) + assertthat::assert_that(institution_id > 0) + assertthat::assert_that(institution_id == floor(institution_id), + msg = "institution_id must be an integer") + + # Validate dest_path + if (!is.null(dest_path)) { + assertthat::assert_that(assertthat::is.string(dest_path)) + } + + # Validate vb + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + # Validate rq + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + # Build URL + avatar_url <- sprintf(API_INSTITUTION_AVATAR, institution_id) + full_url <- paste0(DATABRARY_BASE_URL, avatar_url) + + # Create request + if (is.null(rq)) { + req <- make_default_request() + } else { + req <- rq + } + + # Build the request with the avatar URL + req <- req %>% + httr2::req_url(full_url) %>% + httr2::req_method("GET") %>% + httr2::req_error(is_error = function(resp) FALSE) + + if (vb) { + message("Requesting avatar for institution ", institution_id) + } + + # Perform request + tryCatch({ + resp <- httr2::req_perform(req) + + # Check response status + status <- httr2::resp_status(resp) + if (status != 200) { + if (vb) { + message("Institution ", institution_id, " avatar not found or inaccessible (status: ", status, ")") + } + return(NULL) + } + + # Get raw bytes + avatar_bytes <- httr2::resp_body_raw(resp) + + if (is.null(dest_path)) { + # Return raw bytes + if (vb) { + message("Downloaded ", length(avatar_bytes), " bytes") + } + return(avatar_bytes) + } else { + # Resolve destination path + # If dest_path is a directory, determine filename from response headers or URL + final_path <- dest_path + if (dir.exists(dest_path)) { + # Try to get filename from content-disposition header + filename <- "downloaded_file" + content_disp <- httr2::resp_header(resp, "content-disposition") + + if (!is.null(content_disp) && grepl("filename=", content_disp)) { + # Extract filename from content-disposition header + filename_match <- regmatches(content_disp, regexpr("filename=([^;]+)", content_disp)) + if (length(filename_match) > 0) { + filename <- sub("filename=", "", filename_match) + filename <- gsub('^"|"$', '', filename) # Remove quotes + filename <- trimws(filename) + } + } else { + # Fallback: use URL path basename + url_path <- sprintf(API_INSTITUTION_AVATAR, institution_id) + filename <- paste0("institution_", institution_id, "_avatar.jpg") + } + + final_path <- file.path(dest_path, filename) + } + + # Create parent directory if needed + parent_dir <- dirname(final_path) + if (!dir.exists(parent_dir)) { + dir.create(parent_dir, recursive = TRUE, showWarnings = FALSE) + } + + # Save to file + writeBin(avatar_bytes, final_path) + + if (vb) { + message("Saved avatar to: ", final_path, " (", length(avatar_bytes), " bytes)") + } + + return(normalizePath(final_path)) + } + }, error = function(e) { + if (vb) { + message("Error downloading avatar for institution ", institution_id, ": ", e$message) + } + return(NULL) + }) +} \ No newline at end of file diff --git a/man/get_institution_avatar.Rd b/man/get_institution_avatar.Rd new file mode 100644 index 00000000..b3f3ada1 --- /dev/null +++ b/man/get_institution_avatar.Rd @@ -0,0 +1,60 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_institution_avatar.R +\name{get_institution_avatar} +\alias{get_institution_avatar} +\title{Download Institution Avatar Image} +\usage{ +get_institution_avatar( + institution_id = 1, + dest_path = NULL, + vb = options::opt("vb"), + rq = NULL +) +} +\arguments{ +\item{institution_id}{Numeric institution identifier. Must be a positive +integer.} + +\item{dest_path}{Optional character string specifying the destination file +path or directory where the avatar should be saved. If a directory is +provided, the filename will be determined from the response headers or +will default to \verb{institution__avatar.jpg}. If \code{NULL} (the default), +the raw image bytes are returned instead of being saved to disk.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +If \code{dest_path} is provided, returns the full path to the saved +file (character string). If \code{dest_path} is \code{NULL}, returns the raw +image bytes. Returns \code{NULL} if the avatar is not found or inaccessible. +} +\description{ +Download an institution's avatar image from Databrary. The +image can be saved to a file or returned as raw bytes for further +processing. +} +\examples{ +\donttest{ +\dontrun{ +# Download avatar as raw bytes +avatar_bytes <- get_institution_avatar(institution_id = 1) + +# Download and save avatar to specific file +avatar_path <- get_institution_avatar( + institution_id = 1, + dest_path = "institution_1_avatar.jpg" +) + +# Download and save to directory (filename auto-determined) +avatar_path <- get_institution_avatar( + institution_id = 1, + dest_path = "avatars/" +) + +# With verbose output +get_institution_avatar(institution_id = 1, vb = TRUE) +} +} +} diff --git a/tests/testthat/test-get_institution_avatar.R b/tests/testthat/test-get_institution_avatar.R new file mode 100644 index 00000000..f04e4684 --- /dev/null +++ b/tests/testthat/test-get_institution_avatar.R @@ -0,0 +1,189 @@ +# get_institution_avatar() --------------------------------------------------- +login_test_account() + +test_that("get_institution_avatar returns raw bytes when dest_path is NULL", { + # Institution ID 1 is known to have an avatar + result <- get_institution_avatar(institution_id = 1, vb = FALSE) + skip_if_null_response(result, "get_institution_avatar(institution_id = 1)") + + expect_type(result, "raw") + expect_gt(length(result), 0) +}) + +test_that("get_institution_avatar saves to file when dest_path is provided", { + # Institution ID 1 is known to have an avatar + temp_file <- tempfile(fileext = ".jpg") + + result <- get_institution_avatar( + institution_id = 1, + dest_path = temp_file, + vb = FALSE + ) + skip_if_null_response(result, "get_institution_avatar(institution_id = 1, dest_path = ...)") + + expect_type(result, "character") + expect_true(file.exists(result)) + expect_gt(file.size(result), 0) + + # Clean up + unlink(temp_file) +}) + +test_that("get_institution_avatar returns NULL for non-existent institution", { + result <- get_institution_avatar(institution_id = 999999, vb = FALSE) + expect_null(result) +}) + +test_that("get_institution_avatar returns NULL for institution without avatar", { + # Test with a very high ID that likely doesn't have an avatar + result <- get_institution_avatar(institution_id = 99999, vb = FALSE) + # This may return NULL either because institution doesn't exist or has no avatar + # Both outcomes are acceptable for this test + expect_true(is.null(result) || is.raw(result)) +}) + +test_that("get_institution_avatar works with verbose mode", { + # Institution ID 1 is known to have an avatar + result <- get_institution_avatar(institution_id = 1, vb = TRUE) + skip_if_null_response(result, "get_institution_avatar(institution_id = 1, vb = TRUE)") + + expect_type(result, "raw") + expect_gt(length(result), 0) +}) + +test_that("get_institution_avatar rejects invalid institution_id", { + # Negative ID + expect_error(get_institution_avatar(institution_id = -1)) + + # Zero ID + expect_error(get_institution_avatar(institution_id = 0)) + + # Non-numeric ID + expect_error(get_institution_avatar(institution_id = "1")) + expect_error(get_institution_avatar(institution_id = TRUE)) + expect_error(get_institution_avatar(institution_id = list(a = 1))) + + # Multiple values + expect_error(get_institution_avatar(institution_id = c(1, 2))) + + # Decimal/non-integer + expect_error(get_institution_avatar(institution_id = 1.5)) + expect_error(get_institution_avatar(institution_id = 2.7)) + + # NULL + expect_error(get_institution_avatar(institution_id = NULL)) + + # NA + expect_error(get_institution_avatar(institution_id = NA)) +}) + +test_that("get_institution_avatar rejects invalid dest_path", { + # Non-character dest_path + expect_error(get_institution_avatar(institution_id = 1, dest_path = 123)) + expect_error(get_institution_avatar(institution_id = 1, dest_path = TRUE)) + expect_error(get_institution_avatar(institution_id = 1, dest_path = list(a = 1))) + + # Multiple values + expect_error(get_institution_avatar(institution_id = 1, dest_path = c("file1.jpg", "file2.jpg"))) +}) + +test_that("get_institution_avatar rejects invalid vb parameter", { + expect_error(get_institution_avatar(institution_id = 1, vb = -1)) + expect_error(get_institution_avatar(institution_id = 1, vb = 3)) + expect_error(get_institution_avatar(institution_id = 1, vb = "a")) + expect_error(get_institution_avatar(institution_id = 1, vb = list(a = 1, b = 2))) + expect_error(get_institution_avatar(institution_id = 1, vb = c(TRUE, FALSE))) + expect_error(get_institution_avatar(institution_id = 1, vb = NULL)) +}) + +test_that("get_institution_avatar rejects invalid rq parameter", { + expect_error(get_institution_avatar(institution_id = 1, rq = "a")) + expect_error(get_institution_avatar(institution_id = 1, rq = -1)) + expect_error(get_institution_avatar(institution_id = 1, rq = c(2, 3))) + expect_error(get_institution_avatar(institution_id = 1, rq = list(a = 1, b = 2))) + expect_error(get_institution_avatar(institution_id = 1, rq = TRUE)) +}) + +test_that("get_institution_avatar creates parent directory if needed", { + # Institution ID 1 is known to have an avatar + # Create a path with non-existent parent directory + temp_dir <- tempfile() + temp_file <- file.path(temp_dir, "avatars", "test.jpg") + + result <- get_institution_avatar( + institution_id = 1, + dest_path = temp_file, + vb = FALSE + ) + skip_if_null_response(result, "get_institution_avatar(institution_id = 1, dest_path = ...)") + + expect_true(file.exists(result)) + expect_true(dir.exists(dirname(result))) + + # Clean up + unlink(temp_dir, recursive = TRUE) +}) + +test_that("get_institution_avatar works with custom request object", { + # Institution ID 1 is known to have an avatar + custom_rq <- databraryr::make_default_request() + + result <- get_institution_avatar(institution_id = 1, rq = custom_rq, vb = FALSE) + skip_if_null_response(result, "get_institution_avatar(institution_id = 1, rq = custom_rq)") + + expect_type(result, "raw") + expect_gt(length(result), 0) +}) + +test_that("get_institution_avatar returns same content for raw bytes and file", { + # Institution ID 1 is known to have an avatar + # Get as raw bytes + bytes_result <- get_institution_avatar(institution_id = 1, vb = FALSE) + skip_if_null_response(bytes_result, "get_institution_avatar(institution_id = 1) as bytes") + + # Get as file + temp_file <- tempfile(fileext = ".jpg") + file_result <- get_institution_avatar( + institution_id = 1, + dest_path = temp_file, + vb = FALSE + ) + skip_if_null_response(file_result, "get_institution_avatar(institution_id = 1, dest_path = ...) as file") + + # Read file and compare + file_bytes <- readBin(file_result, "raw", file.size(file_result)) + expect_equal(bytes_result, file_bytes) + + # Clean up + unlink(temp_file) +}) + +test_that("get_institution_avatar saves to directory with auto-determined filename", { + # Institution ID 1 is known to have an avatar + # Create a temporary directory + temp_dir <- tempfile() + dir.create(temp_dir) + + result <- get_institution_avatar( + institution_id = 1, + dest_path = temp_dir, + vb = FALSE + ) + skip_if_null_response(result, "get_institution_avatar(institution_id = 1, dest_path = temp_dir)") + + expect_type(result, "character") + expect_true(file.exists(result)) + expect_gt(file.size(result), 0) + + # Check that the file is in the temp_dir + expect_true(startsWith(result, normalizePath(temp_dir))) + + # Check that filename was auto-determined + filename <- basename(result) + expect_true(nchar(filename) > 0) + # The filename should either be from content-disposition header or our fallback + expect_true(filename == "institutions_1_avatar" || filename == "institution_1_avatar.jpg" || filename == "downloaded_file") + + # Clean up + unlink(temp_dir, recursive = TRUE) +}) \ No newline at end of file From 8b7d9f1e9e4fcc549934de79fa7f2a98f1a66534 Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Wed, 10 Dec 2025 15:02:39 +0100 Subject: [PATCH 13/27] feat: add list_institutions() function with tests --- NAMESPACE | 1 + R/CONSTANTS.R | 1 + R/list_institutions.R | 93 +++++++++++++ man/list_institutions.Rd | 40 ++++++ tests/testthat/test-list_institutions.R | 170 ++++++++++++++++++++++++ 5 files changed, 305 insertions(+) create mode 100644 R/list_institutions.R create mode 100644 man/list_institutions.Rd create mode 100644 tests/testthat/test-list_institutions.R diff --git a/NAMESPACE b/NAMESPACE index cacbeefe..49f2bda9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -37,6 +37,7 @@ export(list_authorized_investigators) export(list_categories) export(list_folder_assets) export(list_institution_affiliates) +export(list_institutions) export(list_session_activity) export(list_session_assets) export(list_user_affiliates) diff --git a/R/CONSTANTS.R b/R/CONSTANTS.R index 7afef603..97199e5e 100644 --- a/R/CONSTANTS.R +++ b/R/CONSTANTS.R @@ -12,6 +12,7 @@ API_USER_SPONSORSHIPS <- "/users/%s/sponsorships/" API_USER_AFFILIATES <- "/users/%s/affiliates/" API_USER_AVATAR <- "/users/%s/avatar/" API_USERS_HISTORY <- "/users/%s/history/" +API_INSTITUTIONS_LIST <- "/institutions/" API_INSTITUTIONS <- "/institutions/%s/" API_INSTITUTION_AFFILIATES <- "/institutions/%s/affiliates/" API_INSTITUTION_AVATAR <- "/institutions/%s/avatar/" diff --git a/R/list_institutions.R b/R/list_institutions.R new file mode 100644 index 00000000..13d1392a --- /dev/null +++ b/R/list_institutions.R @@ -0,0 +1,93 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' List Institutions +#' +#' @description Retrieve a list of all institutions registered with Databrary. +#' Optionally filter by search string. +#' +#' @param search_string Optional character string to filter institutions. If +#' `NULL` (the default), returns all institutions. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return A tibble containing institutions with their metadata including id, +#' name, url, date_signed, source, created_at, updated_at, has_avatar, +#' has_administrators, latitude, longitude, and manual_coordinates, or `NULL` +#' if no institutions are found. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' # List all institutions +#' list_institutions() +#' +#' # List institutions filtered by search string +#' list_institutions(search_string = "university") +#' +#' # With verbose output +#' list_institutions(vb = TRUE) +#' } +#' } +#' @export +list_institutions <- function(search_string = NULL, + vb = options::opt("vb"), + rq = NULL) { + # Validate search_string + if (!is.null(search_string)) { + assertthat::assert_that(assertthat::is.string(search_string)) + } + + # Validate vb + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + # Validate rq + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + # Build params list + params <- list() + if (!is.null(search_string)) { + params$search <- search_string + } + + # Perform API call with pagination + results <- collect_paginated_get( + path = API_INSTITUTIONS_LIST, + params = params, + rq = rq, + vb = vb + ) + + if (is.null(results) || length(results) == 0) { + if (vb) { + if (is.null(search_string)) { + message("No institutions found.") + } else { + message("No institutions found matching '", search_string, "'.") + } + } + return(NULL) + } + + # Process results into tibble + purrr::map_dfr(results, function(entry) { + tibble::tibble( + institution_id = entry$id, + institution_name = entry$name, + institution_url = if (is.null(entry$url)) NA_character_ else entry$url, + institution_date_signed = if (is.null(entry$date_signed)) NA_character_ else as.character(entry$date_signed), + institution_source = if (is.null(entry$source)) NA_character_ else entry$source, + institution_created_at = if (is.null(entry$created_at)) NA_character_ else as.character(entry$created_at), + institution_updated_at = if (is.null(entry$updated_at)) NA_character_ else as.character(entry$updated_at), + institution_has_avatar = if (is.null(entry$has_avatar)) NA else entry$has_avatar, + institution_has_administrators = if (is.null(entry$has_administrators)) NA else entry$has_administrators, + institution_latitude = if (is.null(entry$latitude)) NA_real_ else as.numeric(entry$latitude), + institution_longitude = if (is.null(entry$longitude)) NA_real_ else as.numeric(entry$longitude), + institution_manual_coordinates = if (is.null(entry$manual_coordinates)) NA else entry$manual_coordinates + ) + }) +} \ No newline at end of file diff --git a/man/list_institutions.Rd b/man/list_institutions.Rd new file mode 100644 index 00000000..e6a7e159 --- /dev/null +++ b/man/list_institutions.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/list_institutions.R +\name{list_institutions} +\alias{list_institutions} +\title{List Institutions} +\usage{ +list_institutions(search_string = NULL, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{search_string}{Optional character string to filter institutions. If +\code{NULL} (the default), returns all institutions.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +A tibble containing institutions with their metadata including id, +name, url, date_signed, source, created_at, updated_at, has_avatar, +has_administrators, latitude, longitude, and manual_coordinates, or \code{NULL} +if no institutions are found. +} +\description{ +Retrieve a list of all institutions registered with Databrary. +Optionally filter by search string. +} +\examples{ +\donttest{ +\dontrun{ +# List all institutions +list_institutions() + +# List institutions filtered by search string +list_institutions(search_string = "university") + +# With verbose output +list_institutions(vb = TRUE) +} +} +} diff --git a/tests/testthat/test-list_institutions.R b/tests/testthat/test-list_institutions.R new file mode 100644 index 00000000..e0c14a64 --- /dev/null +++ b/tests/testthat/test-list_institutions.R @@ -0,0 +1,170 @@ +# list_institutions() --------------------------------------------------------- +login_test_account() + +test_that("list_institutions returns all institutions without search filter", { + result <- list_institutions(vb = FALSE) + skip_if_null_response(result, "list_institutions()") + + expect_s3_class(result, "tbl_df") + expect_named(result, c("institution_id", "institution_name", "institution_url", + "institution_date_signed", "institution_source", + "institution_created_at", "institution_updated_at", + "institution_has_avatar", "institution_has_administrators", + "institution_latitude", "institution_longitude", + "institution_manual_coordinates")) + expect_gt(nrow(result), 0) + + # Check column types + expect_true(is.numeric(result$institution_id) || is.integer(result$institution_id)) + expect_type(result$institution_name, "character") + expect_type(result$institution_url, "character") + expect_type(result$institution_date_signed, "character") + expect_type(result$institution_source, "character") + expect_type(result$institution_created_at, "character") + expect_type(result$institution_updated_at, "character") + expect_type(result$institution_has_avatar, "logical") + expect_type(result$institution_has_administrators, "logical") + expect_true(is.numeric(result$institution_latitude) || is.double(result$institution_latitude)) + expect_true(is.numeric(result$institution_longitude) || is.double(result$institution_longitude)) + expect_type(result$institution_manual_coordinates, "logical") +}) + +test_that("list_institutions filters by search string", { + result <- list_institutions(search_string = "university", vb = FALSE) + skip_if_null_response(result, "list_institutions(search_string = 'university')") + + expect_s3_class(result, "tbl_df") + expect_named(result, c("institution_id", "institution_name", "institution_url", + "institution_date_signed", "institution_source", + "institution_created_at", "institution_updated_at", + "institution_has_avatar", "institution_has_administrators", + "institution_latitude", "institution_longitude", + "institution_manual_coordinates")) + expect_gt(nrow(result), 0) + + # Check that results contain the search term (case insensitive) + expect_true(any(grepl("university", result$institution_name, ignore.case = TRUE))) +}) + +test_that("list_institutions works with verbose mode", { + result <- list_institutions(vb = TRUE) + skip_if_null_response(result, "list_institutions(vb = TRUE)") + + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) +}) + +test_that("list_institutions returns NULL for search with no matches", { + # Use a very unlikely search string + result <- list_institutions(search_string = "xyzabcdefghijklmnopqrstuvwxyz999999", vb = FALSE) + expect_null(result) +}) + +test_that("list_institutions rejects invalid search_string", { + # Non-character search_string + expect_error(list_institutions(search_string = 123)) + expect_error(list_institutions(search_string = TRUE)) + expect_error(list_institutions(search_string = list(a = 1))) + + # Multiple values + expect_error(list_institutions(search_string = c("test1", "test2"))) +}) + +test_that("list_institutions rejects invalid vb parameter", { + expect_error(list_institutions(vb = -1)) + expect_error(list_institutions(vb = 3)) + expect_error(list_institutions(vb = "a")) + expect_error(list_institutions(vb = list(a = 1, b = 2))) + expect_error(list_institutions(vb = c(TRUE, FALSE))) + expect_error(list_institutions(vb = NULL)) +}) + +test_that("list_institutions rejects invalid rq parameter", { + expect_error(list_institutions(rq = "a")) + expect_error(list_institutions(rq = -1)) + expect_error(list_institutions(rq = c(2, 3))) + expect_error(list_institutions(rq = list(a = 1, b = 2))) + expect_error(list_institutions(rq = TRUE)) +}) + +test_that("list_institutions result structure is consistent", { + result <- list_institutions(vb = FALSE) + skip_if_null_response(result, "list_institutions()") + + # Check that all expected fields exist + expect_true(all(c("institution_id", "institution_name", "institution_url", "institution_has_avatar") %in% names(result))) + + # Check that institution_id values are numeric + expect_true(is.numeric(result$institution_id) || is.integer(result$institution_id)) + + # Check that institution_name is never NA + expect_true(all(!is.na(result$institution_name))) +}) + +test_that("list_institutions handles NA values correctly", { + result <- list_institutions(vb = FALSE) + skip_if_null_response(result, "list_institutions()") + + # institution_url can be NA for institutions without a URL + expect_type(result$institution_url, "character") + + # institution_has_avatar can be NA for institutions without avatar info + expect_type(result$institution_has_avatar, "logical") +}) + +test_that("list_institutions works with custom request object", { + custom_rq <- databraryr::make_default_request() + result <- list_institutions(rq = custom_rq, vb = FALSE) + skip_if_null_response(result, "list_institutions(rq = custom_rq)") + + expect_s3_class(result, "tbl_df") + expect_gt(nrow(result), 0) +}) + +test_that("list_institutions returns different results with and without search", { + # Get all institutions + all_institutions <- list_institutions(vb = FALSE) + skip_if_null_response(all_institutions, "list_institutions()") + + # Get filtered institutions + filtered_institutions <- list_institutions(search_string = "state", vb = FALSE) + + # If filtered results exist, they should be a subset of all institutions + if (!is.null(filtered_institutions)) { + expect_true(nrow(filtered_institutions) <= nrow(all_institutions)) + } +}) + +test_that("list_institutions returns unique institution IDs", { + result <- list_institutions(vb = FALSE) + skip_if_null_response(result, "list_institutions()") + + # Check that all institution IDs are unique + expect_equal(nrow(result), length(unique(result$institution_id))) +}) + +test_that("list_institutions search is case insensitive", { + result_lower <- list_institutions(search_string = "university", vb = FALSE) + result_upper <- list_institutions(search_string = "UNIVERSITY", vb = FALSE) + + # If both return results, they should be similar + if (!is.null(result_lower) && !is.null(result_upper)) { + # Both should have results with "university" in the name (case insensitive) + expect_true(any(grepl("university", result_lower$institution_name, ignore.case = TRUE))) + expect_true(any(grepl("university", result_upper$institution_name, ignore.case = TRUE))) + } +}) + +test_that("list_institutions can retrieve institutions with avatars", { + result <- list_institutions(vb = FALSE) + skip_if_null_response(result, "list_institutions()") + + # Filter institutions that have avatars + institutions_with_avatars <- result[!is.na(result$institution_has_avatar) & result$institution_has_avatar == TRUE, ] + + # There should be at least some institutions with avatars + if (nrow(institutions_with_avatars) > 0) { + expect_gt(nrow(institutions_with_avatars), 0) + expect_true(all(institutions_with_avatars$institution_has_avatar == TRUE)) + } +}) From 16d880040f6f943ba42d77f682776c6052c2446b Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Wed, 10 Dec 2025 15:16:31 +0100 Subject: [PATCH 14/27] feat: add get_user_avatar() function with tests --- NAMESPACE | 1 + R/get_user_avatar.R | 166 +++++++++++++++++++++ man/get_user_avatar.Rd | 48 ++++++ tests/testthat/test-get_user_avatar.R | 205 ++++++++++++++++++++++++++ 4 files changed, 420 insertions(+) create mode 100644 R/get_user_avatar.R create mode 100644 man/get_user_avatar.Rd create mode 100644 tests/testthat/test-get_user_avatar.R diff --git a/NAMESPACE b/NAMESPACE index 49f2bda9..1d62eff1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -28,6 +28,7 @@ export(get_session_by_id) export(get_session_by_name) export(get_supported_file_types) export(get_tag_by_id) +export(get_user_avatar) export(get_user_by_id) export(get_volume_by_id) export(get_volume_collaborator_by_id) diff --git a/R/get_user_avatar.R b/R/get_user_avatar.R new file mode 100644 index 00000000..ae174b48 --- /dev/null +++ b/R/get_user_avatar.R @@ -0,0 +1,166 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Get User Avatar +#' +#' @description Download a user's avatar image from Databrary. Returns raw +#' bytes if no destination path is specified, or saves to disk and returns the +#' file path. +#' +#' @param user_id Numeric. The ID of the user whose avatar to download. +#' @param dest_path Optional character string specifying where to save the +#' avatar. Can be either a file path or a directory. If a directory is +#' provided, the filename will be automatically determined from the response +#' headers or will default to "user__avatar.jpg". If `NULL` (the +#' default), the function returns raw bytes instead of saving to disk. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' +#' @return If `dest_path` is `NULL`, returns raw bytes. If `dest_path` is +#' specified, returns the full path where the avatar was saved. Returns +#' `NULL` if the user has no avatar or if an error occurs. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' # Get avatar as raw bytes +#' avatar_bytes <- get_user_avatar(user_id = 5) +#' +#' # Save avatar to specific file +#' get_user_avatar(user_id = 5, dest_path = "avatar.jpg") +#' +#' # Save avatar to directory (filename auto-determined) +#' get_user_avatar(user_id = 5, dest_path = "~/avatars/") +#' +#' # With verbose output +#' get_user_avatar(user_id = 5, dest_path = "avatar.jpg", vb = TRUE) +#' } +#' } +#' @export +get_user_avatar <- function(user_id, + dest_path = NULL, + vb = options::opt("vb"), + rq = NULL) { + # Validate user_id + assertthat::assert_that(length(user_id) == 1) + assertthat::assert_that(is.numeric(user_id) || is.integer(user_id)) + assertthat::assert_that(user_id > 0) + + # Validate dest_path + if (!is.null(dest_path)) { + assertthat::assert_that(assertthat::is.string(dest_path)) + } + + # Validate vb + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + # Validate rq + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + # Build URL path + path <- sprintf(API_USER_AVATAR, user_id) + + if (vb) { + message("Getting user avatar for user ID: ", user_id) + } + + # Set up request + if (is.null(rq)) { + rq <- make_default_request() + } + + # Perform request + resp <- tryCatch( + { + rq |> + httr2::req_url_path_append(path) |> + httr2::req_error(is_error = function(resp) FALSE) |> + httr2::req_perform() + }, + error = function(e) { + if (vb) { + message("Error downloading user avatar: ", conditionMessage(e)) + } + return(NULL) + } + ) + + if (is.null(resp)) { + return(NULL) + } + + # Check for errors + if (httr2::resp_status(resp) != 200) { + if (vb) { + message( + "Failed to download user avatar. Status: ", + httr2::resp_status(resp) + ) + } + return(NULL) + } + + # Get avatar bytes + avatar_bytes <- httr2::resp_body_raw(resp) + + # If no destination path, return bytes + if (is.null(dest_path)) { + if (vb) { + message("Returning avatar as raw bytes (", length(avatar_bytes), " bytes)") + } + return(avatar_bytes) + } + + # Save to file + # Resolve destination path + # If dest_path is a directory, determine filename from response headers or URL + final_path <- dest_path + if (dir.exists(dest_path)) { + # Try to get filename from content-disposition header + filename <- "downloaded_file" + content_disp <- httr2::resp_header(resp, "content-disposition") + + if (!is.null(content_disp) && grepl("filename=", content_disp)) { + # Extract filename from content-disposition header + filename_match <- regmatches(content_disp, regexpr("filename=([^;]+)", content_disp)) + if (length(filename_match) > 0) { + filename <- sub("filename=", "", filename_match) + filename <- gsub('^"|"$', '', filename) # Remove quotes + filename <- trimws(filename) + } + } else { + # Fallback: use URL path basename + url_path <- sprintf(API_USER_AVATAR, user_id) + filename <- paste0("user_", user_id, "_avatar.jpg") + } + + final_path <- file.path(dest_path, filename) + } + + # Ensure parent directory exists + parent_dir <- dirname(final_path) + if (!dir.exists(parent_dir)) { + dir.create(parent_dir, recursive = TRUE) + } + + # Write to file + tryCatch( + { + writeBin(avatar_bytes, final_path) + if (vb) { + message("Avatar saved to: ", final_path) + } + return(normalizePath(final_path)) + }, + error = function(e) { + if (vb) { + message("Error saving avatar to file: ", conditionMessage(e)) + } + return(NULL) + } + ) +} \ No newline at end of file diff --git a/man/get_user_avatar.Rd b/man/get_user_avatar.Rd new file mode 100644 index 00000000..2b1b0f10 --- /dev/null +++ b/man/get_user_avatar.Rd @@ -0,0 +1,48 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_user_avatar.R +\name{get_user_avatar} +\alias{get_user_avatar} +\title{Get User Avatar} +\usage{ +get_user_avatar(user_id, dest_path = NULL, vb = options::opt("vb"), rq = NULL) +} +\arguments{ +\item{user_id}{Numeric. The ID of the user whose avatar to download.} + +\item{dest_path}{Optional character string specifying where to save the +avatar. Can be either a file path or a directory. If a directory is +provided, the filename will be automatically determined from the response +headers or will default to "user_\if{html}{\out{}}_avatar.jpg". If \code{NULL} (the +default), the function returns raw bytes instead of saving to disk.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An \code{httr2} request object. Defaults to \code{NULL}.} +} +\value{ +If \code{dest_path} is \code{NULL}, returns raw bytes. If \code{dest_path} is +specified, returns the full path where the avatar was saved. Returns +\code{NULL} if the user has no avatar or if an error occurs. +} +\description{ +Download a user's avatar image from Databrary. Returns raw +bytes if no destination path is specified, or saves to disk and returns the +file path. +} +\examples{ +\donttest{ +\dontrun{ +# Get avatar as raw bytes +avatar_bytes <- get_user_avatar(user_id = 5) + +# Save avatar to specific file +get_user_avatar(user_id = 5, dest_path = "avatar.jpg") + +# Save avatar to directory (filename auto-determined) +get_user_avatar(user_id = 5, dest_path = "~/avatars/") + +# With verbose output +get_user_avatar(user_id = 5, dest_path = "avatar.jpg", vb = TRUE) +} +} +} diff --git a/tests/testthat/test-get_user_avatar.R b/tests/testthat/test-get_user_avatar.R new file mode 100644 index 00000000..08fe7fe5 --- /dev/null +++ b/tests/testthat/test-get_user_avatar.R @@ -0,0 +1,205 @@ +# get_user_avatar() --------------------------------------------------------- +login_test_account() + +test_that("get_user_avatar returns raw bytes when dest_path is NULL", { + # User ID 5 is known to have an avatar + result <- get_user_avatar(user_id = 5, vb = FALSE) + skip_if_null_response(result, "get_user_avatar(user_id = 5)") + + expect_type(result, "raw") + expect_gt(length(result), 0) +}) + +test_that("get_user_avatar saves to file when dest_path is provided", { + # User ID 5 is known to have an avatar + temp_file <- tempfile(fileext = ".jpg") + + result <- get_user_avatar( + user_id = 5, + dest_path = temp_file, + vb = FALSE + ) + skip_if_null_response(result, "get_user_avatar(user_id = 5, dest_path = temp_file)") + + expect_type(result, "character") + expect_true(file.exists(result)) + expect_gt(file.size(result), 0) + + # Clean up + unlink(result) +}) + +test_that("get_user_avatar creates parent directories if needed", { + # User ID 5 is known to have an avatar + temp_dir <- tempfile() + nested_path <- file.path(temp_dir, "subdir", "avatar.jpg") + + result <- get_user_avatar( + user_id = 5, + dest_path = nested_path, + vb = FALSE + ) + skip_if_null_response(result, "get_user_avatar(user_id = 5, dest_path = nested_path)") + + expect_type(result, "character") + expect_true(file.exists(result)) + expect_gt(file.size(result), 0) + + # Clean up + unlink(temp_dir, recursive = TRUE) +}) + +test_that("get_user_avatar returns NULL for non-existent user", { + result <- get_user_avatar(user_id = 999999, vb = FALSE) + expect_null(result) +}) + +test_that("get_user_avatar works with verbose mode", { + # User ID 5 is known to have an avatar + result <- get_user_avatar(user_id = 5, vb = TRUE) + skip_if_null_response(result, "get_user_avatar(user_id = 5, vb = TRUE)") + + expect_type(result, "raw") + expect_gt(length(result), 0) +}) + +test_that("get_user_avatar rejects invalid user_id", { + # Non-numeric user_id + expect_error(get_user_avatar(user_id = "abc")) + expect_error(get_user_avatar(user_id = TRUE)) + expect_error(get_user_avatar(user_id = list(a = 1))) + + # Multiple values + expect_error(get_user_avatar(user_id = c(1, 2))) + + # Negative or zero user_id + expect_error(get_user_avatar(user_id = 0)) + expect_error(get_user_avatar(user_id = -1)) + + # NULL or NA user_id + expect_error(get_user_avatar(user_id = NULL)) + expect_error(get_user_avatar(user_id = NA)) +}) + +test_that("get_user_avatar rejects invalid dest_path", { + # Non-character dest_path + expect_error(get_user_avatar(user_id = 5, dest_path = 123)) + expect_error(get_user_avatar(user_id = 5, dest_path = TRUE)) + expect_error(get_user_avatar(user_id = 5, dest_path = list(a = 1))) + + # Multiple values + expect_error(get_user_avatar(user_id = 5, dest_path = c("path1", "path2"))) +}) + +test_that("get_user_avatar rejects invalid vb parameter", { + expect_error(get_user_avatar(user_id = 5, vb = -1)) + expect_error(get_user_avatar(user_id = 5, vb = 3)) + expect_error(get_user_avatar(user_id = 5, vb = "a")) + expect_error(get_user_avatar(user_id = 5, vb = list(a = 1, b = 2))) + expect_error(get_user_avatar(user_id = 5, vb = c(TRUE, FALSE))) + expect_error(get_user_avatar(user_id = 5, vb = NULL)) +}) + +test_that("get_user_avatar rejects invalid rq parameter", { + expect_error(get_user_avatar(user_id = 5, rq = "a")) + expect_error(get_user_avatar(user_id = 5, rq = -1)) + expect_error(get_user_avatar(user_id = 5, rq = c(2, 3))) + expect_error(get_user_avatar(user_id = 5, rq = list(a = 1, b = 2))) + expect_error(get_user_avatar(user_id = 5, rq = TRUE)) +}) + +test_that("get_user_avatar bytes and file content are identical", { + # User ID 5 is known to have an avatar + # Get bytes + bytes_result <- get_user_avatar(user_id = 5, vb = FALSE) + skip_if_null_response(bytes_result, "get_user_avatar(user_id = 5)") + + # Save to file + temp_file <- tempfile(fileext = ".jpg") + file_result <- get_user_avatar( + user_id = 5, + dest_path = temp_file, + vb = FALSE + ) + skip_if_null_response(file_result, "get_user_avatar(user_id = 5, dest_path = temp_file)") + + # Read file and compare + file_bytes <- readBin(file_result, "raw", file.info(file_result)$size) + expect_equal(bytes_result, file_bytes) + + # Clean up + unlink(file_result) +}) + +test_that("get_user_avatar saves to directory with auto-determined filename", { + # User ID 5 is known to have an avatar + # Create a temporary directory + temp_dir <- tempfile() + dir.create(temp_dir) + + result <- get_user_avatar( + user_id = 5, + dest_path = temp_dir, + vb = FALSE + ) + skip_if_null_response(result, "get_user_avatar(user_id = 5, dest_path = temp_dir)") + + expect_type(result, "character") + expect_true(file.exists(result)) + expect_gt(file.size(result), 0) + + # Check that the file is in the temp_dir + expect_true(startsWith(result, normalizePath(temp_dir))) + + # Check that filename was auto-determined + filename <- basename(result) + expect_true(nchar(filename) > 0) + # The filename should either be from content-disposition header or our fallback + # Accept any reasonable filename pattern + expect_true(grepl("avatar|user", filename, ignore.case = TRUE) || filename == "downloaded_file") + + # Clean up + unlink(temp_dir, recursive = TRUE) +}) + +test_that("get_user_avatar works with custom request object", { + custom_rq <- databraryr::make_default_request() + result <- get_user_avatar(user_id = 5, rq = custom_rq, vb = FALSE) + skip_if_null_response(result, "get_user_avatar(user_id = 5, rq = custom_rq)") + + expect_type(result, "raw") + expect_gt(length(result), 0) +}) + +test_that("get_user_avatar handles overwriting existing files", { + # User ID 5 is known to have an avatar + temp_file <- tempfile(fileext = ".jpg") + + # First write + result1 <- get_user_avatar( + user_id = 5, + dest_path = temp_file, + vb = FALSE + ) + skip_if_null_response(result1, "get_user_avatar(user_id = 5, dest_path = temp_file)") + + first_size <- file.size(result1) + + # Second write (overwrite) + result2 <- get_user_avatar( + user_id = 5, + dest_path = temp_file, + vb = FALSE + ) + skip_if_null_response(result2, "get_user_avatar(user_id = 5, dest_path = temp_file) [overwrite]") + + second_size <- file.size(result2) + + # Both should point to same file + expect_equal(result1, result2) + # Sizes should be the same (same avatar) + expect_equal(first_size, second_size) + + # Clean up + unlink(result2) +}) \ No newline at end of file From d8ceda29fb63a81f79c23be8c3675dafd27db1c9 Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Fri, 12 Dec 2025 09:45:59 +0100 Subject: [PATCH 15/27] feat: add get_session_file function with tests --- NAMESPACE | 1 + R/get_session_file.R | 65 ++++++++++++++++++++++++++ man/get_session_file.Rd | 41 ++++++++++++++++ tests/testthat/test-get_session_file.R | 44 +++++++++++++++++ 4 files changed, 151 insertions(+) create mode 100644 R/get_session_file.R create mode 100644 man/get_session_file.Rd create mode 100644 tests/testthat/test-get_session_file.R diff --git a/NAMESPACE b/NAMESPACE index 1d62eff1..f27b9b0e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,6 +26,7 @@ export(get_permission_levels) export(get_release_levels) export(get_session_by_id) export(get_session_by_name) +export(get_session_file) export(get_supported_file_types) export(get_tag_by_id) export(get_user_avatar) diff --git a/R/get_session_file.R b/R/get_session_file.R new file mode 100644 index 00000000..895ce274 --- /dev/null +++ b/R/get_session_file.R @@ -0,0 +1,65 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Get Session File Data From A Databrary Volume +#' +#' @param vol_id An integer indicating the volume identifier. Default is 1. +#' @param session_id An integer indicating a valid session/slot identifier +#' linked to a volume. Default value is 9807, the materials folder for volume 1. +#' @param file_id An integer indicating the file identifier. +#' @param rq An httr2 request object. +#' +#' @returns A JSON blob with the file data. If the user has previously logged +#' in to Databrary via `login_db()`, then files that have restricted access +#' can be downloaded, subject to the sharing release levels on those files. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' get_session_file(vol_id = 2, session_id = 11, file_id = 1) +#' } +#' } +#' @export +get_session_file <- + function(vol_id = 1, + session_id = 9807, + file_id, + vb = options::opt("vb"), + rq = NULL) { + + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(vol_id > 0) + assertthat::assert_that(length(vol_id) == 1) + + assertthat::assert_that(is.numeric(session_id)) + assertthat::assert_that(session_id > 0) + assertthat::assert_that(length(session_id) == 1) + + assertthat::assert_that(is.numeric(file_id)) + assertthat::assert_that(file_id > 0) + assertthat::assert_that(length(file_id) == 1) + + assertthat::assert_that(is.logical(vb)) + assertthat::assert_that(length(vb) == 1) + + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + file <- perform_api_get( + path = sprintf(API_SESSION_FILE_DETAIL, vol_id, session_id, file_id), + rq = rq, + vb = vb + ) + + if (is.null(file)) { + if (vb) { + message("Cannot access requested file ", file_id, " in session ", session_id, " of volume ", vol_id) + } + return(NULL) + } + + file + } diff --git a/man/get_session_file.Rd b/man/get_session_file.Rd new file mode 100644 index 00000000..041298ad --- /dev/null +++ b/man/get_session_file.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_session_file.R +\name{get_session_file} +\alias{get_session_file} +\title{Get Session File Data From A Databrary Volume} +\usage{ +get_session_file( + vol_id = 1, + session_id = 9807, + file_id, + vb = options::opt("vb"), + rq = NULL +) +} +\arguments{ +\item{vol_id}{An integer indicating the volume identifier. Default is 1.} + +\item{session_id}{An integer indicating a valid session/slot identifier +linked to a volume. Default value is 9807, the materials folder for volume 1.} + +\item{file_id}{An integer indicating the file identifier.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An httr2 request object.} +} +\value{ +A JSON blob with the file data. If the user has previously logged +in to Databrary via \code{login_db()}, then files that have restricted access +can be downloaded, subject to the sharing release levels on those files. +} +\description{ +Get Session File Data From A Databrary Volume +} +\examples{ +\donttest{ +\dontrun{ +get_session_file(vol_id = 2, session_id = 11, file_id = 1) +} +} +} diff --git a/tests/testthat/test-get_session_file.R b/tests/testthat/test-get_session_file.R new file mode 100644 index 00000000..dd6e300b --- /dev/null +++ b/tests/testthat/test-get_session_file.R @@ -0,0 +1,44 @@ +# get_session_file ------------------------------------------------------- +test_that("get_session_file returns file metadata", { + login_test_account() + files <- list_volume_session_assets(vol_id = 2, session_id = 11) + skip_if_null_response(files, "list_volume_session_assets(vol_id = 2, session_id = 11)") + + target_file <- files$asset_id[1] + result <- get_session_file(vol_id = 2, session_id = 11, file_id = target_file) + skip_if_null_response(result, sprintf("get_session_file(vol_id = 2, session_id = 11, file_id = %s)", target_file)) + + expect_type(result, "list") + expect_equal(result$id, target_file) + expect_true(all(c("id", "name") %in% names(result))) +}) + +test_that("get_session_file rejects bad input parameters", { + expect_error(get_session_file(vol_id = "a", file_id = 1)) + expect_error(get_session_file(vol_id = c(1, 2), file_id = 1)) + expect_error(get_session_file(vol_id = TRUE, file_id = 1)) + expect_error(get_session_file(vol_id = list(a = 1), file_id = 1)) + expect_error(get_session_file(vol_id = -1, file_id = 1)) + + expect_error(get_session_file(session_id = "a", file_id = 1)) + expect_error(get_session_file(session_id = c(1, 2), file_id = 1)) + expect_error(get_session_file(session_id = TRUE, file_id = 1)) + expect_error(get_session_file(session_id = list(a = 1), file_id = 1)) + expect_error(get_session_file(session_id = -1, file_id = 1)) + + expect_error(get_session_file(file_id = "a")) + expect_error(get_session_file(file_id = c(1, 2))) + expect_error(get_session_file(file_id = TRUE)) + expect_error(get_session_file(file_id = list(a = 1))) + expect_error(get_session_file(file_id = -1)) + + expect_error(get_session_file(file_id = 1, vb = -1)) + expect_error(get_session_file(file_id = 1, vb = 3)) + expect_error(get_session_file(file_id = 1, vb = "a")) + expect_error(get_session_file(file_id = 1, vb = list(a = 1))) + + expect_error(get_session_file(file_id = 1, rq = "a")) + expect_error(get_session_file(file_id = 1, rq = -1)) + expect_error(get_session_file(file_id = 1, rq = c(2, 3))) + expect_error(get_session_file(file_id = 1, rq = list(a = 1))) +}) From 2d1737d9ce2b37d9bf105b51f018fbeca1e4d51e Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Fri, 12 Dec 2025 10:31:33 +0100 Subject: [PATCH 16/27] chore: remove get_file_duration --- NAMESPACE | 1 - R/utils.R | 298 +++++++++++++----------------------- man/get_file_duration.Rd | 40 ----- tests/testthat/test-utils.R | 34 +--- 4 files changed, 108 insertions(+), 265 deletions(-) delete mode 100644 man/get_file_duration.Rd diff --git a/NAMESPACE b/NAMESPACE index f27b9b0e..270686d9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,7 +17,6 @@ export(download_video) export(download_volume_zip) export(get_category_by_id) export(get_db_stats) -export(get_file_duration) export(get_folder_by_id) export(get_funder_by_id) export(get_institution_avatar) diff --git a/R/utils.R b/R/utils.R index f605de05..e1e1059f 100644 --- a/R/utils.R +++ b/R/utils.R @@ -8,215 +8,131 @@ #' NULL -#' Get Duration (In ms) Of A File. -#' -#' @param vol_id Volume ID. -#' @param session_id Session ID containing the asset. -#' @param asset_id Asset number. -#' @param types_w_durations Asset types that have valid durations. -#' @param rq An `httr2` request object. Default is NULL. + +#---------------------------------------------------------------------------- +#' Extract Databrary Permission Levels. #' -#' @returns Duration of a file in ms. +#' @returns An array with the permission levels that can be assigned to data. #' #' @inheritParams options_params #' #' @examples #' \donttest{ -#' get_file_duration() # default is a public video from volume 1 +#' get_permission_levels() #' } #' #' @export -get_file_duration <- function(vol_id = 2, - session_id = 9, - asset_id = 2, - types_w_durations = c(-600, -800), - vb = options::opt("vb"), - rq = NULL) { - assertthat::assert_that(is.numeric(vol_id)) - assertthat::assert_that(vol_id > 0) - assertthat::assert_that(length(vol_id) == 1) - - assertthat::assert_that(is.numeric(session_id)) - assertthat::assert_that(session_id > 0) - assertthat::assert_that(length(session_id) == 1) - - assertthat::assert_that(is.numeric(asset_id)) - assertthat::assert_that(asset_id > 0) - assertthat::assert_that(length(asset_id) == 1) - - assertthat::assert_that(is.atomic(types_w_durations)) - - assertthat::assert_that(is.logical(vb)) - assertthat::assert_that(length(vb) == 1) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - - types_w_durations <- as.character(types_w_durations) - - asset <- perform_api_get( - path = sprintf(API_SESSION_FILE_DETAIL, vol_id, session_id, asset_id), - rq = rq, - vb = vb - ) - - if (is.null(asset)) { - message("Cannot access requested resource on Databrary. Exiting.") - return(NULL) - } - - format <- asset$format - format_id_chr <- as.character(format$id) - - if (!is.na(format_id_chr) && !(format_id_chr %in% types_w_durations)) { - if (vb) { - message("Asset format does not include duration metadata.") - } - return(NULL) - } - - duration_value <- asset$duration - - if (is.null(duration_value)) { - if (vb) { - message("Duration metadata not available for the requested asset.") - } - return(NULL) - } - - duration_value <- suppressWarnings(as.numeric(duration_value)) - - if (is.na(duration_value)) { - return(NULL) - } - - round(duration_value * 1000) -} - - #---------------------------------------------------------------------------- - #' Extract Databrary Permission Levels. - #' - #' @returns An array with the permission levels that can be assigned to data. - #' - #' @inheritParams options_params - #' - #' @examples - #' \donttest{ - #' get_permission_levels() - #' } - #' - #' @export get_permission_levels <- function(vb = options::opt("vb")) { enums <- get_permission_levels_enums() enums$volume_access_levels } - #---------------------------------------------------------------------------- - #' Convert Timestamp String To ms. - #' - #' @param HHMMSSmmm a string in the format "HH:MM:SS:mmm" - #' - #' @returns A numeric value in ms from the input string. - #' - #' @examples - #' HHMMSSmmm_to_ms() # 01:01:01:333 in ms - #' @export - HHMMSSmmm_to_ms <- function(HHMMSSmmm = "01:01:01:333") { - # Check parameters - if (!is.character(HHMMSSmmm)) { - stop("HHMMSSmmm must be a string.") - } - - if (stringr::str_detect(HHMMSSmmm, - "([0-9]{2}):([0-9]{2}):([0-9]{2}):([0-9]{3})")) { - time_segs <- stringr::str_match(HHMMSSmmm, - "([0-9]{2}):([0-9]{2}):([0-9]{2}):([0-9]{3})") - as.numeric(time_segs[5]) + as.numeric(time_segs[4]) * - 1000 + as.numeric(time_segs[3]) * 1000 * 60 + - as.numeric(time_segs[2]) * 1000 * 60 * 60 - } else { - NULL - } +#---------------------------------------------------------------------------- +#' Convert Timestamp String To ms. +#' +#' @param HHMMSSmmm a string in the format "HH:MM:SS:mmm" +#' +#' @returns A numeric value in ms from the input string. +#' +#' @examples +#' HHMMSSmmm_to_ms() # 01:01:01:333 in ms +#' @export +HHMMSSmmm_to_ms <- function(HHMMSSmmm = "01:01:01:333") { + # Check parameters + if (!is.character(HHMMSSmmm)) { + stop("HHMMSSmmm must be a string.") } - #---------------------------------------------------------------------------- - #' Show Databrary Release Levels - #' - #' @returns A data frame with Databrary's release levels. - #' - #' @inheritParams options_params - #' - #' @examples - #' \donttest{ - #' get_release_levels() - #' } - #' - #' @export - get_release_levels <- function(vb = options::opt("vb")) { - enums <- get_release_levels_enums() - vapply(enums$levels, function(item) item$code, character(1)) + if (stringr::str_detect(HHMMSSmmm, + "([0-9]{2}):([0-9]{2}):([0-9]{2}):([0-9]{3})")) { + time_segs <- stringr::str_match(HHMMSSmmm, + "([0-9]{2}):([0-9]{2}):([0-9]{2}):([0-9]{3})") + as.numeric(time_segs[5]) + as.numeric(time_segs[4]) * + 1000 + as.numeric(time_segs[3]) * 1000 * 60 + + as.numeric(time_segs[2]) * 1000 * 60 * 60 + } else { + NULL } +} + +#---------------------------------------------------------------------------- +#' Show Databrary Release Levels +#' +#' @returns A data frame with Databrary's release levels. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' get_release_levels() +#' } +#' +#' @export +get_release_levels <- function(vb = options::opt("vb")) { +enums <- get_release_levels_enums() +vapply(enums$levels, function(item) item$code, character(1)) +} + +#---------------------------------------------------------------------------- +#' Extracts File Types Supported by Databrary. +#' +#' +#' @returns A data frame with the file types permitted on Databrary. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' get_supported_file_types() +#' } +#' +#' @export +get_supported_file_types <- function(vb = options::opt("vb")) { +constants <- assign_constants(vb = vb) +constants$format_df |> + dplyr::rename( + asset_type = name, + asset_type_id = id, + asset_category = category + ) +} + +#---------------------------------------------------------------------------- +#' Make Portable File Names +#' +#' @param fn Databrary party ID +#' @param replace_regex A character string. A regular expression to capture +#' the "non-portable" characters in fn. +#' @param replacement_char A character string. The character(s) that will +#' replace the non-portable characters. +#' +#' @returns A "cleaned" portable file name +#' +#' @inheritParams options_params +#' +make_fn_portable <- function(fn, + vb = options::opt("vb"), + replace_regex = "[ &\\!\\)\\(\\}\\{\\[\\]\\+\\=@#\\$%\\^\\*]", + replacement_char = "_") { + assertthat::is.string(fn) + assertthat::assert_that(!is.numeric(fn)) + assertthat::assert_that(!is.logical(fn)) + assertthat::assert_that(length(fn) == 1) - #---------------------------------------------------------------------------- - #' Extracts File Types Supported by Databrary. - #' - #' - #' @returns A data frame with the file types permitted on Databrary. - #' - #' @inheritParams options_params - #' - #' @examples - #' \donttest{ - #' get_supported_file_types() - #' } - #' - #' @export - get_supported_file_types <- function(vb = options::opt("vb")) { - constants <- assign_constants(vb = vb) - constants$format_df |> - dplyr::rename( - asset_type = name, - asset_type_id = id, - asset_category = category - ) - } + assertthat::assert_that(is.logical(vb)) + assertthat::assert_that(length(vb) == 1) + + assertthat::is.string(replace_regex) + assertthat::assert_that(length(replace_regex) == 1) - #---------------------------------------------------------------------------- - #' Make Portable File Names - #' - #' @param fn Databrary party ID - #' @param replace_regex A character string. A regular expression to capture - #' the "non-portable" characters in fn. - #' @param replacement_char A character string. The character(s) that will - #' replace the non-portable characters. - #' - #' @returns A "cleaned" portable file name - #' - #' @inheritParams options_params - #' - make_fn_portable <- function(fn, - vb = options::opt("vb"), - replace_regex = "[ &\\!\\)\\(\\}\\{\\[\\]\\+\\=@#\\$%\\^\\*]", - replacement_char = "_") { - assertthat::is.string(fn) - assertthat::assert_that(!is.numeric(fn)) - assertthat::assert_that(!is.logical(fn)) - assertthat::assert_that(length(fn) == 1) - - assertthat::assert_that(is.logical(vb)) - assertthat::assert_that(length(vb) == 1) - - assertthat::is.string(replace_regex) - assertthat::assert_that(length(replace_regex) == 1) - - assertthat::is.string(replacement_char) - assertthat::assert_that(length(replacement_char) == 1) - - if (vb) { - non_portable_chars <- stringr::str_detect(fn, replace_regex) - message("There are ", sum(non_portable_chars), " in ", fn) - } - new_fn <- stringr::str_replace_all(fn, replace_regex, replacement_char) - new_fn + assertthat::is.string(replacement_char) + assertthat::assert_that(length(replacement_char) == 1) + + if (vb) { + non_portable_chars <- stringr::str_detect(fn, replace_regex) + message("There are ", sum(non_portable_chars), " in ", fn) } + new_fn <- stringr::str_replace_all(fn, replace_regex, replacement_char) + new_fn +} \ No newline at end of file diff --git a/man/get_file_duration.Rd b/man/get_file_duration.Rd deleted file mode 100644 index 2f85028d..00000000 --- a/man/get_file_duration.Rd +++ /dev/null @@ -1,40 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{get_file_duration} -\alias{get_file_duration} -\title{Get Duration (In ms) Of A File.} -\usage{ -get_file_duration( - vol_id = 2, - session_id = 9, - asset_id = 2, - types_w_durations = c(-600, -800), - vb = options::opt("vb"), - rq = NULL -) -} -\arguments{ -\item{vol_id}{Volume ID.} - -\item{session_id}{Session ID containing the asset.} - -\item{asset_id}{Asset number.} - -\item{types_w_durations}{Asset types that have valid durations.} - -\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} - -\item{rq}{An \code{httr2} request object. Default is NULL.} -} -\value{ -Duration of a file in ms. -} -\description{ -Get Duration (In ms) Of A File. -} -\examples{ -\donttest{ -get_file_duration() # default is a public video from volume 1 -} - -} diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index d0da8d1b..6286b45e 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -1,38 +1,6 @@ -# get_file_duration --------------------------------------------------------- -test_that("get_file_duration returns duration metadata for a known asset", { - login_test_account() - result <- get_file_duration() - skip_if_null_response(result, "get_file_duration()") - expect_true(is.numeric(result) && length(result) == 1) - - asset_detail <- perform_api_get( - path = sprintf(API_SESSION_FILE_DETAIL, 2, 9, 2), - vb = FALSE - ) - expect_true("thumbnail_url" %in% names(asset_detail)) - expect_true(is.null(asset_detail$thumbnail_url) || nzchar(asset_detail$thumbnail_url)) -}) - -test_that("get_file_duration rejects bad input parameters", { - expect_error(get_file_duration(vol_id = "a")) - expect_error(get_file_duration(vol_id = -1)) - expect_error(get_file_duration(vol_id = c(1, 3))) - - expect_error(get_file_duration(session_id = "a")) - expect_error(get_file_duration(session_id = -1)) - expect_error(get_file_duration(session_id = c(1, 3))) - - expect_error(get_file_duration(asset_id = "a")) - expect_error(get_file_duration(asset_id = -1)) - expect_error(get_file_duration(asset_id = c(1, 3))) - - expect_error(get_file_duration(vb = "a")) - expect_error(get_file_duration(vb = -1)) - expect_error(get_file_duration(vb = c(2, 3))) -}) - # get_permission_levels ------------------------------------------------------- test_that("get_permission_levels returns a character array", { + login_test_account() levels <- get_permission_levels() expect_true(is.character(levels)) expect_true(length(levels) > 0) From be72a51a5eae2ef88291c25119bdd02868403205 Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Fri, 12 Dec 2025 15:30:50 +0100 Subject: [PATCH 17/27] =?UTF-8?q?=1Bfeat:=20add=20get=5Ffolder=5Ffile=20fu?= =?UTF-8?q?nction=20with=20tests?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- NAMESPACE | 1 + R/CONSTANTS.R | 1 + R/get_folder_file.R | 65 +++++++++++++++++++++++++++ man/get_folder_file.Rd | 41 +++++++++++++++++ tests/testthat/test-get_folder_file.R | 44 ++++++++++++++++++ 5 files changed, 152 insertions(+) create mode 100644 R/get_folder_file.R create mode 100644 man/get_folder_file.Rd create mode 100644 tests/testthat/test-get_folder_file.R diff --git a/NAMESPACE b/NAMESPACE index 270686d9..a406a9d6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,6 +18,7 @@ export(download_volume_zip) export(get_category_by_id) export(get_db_stats) export(get_folder_by_id) +export(get_folder_file) export(get_funder_by_id) export(get_institution_avatar) export(get_institution_by_id) diff --git a/R/CONSTANTS.R b/R/CONSTANTS.R index 97199e5e..ec0a15e7 100644 --- a/R/CONSTANTS.R +++ b/R/CONSTANTS.R @@ -36,6 +36,7 @@ API_SESSION_DOWNLOAD_LINK <- "/volumes/%s/sessions/%s/download-link/" API_SESSION_CSV_DOWNLOAD_LINK <- "/volumes/%s/sessions/%s/csv-download-link/" API_FOLDER_DETAIL <- "/volumes/%s/folders/%s/" API_FOLDER_FILES <- "/volumes/%s/folders/%s/files/" +API_FOLDER_FILES_DETAIL <- "/volumes/%s/folders/%s/files/%s/" API_FOLDER_DOWNLOAD_LINK <- "/volumes/%s/folders/%s/download-link/" API_FOLDER_FILE_DOWNLOAD_LINK <- "/volumes/%s/folders/%s/files/%s/download-link/" API_VOLUME_DOWNLOAD_LINK <- "/volumes/%s/download-link/" diff --git a/R/get_folder_file.R b/R/get_folder_file.R new file mode 100644 index 00000000..997ca29c --- /dev/null +++ b/R/get_folder_file.R @@ -0,0 +1,65 @@ +#' @eval options::as_params() +#' @name options_params +#' +NULL + +#' Get Session File Data From A Databrary Volume +#' +#' @param vol_id An integer indicating the volume identifier. Default is 1. +#' @param folder_id An integer indicating a valid folder identifier +#' linked to a volume. Default value is 9807, the materials folder for volume 1. +#' @param file_id An integer indicating the file identifier. +#' @param rq An httr2 request object. +#' +#' @returns A JSON blob with the file data. If the user has previously logged +#' in to Databrary via `login_db()`, then files that have restricted access +#' can be downloaded, subject to the sharing release levels on those files. +#' +#' @inheritParams options_params +#' +#' @examples +#' \donttest{ +#' \dontrun{ +#' get_session_file(vol_id = 2, session_id = 11, file_id = 1) +#' } +#' } +#' @export +get_folder_file <- + function(vol_id = 1, + folder_id = 9807, + file_id, + vb = options::opt("vb"), + rq = NULL) { + + assertthat::assert_that(is.numeric(vol_id)) + assertthat::assert_that(vol_id > 0) + assertthat::assert_that(length(vol_id) == 1) + + assertthat::assert_that(is.numeric(folder_id)) + assertthat::assert_that(folder_id > 0) + assertthat::assert_that(length(folder_id) == 1) + + assertthat::assert_that(is.numeric(file_id)) + assertthat::assert_that(file_id > 0) + assertthat::assert_that(length(file_id) == 1) + + assertthat::assert_that(is.logical(vb)) + assertthat::assert_that(length(vb) == 1) + + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + + file <- perform_api_get( + path = sprintf(API_FOLDER_FILES_DETAIL, vol_id, folder_id, file_id), + rq = rq, + vb = vb + ) + + if (is.null(file)) { + if (vb) { + message("Cannot access requested file ", file_id, " in folder ", folder_id, " of volume ", vol_id) + } + return(NULL) + } + + file + } diff --git a/man/get_folder_file.Rd b/man/get_folder_file.Rd new file mode 100644 index 00000000..6154145f --- /dev/null +++ b/man/get_folder_file.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_folder_file.R +\name{get_folder_file} +\alias{get_folder_file} +\title{Get Session File Data From A Databrary Volume} +\usage{ +get_folder_file( + vol_id = 1, + folder_id = 9807, + file_id, + vb = options::opt("vb"), + rq = NULL +) +} +\arguments{ +\item{vol_id}{An integer indicating the volume identifier. Default is 1.} + +\item{folder_id}{An integer indicating a valid folder identifier +linked to a volume. Default value is 9807, the materials folder for volume 1.} + +\item{file_id}{An integer indicating the file identifier.} + +\item{vb}{Show verbose messages. (Defaults to \code{FALSE}, overwritable using option 'databraryr.vb' or environment variable 'R_DATABRARYR_VB')} + +\item{rq}{An httr2 request object.} +} +\value{ +A JSON blob with the file data. If the user has previously logged +in to Databrary via \code{login_db()}, then files that have restricted access +can be downloaded, subject to the sharing release levels on those files. +} +\description{ +Get Session File Data From A Databrary Volume +} +\examples{ +\donttest{ +\dontrun{ +get_session_file(vol_id = 2, session_id = 11, file_id = 1) +} +} +} diff --git a/tests/testthat/test-get_folder_file.R b/tests/testthat/test-get_folder_file.R new file mode 100644 index 00000000..21e88c0d --- /dev/null +++ b/tests/testthat/test-get_folder_file.R @@ -0,0 +1,44 @@ +# get_folder_file ------------------------------------------------------- +test_that("get_folder_file returns file metadata", { + login_test_account() + files <- list_folder_assets(vol_id = 1, folder_id = 1) + skip_if_null_response(files, "list_folder_assets(vol_id = 1, folder_id = 1)") + + target_file <- files$asset_id[1] + result <- get_folder_file(vol_id = 1, folder_id = 1, file_id = target_file) + skip_if_null_response(result, sprintf("get_folder_file(vol_id = 1, folder_id = 1, file_id = %s)", target_file)) + + expect_type(result, "list") + expect_equal(result$id, target_file) + expect_true(all(c("id", "name") %in% names(result))) +}) + +test_that("get_folder_file rejects bad input parameters", { + expect_error(get_folder_file(vol_id = "a", file_id = 1)) + expect_error(get_folder_file(vol_id = c(1, 2), file_id = 1)) + expect_error(get_folder_file(vol_id = TRUE, file_id = 1)) + expect_error(get_folder_file(vol_id = list(a = 1), file_id = 1)) + expect_error(get_folder_file(vol_id = -1, file_id = 1)) + + expect_error(get_folder_file(folder_id = "a", file_id = 1)) + expect_error(get_folder_file(folder_id = c(1, 2), file_id = 1)) + expect_error(get_folder_file(folder_id = TRUE, file_id = 1)) + expect_error(get_folder_file(folder_id = list(a = 1), file_id = 1)) + expect_error(get_folder_file(folder_id = -1, file_id = 1)) + + expect_error(get_folder_file(file_id = "a")) + expect_error(get_folder_file(file_id = c(1, 2))) + expect_error(get_folder_file(file_id = TRUE)) + expect_error(get_folder_file(file_id = list(a = 1))) + expect_error(get_folder_file(file_id = -1)) + + expect_error(get_folder_file(file_id = 1, vb = -1)) + expect_error(get_folder_file(file_id = 1, vb = 3)) + expect_error(get_folder_file(file_id = 1, vb = "a")) + expect_error(get_folder_file(file_id = 1, vb = list(a = 1))) + + expect_error(get_folder_file(file_id = 1, rq = "a")) + expect_error(get_folder_file(file_id = 1, rq = -1)) + expect_error(get_folder_file(file_id = 1, rq = c(2, 3))) + expect_error(get_folder_file(file_id = 1, rq = list(a = 1))) +}) From c8cc694456d3df4b2d31c6f17cd630d06c52f9e9 Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Tue, 16 Dec 2025 10:39:06 +0100 Subject: [PATCH 18/27] chore: format changed files --- R/get_category_by_id.R | 16 +-- R/get_db_stats.R | 111 ++++++++++++++------- R/get_folder_file.R | 22 +++-- R/get_funder_by_id.R | 16 +-- R/get_institution_avatar.R | 155 ++++++++++++++++++------------ R/get_session_file.R | 22 +++-- R/get_tag_by_id.R | 10 +- R/get_user_avatar.R | 25 +++-- R/get_volume_collaborator_by_id.R | 37 ++++--- R/get_volume_record_by_id.R | 30 ++++-- R/list_categories.R | 9 +- R/list_institutions.R | 64 +++++++++--- R/list_volume_records.R | 70 +++++++++++--- 13 files changed, 397 insertions(+), 190 deletions(-) diff --git a/R/get_category_by_id.R b/R/get_category_by_id.R index 1b137692..2119cf04 100644 --- a/R/get_category_by_id.R +++ b/R/get_category_by_id.R @@ -28,15 +28,19 @@ NULL #' } #' } #' @export -get_category_by_id <- function(category_id = 1, - vb = options::opt("vb"), - rq = NULL) { +get_category_by_id <- function( + category_id = 1, + vb = options::opt("vb"), + rq = NULL +) { # Validate category_id assertthat::assert_that(is.numeric(category_id)) assertthat::assert_that(length(category_id) == 1) assertthat::assert_that(category_id > 0) - assertthat::assert_that(category_id == floor(category_id), - msg = "category_id must be an integer") + assertthat::assert_that( + category_id == floor(category_id), + msg = "category_id must be an integer" + ) # Validate vb assertthat::assert_that(length(vb) == 1) @@ -83,4 +87,4 @@ get_category_by_id <- function(category_id = 1, category_description = category$description, metrics = metrics ) -} \ No newline at end of file +} diff --git a/R/get_db_stats.R b/R/get_db_stats.R index 239ac0f2..35809aec 100644 --- a/R/get_db_stats.R +++ b/R/get_db_stats.R @@ -1,6 +1,6 @@ #' @eval options::as_params() #' @name options_params -#' +#' NULL #' Get Stats About Databrary. @@ -11,11 +11,11 @@ NULL #' @param type Type of Databrary report to run "institutions", "people", "data" #' @param rq An `httr2` request object. #' -#' @returns A data frame with the requested data or NULL if there is +#' @returns A data frame with the requested data or NULL if there is #' no new information. #' #' @inheritParams options_params -#' +#' #' @examples #' \donttest{ #' get_db_stats() @@ -24,33 +24,34 @@ NULL #' get_db_stats("places") # Information about the newest institutions. #' } #' @export -get_db_stats <- function(type = "stats", - vb = options::opt("vb"), - rq = NULL) { +get_db_stats <- function(type = "stats", vb = options::opt("vb"), rq = NULL) { # Check parameters assertthat::assert_that(length(type) == 1) assertthat::assert_that(is.character(type)) assertthat::assert_that( - type %in% c( - "institutions", - "places", - "people", - "researchers", - "investigators", - "datasets", - "data", - "volumes", - "stats", - "numbers" - ) + type %in% + c( + "institutions", + "places", + "people", + "researchers", + "investigators", + "datasets", + "data", + "volumes", + "stats", + "numbers" + ) ) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) | - ("httr2_request" %in% class(rq))) - + + assertthat::assert_that( + is.null(rq) | + ("httr2_request" %in% class(rq)) + ) + if (is.null(rq)) { if (vb) { message("\nNULL request object. Will generate default.") @@ -63,27 +64,67 @@ get_db_stats <- function(type = "stats", rq = rq, vb = vb ) - + if (is.null(stats)) { message("Cannot access requested resource on Databrary. Exiting.") return(NULL) } - + if (type %in% c("stats", "numbers")) { # Map new API field names to output tibble::tibble( date = Sys.time(), - institutions = if (!is.null(stats$institutions)) stats$institutions else NA_integer_, - affiliates = if (!is.null(stats$affiliates)) stats$affiliates else NA_integer_, - investigators = if (!is.null(stats$investigators)) stats$investigators else NA_integer_, - hours_of_recordings = if (!is.null(stats$hours_of_recordings)) stats$hours_of_recordings else NA_integer_, + institutions = if (!is.null(stats$institutions)) { + stats$institutions + } else { + NA_integer_ + }, + affiliates = if (!is.null(stats$affiliates)) { + stats$affiliates + } else { + NA_integer_ + }, + investigators = if (!is.null(stats$investigators)) { + stats$investigators + } else { + NA_integer_ + }, + hours_of_recordings = if (!is.null(stats$hours_of_recordings)) { + stats$hours_of_recordings + } else { + NA_integer_ + }, # Legacy fields (may not be present in new API) - authorized_users = if (!is.null(stats$authorized_users)) stats$authorized_users else NA_integer_, - total_volumes = if (!is.null(stats$total_volumes)) stats$total_volumes else NA_integer_, - public_volumes = if (!is.null(stats$public_volumes)) stats$public_volumes else NA_integer_, - total_files = if (!is.null(stats$total_files)) stats$total_files else NA_integer_, - total_duration_hours = if (!is.null(stats$total_duration_hours)) stats$total_duration_hours else NA_real_, - total_storage_tb = if (!is.null(stats$total_storage_tb)) stats$total_storage_tb else NA_real_ + authorized_users = if (!is.null(stats$authorized_users)) { + stats$authorized_users + } else { + NA_integer_ + }, + total_volumes = if (!is.null(stats$total_volumes)) { + stats$total_volumes + } else { + NA_integer_ + }, + public_volumes = if (!is.null(stats$public_volumes)) { + stats$public_volumes + } else { + NA_integer_ + }, + total_files = if (!is.null(stats$total_files)) { + stats$total_files + } else { + NA_integer_ + }, + total_duration_hours = if (!is.null(stats$total_duration_hours)) { + stats$total_duration_hours + } else { + NA_real_ + }, + total_storage_tb = if (!is.null(stats$total_storage_tb)) { + stats$total_storage_tb + } else { + NA_real_ + } ) } else { # For other types, return the raw stats as a tibble diff --git a/R/get_folder_file.R b/R/get_folder_file.R index 997ca29c..57bc7e39 100644 --- a/R/get_folder_file.R +++ b/R/get_folder_file.R @@ -25,12 +25,13 @@ NULL #' } #' @export get_folder_file <- - function(vol_id = 1, - folder_id = 9807, - file_id, - vb = options::opt("vb"), - rq = NULL) { - + function( + vol_id = 1, + folder_id = 9807, + file_id, + vb = options::opt("vb"), + rq = NULL + ) { assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id > 0) assertthat::assert_that(length(vol_id) == 1) @@ -56,7 +57,14 @@ get_folder_file <- if (is.null(file)) { if (vb) { - message("Cannot access requested file ", file_id, " in folder ", folder_id, " of volume ", vol_id) + message( + "Cannot access requested file ", + file_id, + " in folder ", + folder_id, + " of volume ", + vol_id + ) } return(NULL) } diff --git a/R/get_funder_by_id.R b/R/get_funder_by_id.R index 01c688ed..b13c765a 100644 --- a/R/get_funder_by_id.R +++ b/R/get_funder_by_id.R @@ -27,15 +27,19 @@ NULL #' } #' } #' @export -get_funder_by_id <- function(funder_id = 1, - vb = options::opt("vb"), - rq = NULL) { +get_funder_by_id <- function( + funder_id = 1, + vb = options::opt("vb"), + rq = NULL +) { # Validate funder_id assertthat::assert_that(is.numeric(funder_id)) assertthat::assert_that(length(funder_id) == 1) assertthat::assert_that(funder_id > 0) - assertthat::assert_that(funder_id == floor(funder_id), - msg = "funder_id must be an integer") + assertthat::assert_that( + funder_id == floor(funder_id), + msg = "funder_id must be an integer" + ) # Validate vb assertthat::assert_that(length(vb) == 1) @@ -64,4 +68,4 @@ get_funder_by_id <- function(funder_id = 1, funder_name = funder$name, funder_is_approved = funder$is_approved ) -} \ No newline at end of file +} diff --git a/R/get_institution_avatar.R b/R/get_institution_avatar.R index 2ce3535e..836dcc64 100644 --- a/R/get_institution_avatar.R +++ b/R/get_institution_avatar.R @@ -47,16 +47,20 @@ NULL #' } #' } #' @export -get_institution_avatar <- function(institution_id = 1, - dest_path = NULL, - vb = options::opt("vb"), - rq = NULL) { +get_institution_avatar <- function( + institution_id = 1, + dest_path = NULL, + vb = options::opt("vb"), + rq = NULL +) { # Validate institution_id assertthat::assert_that(is.numeric(institution_id)) assertthat::assert_that(length(institution_id) == 1) assertthat::assert_that(institution_id > 0) - assertthat::assert_that(institution_id == floor(institution_id), - msg = "institution_id must be an integer") + assertthat::assert_that( + institution_id == floor(institution_id), + msg = "institution_id must be an integer" + ) # Validate dest_path if (!is.null(dest_path)) { @@ -92,72 +96,95 @@ get_institution_avatar <- function(institution_id = 1, } # Perform request - tryCatch({ - resp <- httr2::req_perform(req) - - # Check response status - status <- httr2::resp_status(resp) - if (status != 200) { - if (vb) { - message("Institution ", institution_id, " avatar not found or inaccessible (status: ", status, ")") + tryCatch( + { + resp <- httr2::req_perform(req) + + # Check response status + status <- httr2::resp_status(resp) + if (status != 200) { + if (vb) { + message( + "Institution ", + institution_id, + " avatar not found or inaccessible (status: ", + status, + ")" + ) + } + return(NULL) } - return(NULL) - } - # Get raw bytes - avatar_bytes <- httr2::resp_body_raw(resp) + # Get raw bytes + avatar_bytes <- httr2::resp_body_raw(resp) - if (is.null(dest_path)) { - # Return raw bytes - if (vb) { - message("Downloaded ", length(avatar_bytes), " bytes") - } - return(avatar_bytes) - } else { - # Resolve destination path - # If dest_path is a directory, determine filename from response headers or URL - final_path <- dest_path - if (dir.exists(dest_path)) { - # Try to get filename from content-disposition header - filename <- "downloaded_file" - content_disp <- httr2::resp_header(resp, "content-disposition") - - if (!is.null(content_disp) && grepl("filename=", content_disp)) { - # Extract filename from content-disposition header - filename_match <- regmatches(content_disp, regexpr("filename=([^;]+)", content_disp)) - if (length(filename_match) > 0) { - filename <- sub("filename=", "", filename_match) - filename <- gsub('^"|"$', '', filename) # Remove quotes - filename <- trimws(filename) - } - } else { - # Fallback: use URL path basename - url_path <- sprintf(API_INSTITUTION_AVATAR, institution_id) - filename <- paste0("institution_", institution_id, "_avatar.jpg") + if (is.null(dest_path)) { + # Return raw bytes + if (vb) { + message("Downloaded ", length(avatar_bytes), " bytes") } + return(avatar_bytes) + } else { + # Resolve destination path + # If dest_path is a directory, determine filename from response headers or URL + final_path <- dest_path + if (dir.exists(dest_path)) { + # Try to get filename from content-disposition header + filename <- "downloaded_file" + content_disp <- httr2::resp_header(resp, "content-disposition") + + if (!is.null(content_disp) && grepl("filename=", content_disp)) { + # Extract filename from content-disposition header + filename_match <- regmatches( + content_disp, + regexpr("filename=([^;]+)", content_disp) + ) + if (length(filename_match) > 0) { + filename <- sub("filename=", "", filename_match) + filename <- gsub('^"|"$', '', filename) # Remove quotes + filename <- trimws(filename) + } + } else { + # Fallback: use URL path basename + url_path <- sprintf(API_INSTITUTION_AVATAR, institution_id) + filename <- paste0("institution_", institution_id, "_avatar.jpg") + } - final_path <- file.path(dest_path, filename) - } + final_path <- file.path(dest_path, filename) + } - # Create parent directory if needed - parent_dir <- dirname(final_path) - if (!dir.exists(parent_dir)) { - dir.create(parent_dir, recursive = TRUE, showWarnings = FALSE) - } + # Create parent directory if needed + parent_dir <- dirname(final_path) + if (!dir.exists(parent_dir)) { + dir.create(parent_dir, recursive = TRUE, showWarnings = FALSE) + } - # Save to file - writeBin(avatar_bytes, final_path) + # Save to file + writeBin(avatar_bytes, final_path) + + if (vb) { + message( + "Saved avatar to: ", + final_path, + " (", + length(avatar_bytes), + " bytes)" + ) + } + return(normalizePath(final_path)) + } + }, + error = function(e) { if (vb) { - message("Saved avatar to: ", final_path, " (", length(avatar_bytes), " bytes)") + message( + "Error downloading avatar for institution ", + institution_id, + ": ", + e$message + ) } - - return(normalizePath(final_path)) - } - }, error = function(e) { - if (vb) { - message("Error downloading avatar for institution ", institution_id, ": ", e$message) + return(NULL) } - return(NULL) - }) -} \ No newline at end of file + ) +} diff --git a/R/get_session_file.R b/R/get_session_file.R index 895ce274..404d3ff7 100644 --- a/R/get_session_file.R +++ b/R/get_session_file.R @@ -25,12 +25,13 @@ NULL #' } #' @export get_session_file <- - function(vol_id = 1, - session_id = 9807, - file_id, - vb = options::opt("vb"), - rq = NULL) { - + function( + vol_id = 1, + session_id = 9807, + file_id, + vb = options::opt("vb"), + rq = NULL + ) { assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id > 0) assertthat::assert_that(length(vol_id) == 1) @@ -56,7 +57,14 @@ get_session_file <- if (is.null(file)) { if (vb) { - message("Cannot access requested file ", file_id, " in session ", session_id, " of volume ", vol_id) + message( + "Cannot access requested file ", + file_id, + " in session ", + session_id, + " of volume ", + vol_id + ) } return(NULL) } diff --git a/R/get_tag_by_id.R b/R/get_tag_by_id.R index 6f303145..529ea006 100644 --- a/R/get_tag_by_id.R +++ b/R/get_tag_by_id.R @@ -27,15 +27,15 @@ NULL #' } #' } #' @export -get_tag_by_id <- function(tag_id = 1, - vb = options::opt("vb"), - rq = NULL) { +get_tag_by_id <- function(tag_id = 1, vb = options::opt("vb"), rq = NULL) { # Validate tag_id assertthat::assert_that(is.numeric(tag_id)) assertthat::assert_that(length(tag_id) == 1) assertthat::assert_that(tag_id > 0) - assertthat::assert_that(tag_id == floor(tag_id), - msg = "tag_id must be an integer") + assertthat::assert_that( + tag_id == floor(tag_id), + msg = "tag_id must be an integer" + ) # Validate vb assertthat::assert_that(length(vb) == 1) diff --git a/R/get_user_avatar.R b/R/get_user_avatar.R index ae174b48..c9fa961b 100644 --- a/R/get_user_avatar.R +++ b/R/get_user_avatar.R @@ -40,10 +40,12 @@ NULL #' } #' } #' @export -get_user_avatar <- function(user_id, - dest_path = NULL, - vb = options::opt("vb"), - rq = NULL) { +get_user_avatar <- function( + user_id, + dest_path = NULL, + vb = options::opt("vb"), + rq = NULL +) { # Validate user_id assertthat::assert_that(length(user_id) == 1) assertthat::assert_that(is.numeric(user_id) || is.integer(user_id)) @@ -110,7 +112,11 @@ get_user_avatar <- function(user_id, # If no destination path, return bytes if (is.null(dest_path)) { if (vb) { - message("Returning avatar as raw bytes (", length(avatar_bytes), " bytes)") + message( + "Returning avatar as raw bytes (", + length(avatar_bytes), + " bytes)" + ) } return(avatar_bytes) } @@ -126,10 +132,13 @@ get_user_avatar <- function(user_id, if (!is.null(content_disp) && grepl("filename=", content_disp)) { # Extract filename from content-disposition header - filename_match <- regmatches(content_disp, regexpr("filename=([^;]+)", content_disp)) + filename_match <- regmatches( + content_disp, + regexpr("filename=([^;]+)", content_disp) + ) if (length(filename_match) > 0) { filename <- sub("filename=", "", filename_match) - filename <- gsub('^"|"$', '', filename) # Remove quotes + filename <- gsub('^"|"$', '', filename) # Remove quotes filename <- trimws(filename) } } else { @@ -163,4 +172,4 @@ get_user_avatar <- function(user_id, return(NULL) } ) -} \ No newline at end of file +} diff --git a/R/get_volume_collaborator_by_id.R b/R/get_volume_collaborator_by_id.R index 8137eea0..6819184c 100644 --- a/R/get_volume_collaborator_by_id.R +++ b/R/get_volume_collaborator_by_id.R @@ -32,23 +32,29 @@ NULL #' } #' } #' @export -get_volume_collaborator_by_id <- function(vol_id = 1, - collaborator_id = 1, - vb = options::opt("vb"), - rq = NULL) { +get_volume_collaborator_by_id <- function( + vol_id = 1, + collaborator_id = 1, + vb = options::opt("vb"), + rq = NULL +) { # Validate vol_id assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(vol_id >= 1) - assertthat::assert_that(vol_id == floor(vol_id), - msg = "vol_id must be an integer") + assertthat::assert_that( + vol_id == floor(vol_id), + msg = "vol_id must be an integer" + ) # Validate collaborator_id assertthat::assert_that(is.numeric(collaborator_id)) assertthat::assert_that(length(collaborator_id) == 1) assertthat::assert_that(collaborator_id > 0) - assertthat::assert_that(collaborator_id == floor(collaborator_id), - msg = "collaborator_id must be an integer") + assertthat::assert_that( + collaborator_id == floor(collaborator_id), + msg = "collaborator_id must be an integer" + ) # Validate vb assertthat::assert_that(length(vb) == 1) @@ -66,7 +72,13 @@ get_volume_collaborator_by_id <- function(vol_id = 1, if (is.null(collaborator)) { if (vb) { - message("Collaborator ", collaborator_id, " in volume ", vol_id, " not found or inaccessible.") + message( + "Collaborator ", + collaborator_id, + " in volume ", + vol_id, + " not found or inaccessible." + ) } return(NULL) } @@ -108,7 +120,10 @@ get_volume_collaborator_by_id <- function(vol_id = 1, # Process sponsored_users if present sponsored_users <- NULL - if (!is.null(collaborator$sponsored_users) && length(collaborator$sponsored_users) > 0) { + if ( + !is.null(collaborator$sponsored_users) && + length(collaborator$sponsored_users) > 0 + ) { sponsored_users <- lapply(collaborator$sponsored_users, function(u) { list( user_id = u$id, @@ -131,4 +146,4 @@ get_volume_collaborator_by_id <- function(vol_id = 1, expiration_date = collaborator$expiration_date, sponsored_users = sponsored_users ) -} \ No newline at end of file +} diff --git a/R/get_volume_record_by_id.R b/R/get_volume_record_by_id.R index 5638cef8..ea263481 100644 --- a/R/get_volume_record_by_id.R +++ b/R/get_volume_record_by_id.R @@ -31,23 +31,29 @@ NULL #' } #' } #' @export -get_volume_record_by_id <- function(vol_id = 1, - record_id = 1, - vb = options::opt("vb"), - rq = NULL) { +get_volume_record_by_id <- function( + vol_id = 1, + record_id = 1, + vb = options::opt("vb"), + rq = NULL +) { # Validate vol_id assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(vol_id >= 1) - assertthat::assert_that(vol_id == floor(vol_id), - msg = "vol_id must be an integer") + assertthat::assert_that( + vol_id == floor(vol_id), + msg = "vol_id must be an integer" + ) # Validate record_id assertthat::assert_that(is.numeric(record_id)) assertthat::assert_that(length(record_id) == 1) assertthat::assert_that(record_id > 0) - assertthat::assert_that(record_id == floor(record_id), - msg = "record_id must be an integer") + assertthat::assert_that( + record_id == floor(record_id), + msg = "record_id must be an integer" + ) # Validate vb assertthat::assert_that(length(vb) == 1) @@ -65,7 +71,13 @@ get_volume_record_by_id <- function(vol_id = 1, if (is.null(record)) { if (vb) { - message("Record ", record_id, " in volume ", vol_id, " not found or inaccessible.") + message( + "Record ", + record_id, + " in volume ", + vol_id, + " not found or inaccessible." + ) } return(NULL) } diff --git a/R/list_categories.R b/R/list_categories.R index 338a8b84..dcc2c9d8 100644 --- a/R/list_categories.R +++ b/R/list_categories.R @@ -27,8 +27,7 @@ NULL #' } #' } #' @export -list_categories <- function(vb = options::opt("vb"), - rq = NULL) { +list_categories <- function(vb = options::opt("vb"), rq = NULL) { # Validate vb assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) @@ -72,7 +71,11 @@ list_categories <- function(vb = options::opt("vb"), tibble::tibble( category_id = category$id, category_name = category$name, - category_description = if (is.null(category$description)) NA_character_ else category$description, + category_description = if (is.null(category$description)) { + NA_character_ + } else { + category$description + }, metrics = list(metrics) ) }) diff --git a/R/list_institutions.R b/R/list_institutions.R index 13d1392a..f86d3b50 100644 --- a/R/list_institutions.R +++ b/R/list_institutions.R @@ -33,9 +33,11 @@ NULL #' } #' } #' @export -list_institutions <- function(search_string = NULL, - vb = options::opt("vb"), - rq = NULL) { +list_institutions <- function( + search_string = NULL, + vb = options::opt("vb"), + rq = NULL +) { # Validate search_string if (!is.null(search_string)) { assertthat::assert_that(assertthat::is.string(search_string)) @@ -79,15 +81,51 @@ list_institutions <- function(search_string = NULL, institution_id = entry$id, institution_name = entry$name, institution_url = if (is.null(entry$url)) NA_character_ else entry$url, - institution_date_signed = if (is.null(entry$date_signed)) NA_character_ else as.character(entry$date_signed), - institution_source = if (is.null(entry$source)) NA_character_ else entry$source, - institution_created_at = if (is.null(entry$created_at)) NA_character_ else as.character(entry$created_at), - institution_updated_at = if (is.null(entry$updated_at)) NA_character_ else as.character(entry$updated_at), - institution_has_avatar = if (is.null(entry$has_avatar)) NA else entry$has_avatar, - institution_has_administrators = if (is.null(entry$has_administrators)) NA else entry$has_administrators, - institution_latitude = if (is.null(entry$latitude)) NA_real_ else as.numeric(entry$latitude), - institution_longitude = if (is.null(entry$longitude)) NA_real_ else as.numeric(entry$longitude), - institution_manual_coordinates = if (is.null(entry$manual_coordinates)) NA else entry$manual_coordinates + institution_date_signed = if (is.null(entry$date_signed)) { + NA_character_ + } else { + as.character(entry$date_signed) + }, + institution_source = if (is.null(entry$source)) { + NA_character_ + } else { + entry$source + }, + institution_created_at = if (is.null(entry$created_at)) { + NA_character_ + } else { + as.character(entry$created_at) + }, + institution_updated_at = if (is.null(entry$updated_at)) { + NA_character_ + } else { + as.character(entry$updated_at) + }, + institution_has_avatar = if (is.null(entry$has_avatar)) { + NA + } else { + entry$has_avatar + }, + institution_has_administrators = if (is.null(entry$has_administrators)) { + NA + } else { + entry$has_administrators + }, + institution_latitude = if (is.null(entry$latitude)) { + NA_real_ + } else { + as.numeric(entry$latitude) + }, + institution_longitude = if (is.null(entry$longitude)) { + NA_real_ + } else { + as.numeric(entry$longitude) + }, + institution_manual_coordinates = if (is.null(entry$manual_coordinates)) { + NA + } else { + entry$manual_coordinates + } ) }) -} \ No newline at end of file +} diff --git a/R/list_volume_records.R b/R/list_volume_records.R index c67ffdf3..69b61ad5 100644 --- a/R/list_volume_records.R +++ b/R/list_volume_records.R @@ -34,24 +34,30 @@ NULL #' } #' } #' @export -list_volume_records <- function(vol_id = 1, - category_id = NULL, - vb = options::opt("vb"), - rq = NULL) { +list_volume_records <- function( + vol_id = 1, + category_id = NULL, + vb = options::opt("vb"), + rq = NULL +) { # Validate vol_id assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - assertthat::assert_that(vol_id == floor(vol_id), - msg = "vol_id must be an integer") + assertthat::assert_that( + vol_id == floor(vol_id), + msg = "vol_id must be an integer" + ) # Validate category_id if (!is.null(category_id)) { assertthat::assert_that(length(category_id) == 1) assertthat::assert_that(is.numeric(category_id)) assertthat::assert_that(category_id > 0) - assertthat::assert_that(category_id == floor(category_id), - msg = "category_id must be an integer") + assertthat::assert_that( + category_id == floor(category_id), + msg = "category_id must be an integer" + ) } # Validate vb @@ -94,13 +100,41 @@ list_volume_records <- function(vol_id = 1, age_is_blurred <- NA if (!is.null(record$age)) { - age_years <- if (!is.null(record$age$years)) record$age$years else NA_integer_ - age_months <- if (!is.null(record$age$months)) record$age$months else NA_integer_ - age_days <- if (!is.null(record$age$days)) record$age$days else NA_integer_ - age_total_days <- if (!is.null(record$age$total_days)) record$age$total_days else NA_integer_ - age_formatted <- if (!is.null(record$age$formatted_value)) record$age$formatted_value else NA_character_ - age_is_estimated <- if (!is.null(record$age$is_estimated)) record$age$is_estimated else NA - age_is_blurred <- if (!is.null(record$age$is_blurred)) record$age$is_blurred else NA + age_years <- if (!is.null(record$age$years)) { + record$age$years + } else { + NA_integer_ + } + age_months <- if (!is.null(record$age$months)) { + record$age$months + } else { + NA_integer_ + } + age_days <- if (!is.null(record$age$days)) { + record$age$days + } else { + NA_integer_ + } + age_total_days <- if (!is.null(record$age$total_days)) { + record$age$total_days + } else { + NA_integer_ + } + age_formatted <- if (!is.null(record$age$formatted_value)) { + record$age$formatted_value + } else { + NA_character_ + } + age_is_estimated <- if (!is.null(record$age$is_estimated)) { + record$age$is_estimated + } else { + NA + } + age_is_blurred <- if (!is.null(record$age$is_blurred)) { + record$age$is_blurred + } else { + NA + } } tibble::tibble( @@ -108,7 +142,11 @@ list_volume_records <- function(vol_id = 1, record_volume = record$volume, record_category_id = record$category_id, record_measures = list(record$measures), - record_birthday = if (is.null(record$birthday)) NA_character_ else as.character(record$birthday), + record_birthday = if (is.null(record$birthday)) { + NA_character_ + } else { + as.character(record$birthday) + }, age_years = age_years, age_months = age_months, age_days = age_days, From 09e2238eb4b3df4c326bb63aa800402b7e05ec96 Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Tue, 16 Dec 2025 10:42:13 +0100 Subject: [PATCH 19/27] fix(doc): fix documentation for get_folder_file. --- R/get_folder_file.R | 2 +- man/get_folder_file.Rd | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/get_folder_file.R b/R/get_folder_file.R index 57bc7e39..14999688 100644 --- a/R/get_folder_file.R +++ b/R/get_folder_file.R @@ -20,7 +20,7 @@ NULL #' @examples #' \donttest{ #' \dontrun{ -#' get_session_file(vol_id = 2, session_id = 11, file_id = 1) +#' get_folder_file(vol_id = 2, folder_id = 11, file_id = 1) #' } #' } #' @export diff --git a/man/get_folder_file.Rd b/man/get_folder_file.Rd index 6154145f..41889851 100644 --- a/man/get_folder_file.Rd +++ b/man/get_folder_file.Rd @@ -35,7 +35,7 @@ Get Session File Data From A Databrary Volume \examples{ \donttest{ \dontrun{ -get_session_file(vol_id = 2, session_id = 11, file_id = 1) +get_folder_file(vol_id = 2, folder_id = 11, file_id = 1) } } } From 00340d20f94ad28867faa7f1e0564f486939cb46 Mon Sep 17 00:00:00 2001 From: rogilmore Date: Mon, 2 Feb 2026 07:46:32 -0500 Subject: [PATCH 20/27] Test push to github with trivial change to CONSTANTS. --- R/CONSTANTS.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/CONSTANTS.R b/R/CONSTANTS.R index ec0a15e7..36e1c0b7 100644 --- a/R/CONSTANTS.R +++ b/R/CONSTANTS.R @@ -1,7 +1,8 @@ #' Load Package-wide Constants into Local Environment #' #' -DATABRARY_BASE_URL <- Sys.getenv("DATABRARY_BASE_URL", "https://api.stg-databrary.its.nyu.edu") +# DATABRARY_BASE_URL <- Sys.getenv("DATABRARY_BASE_URL", "https://api.stg-databrary.its.nyu.edu") +DATABRARY_BASE_URL <- Sys.getenv("DATABRARY_BASE_URL", "https://api.databrary.org") API_ACTIVITY_SUMMARY <- "/statistics/summary/" API_GROUPED_FORMATS <- "/grouped-formats/" From 7dcbe6b8579d4988b29d7aad43f584d395c41bce Mon Sep 17 00:00:00 2001 From: rogilmore Date: Mon, 2 Feb 2026 07:46:32 -0500 Subject: [PATCH 21/27] Add doc strings to header for `vb` parameter for all documented functions; Changed some default parameters to make function testing easier. --- R/CONSTANTS.R | 3 +- R/assign_constants.R | 1 + R/download_folder_asset.R | 14 +- R/download_folder_assets_fr_df.R | 29 ++-- R/download_folder_zip.R | 15 +- R/download_session_asset.R | 73 +++++---- R/download_session_assets_fr_df.R | 26 +-- R/download_session_csv.R | 14 +- R/download_session_zip.R | 12 +- R/download_single_folder_asset_fr_df.R | 47 +++--- R/download_single_session_asset_fr_df.R | 46 +++--- R/download_video.R | 23 +-- R/download_volume_zip.R | 3 +- R/get_category_by_id.R | 29 ++-- R/get_db_stats.R | 1 + R/get_folder_by_id.R | 22 +-- R/get_folder_file.R | 30 ++-- R/get_funder_by_id.R | 27 ++-- R/get_institution_avatar.R | 202 ++++++++++++------------ R/get_institution_by_id.R | 3 +- R/get_session_by_id.R | 1 + R/get_session_by_name.R | 18 ++- R/get_session_file.R | 30 ++-- R/get_tag_by_id.R | 36 ++--- R/get_user_avatar.R | 122 +++++++------- R/get_user_by_id.R | 18 ++- R/get_volume_by_id.R | 3 +- R/get_volume_collaborator_by_id.R | 50 +++--- R/get_volume_record_by_id.R | 5 +- R/list_asset_formats.R | 4 + R/list_authorized_investigators.R | 18 ++- R/list_categories.R | 23 ++- R/list_folder_assets.R | 37 +++-- R/list_institution_affiliates.R | 26 ++- R/list_institutions.R | 29 ++-- R/list_session_activity.R | 57 ++++--- R/list_session_assets.R | 1 + R/list_user_affiliates.R | 11 +- R/list_user_history.R | 18 +-- R/list_user_sponsors.R | 27 ++-- R/list_user_volumes.R | 7 +- R/list_users.R | 1 + R/list_volume_activity.R | 5 +- R/list_volume_assets.R | 3 +- R/list_volume_collaborators.R | 91 ++++++++--- R/list_volume_folders.R | 19 +-- R/list_volume_funding.R | 9 +- R/list_volume_info.R | 5 +- R/list_volume_links.R | 7 +- R/list_volume_records.R | 42 +++-- R/list_volume_session_assets.R | 3 +- R/list_volume_sessions.R | 3 +- R/list_volume_tags.R | 3 +- R/list_volumes.R | 3 +- R/login_db.R | 2 +- R/logout_db.R | 2 +- R/make_default_request.R | 1 + R/make_login_client.R | 1 + R/search_for_funder.R | 3 +- R/search_for_tags.R | 1 + R/search_institutions.R | 31 ++-- R/search_users.R | 1 + R/search_volumes.R | 1 + R/whoami.R | 32 ++-- 64 files changed, 785 insertions(+), 645 deletions(-) diff --git a/R/CONSTANTS.R b/R/CONSTANTS.R index ec0a15e7..36e1c0b7 100644 --- a/R/CONSTANTS.R +++ b/R/CONSTANTS.R @@ -1,7 +1,8 @@ #' Load Package-wide Constants into Local Environment #' #' -DATABRARY_BASE_URL <- Sys.getenv("DATABRARY_BASE_URL", "https://api.stg-databrary.its.nyu.edu") +# DATABRARY_BASE_URL <- Sys.getenv("DATABRARY_BASE_URL", "https://api.stg-databrary.its.nyu.edu") +DATABRARY_BASE_URL <- Sys.getenv("DATABRARY_BASE_URL", "https://api.databrary.org") API_ACTIVITY_SUMMARY <- "/statistics/summary/" API_GROUPED_FORMATS <- "/grouped-formats/" diff --git a/R/assign_constants.R b/R/assign_constants.R index 3ebb5c6e..25360652 100644 --- a/R/assign_constants.R +++ b/R/assign_constants.R @@ -5,6 +5,7 @@ NULL #' Download Databrary Constants From API. #' +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to NULL. #' #' @returns A data frame with the constants. diff --git a/R/download_folder_asset.R b/R/download_folder_asset.R index 9ad295d2..9081a1dd 100644 --- a/R/download_folder_asset.R +++ b/R/download_folder_asset.R @@ -17,6 +17,7 @@ NULL #' asset. Defaults to the API-provided file name. #' @param target_dir Character string. Directory where the file will be saved. #' Default is `tempdir()`. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Default is `NULL`, in which case a #' default authenticated request is generated. #' @param timeout_secs Numeric. Timeout (seconds) applied to the download @@ -31,16 +32,16 @@ NULL #' \donttest{ #' \dontrun{ #' download_folder_asset() # Default public asset in folder 1 of volume 1 -#' download_folder_asset(vol_id = 1, folder_id = 2, asset_id = 3, -#' file_name = "example.mp4") +#' download_folder_asset(vol_id = 1, folder_id = 8460, asset_id = 19919, +#' file_name = "video.mp4") #' } #' } #' #' @export download_folder_asset <- function(vol_id = 1, - folder_id = 1, - asset_id = 1, - file_name = NULL, + folder_id = 8460, + asset_id = 19919, + file_name = "video.mp4", target_dir = tempdir(), timeout_secs = REQUEST_TIMEOUT, vb = options::opt("vb"), @@ -122,6 +123,3 @@ download_folder_asset <- function(vol_id = 1, vb = vb ) } - - - diff --git a/R/download_folder_assets_fr_df.R b/R/download_folder_assets_fr_df.R index ae1ef3de..aa92a404 100644 --- a/R/download_folder_assets_fr_df.R +++ b/R/download_folder_assets_fr_df.R @@ -21,6 +21,7 @@ NULL #' @param make_portable_fn Logical. When `TRUE`, filenames are sanitized via #' `make_fn_portable()`. #' @param timeout_secs Numeric. Timeout applied to each download request. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An optional `httr2` request object reused when requesting signed #' links. #' @@ -57,7 +58,7 @@ download_folder_assets_fr_df <- call. = FALSE ) } - + assertthat::assert_that(length(target_dir) == 1) assertthat::assert_that(is.character(target_dir)) if (dir.exists(target_dir)) { @@ -68,32 +69,35 @@ download_folder_assets_fr_df <- return(NULL) } } else { - dir.create(target_dir, recursive = TRUE, showWarnings = FALSE) + dir.create(target_dir, + recursive = TRUE, + showWarnings = FALSE) } assertthat::is.writeable(target_dir) - + assertthat::assert_that(length(add_folder_subdir) == 1) assertthat::assert_that(is.logical(add_folder_subdir)) - + assertthat::assert_that(length(overwrite) == 1) assertthat::assert_that(is.logical(overwrite)) - + assertthat::assert_that(length(make_portable_fn) == 1) assertthat::assert_that(is.logical(make_portable_fn)) - + assertthat::is.number(timeout_secs) assertthat::assert_that(length(timeout_secs) == 1) assertthat::assert_that(timeout_secs > 0) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) - + + assertthat::assert_that(is.null(rq) || + ("httr2_request" %in% class(rq))) + if (vb) { message("Downloading n=", nrow(folder_df), " files to ", target_dir) } - + purrr::map( seq_len(nrow(folder_df)), download_single_folder_asset_fr_df, @@ -109,6 +113,3 @@ download_folder_assets_fr_df <- ) |> purrr::list_c() } - - - diff --git a/R/download_folder_zip.R b/R/download_folder_zip.R index 4323306b..4a762446 100644 --- a/R/download_folder_zip.R +++ b/R/download_folder_zip.R @@ -13,6 +13,7 @@ NULL #' #' @param vol_id Volume identifier for the folder. #' @param folder_id Folder identifier scoped within the specified volume. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Default is `NULL`, in which case a #' default authenticated request is generated. #' @@ -36,19 +37,17 @@ download_folder_zip <- function(vol_id = 1, assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - + assertthat::assert_that(length(folder_id) == 1) assertthat::assert_that(is.numeric(folder_id)) assertthat::assert_that(folder_id >= 1) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) - + + assertthat::assert_that(is.null(rq) || + ("httr2_request" %in% class(rq))) + path <- sprintf(API_FOLDER_DOWNLOAD_LINK, vol_id, folder_id) request_processing_task(path = path, rq = rq, vb = vb) } - - - diff --git a/R/download_session_asset.R b/R/download_session_asset.R index 89217ea6..f85687c5 100644 --- a/R/download_session_asset.R +++ b/R/download_session_asset.R @@ -17,10 +17,12 @@ NULL #' API-provided file name. #' @param target_dir Character string. Directory where the file will be saved. #' Default is `tempdir()`. -#' @param rq An `httr2` request object. Default is `NULL`, in which case a -#' default authenticated request is generated. #' @param timeout_secs Numeric. Timeout (seconds) applied to the download #' request. Default is `REQUEST_TIMEOUT`. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. +#' @param rq An `httr2` request object. Default is `NULL`, in which case a +#' default authenticated request is generated. + #' #' @returns The path to the downloaded file (character string) or `NULL` if the #' download fails. @@ -47,73 +49,70 @@ download_session_asset <- function(vol_id = 1, assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - + assertthat::assert_that(length(session_id) == 1) assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id >= 1) - + assertthat::assert_that(length(asset_id) == 1) assertthat::assert_that(is.numeric(asset_id)) assertthat::assert_that(asset_id >= 1) - + if (!is.null(file_name)) { assertthat::assert_that(length(file_name) == 1) assertthat::assert_that(is.character(file_name)) } - + assertthat::assert_that(length(target_dir) == 1) assertthat::assert_that(is.character(target_dir)) assertthat::assert_that(dir.exists(target_dir)) - + assertthat::is.number(timeout_secs) assertthat::assert_that(length(timeout_secs) == 1) assertthat::assert_that(timeout_secs > 0) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) - + + assertthat::assert_that(is.null(rq) || + ("httr2_request" %in% class(rq))) + path <- sprintf(API_FILES_DOWNLOAD_LINK, vol_id, session_id, asset_id) link <- request_signed_download_link(path = path, rq = rq, vb = vb) - + if (is.null(link)) { return(NULL) } - + resolved_name <- if (!is.null(file_name)) { file_name } else if (!is.null(link$file_name)) { link$file_name } else { - paste0( - session_id, - "-", - asset_id, - "-", - format(Sys.time(), "%F-%H%M-%S"), - ".bin" - ) + paste0(session_id, + "-", + asset_id, + "-", + format(Sys.time(), "%F-%H%M-%S"), + ".bin") } - + dest_path <- file.path(target_dir, resolved_name) - + if (file.exists(dest_path)) { - dest_path <- file.path( - target_dir, - paste0( - tools::file_path_sans_ext(resolved_name), - "-", - format(Sys.time(), "%F-%H%M-%S"), - ifelse( - nzchar(tools::file_ext(resolved_name)), - paste0(".", tools::file_ext(resolved_name)), - "" - ) - ) - ) + dest_path <- file.path(target_dir, + paste0( + tools::file_path_sans_ext(resolved_name), + "-", + format(Sys.time(), "%F-%H%M-%S"), + ifelse( + nzchar(tools::file_ext(resolved_name)), + paste0(".", tools::file_ext(resolved_name)), + "" + ) + )) } - + download_signed_file( download_url = link$download_url, dest_path = dest_path, diff --git a/R/download_session_assets_fr_df.R b/R/download_session_assets_fr_df.R index b34b5fcb..f26cda2c 100644 --- a/R/download_session_assets_fr_df.R +++ b/R/download_session_assets_fr_df.R @@ -21,6 +21,7 @@ NULL #' @param make_portable_fn Logical. When `TRUE`, filenames are sanitized via #' `make_fn_portable()`. #' @param timeout_secs Numeric. Timeout applied to each download request. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An optional `httr2` request object reused when requesting signed #' links. #' @@ -56,7 +57,7 @@ download_session_assets_fr_df <- call. = FALSE ) } - + assertthat::assert_that(length(target_dir) == 1) assertthat::assert_that(is.character(target_dir)) if (dir.exists(target_dir)) { @@ -67,32 +68,35 @@ download_session_assets_fr_df <- return(NULL) } } else { - dir.create(target_dir, recursive = TRUE, showWarnings = FALSE) + dir.create(target_dir, + recursive = TRUE, + showWarnings = FALSE) } assertthat::is.writeable(target_dir) - + assertthat::assert_that(length(add_session_subdir) == 1) assertthat::assert_that(is.logical(add_session_subdir)) - + assertthat::assert_that(length(overwrite) == 1) assertthat::assert_that(is.logical(overwrite)) - + assertthat::assert_that(length(make_portable_fn) == 1) assertthat::assert_that(is.logical(make_portable_fn)) - + assertthat::is.number(timeout_secs) assertthat::assert_that(length(timeout_secs) == 1) assertthat::assert_that(timeout_secs > 0) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) - + + assertthat::assert_that(is.null(rq) || + ("httr2_request" %in% class(rq))) + if (vb) { message("Downloading n=", nrow(session_df), " files to ", target_dir) } - + purrr::map( seq_len(nrow(session_df)), download_single_session_asset_fr_df, diff --git a/R/download_session_csv.R b/R/download_session_csv.R index 87e6f400..90db279e 100644 --- a/R/download_session_csv.R +++ b/R/download_session_csv.R @@ -14,6 +14,7 @@ NULL #' @param vol_id Integer. Target volume identifier. Default is 1. #' @param session_id Optional integer. When provided, requests a session-level #' CSV export. When `NULL`, a volume-level CSV export is requested. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Default is `NULL`, meaning a default #' authenticated request is generated. #' @@ -41,23 +42,24 @@ download_session_csv <- function(vol_id = 1, assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - + if (!is.null(session_id)) { assertthat::assert_that(length(session_id) == 1) assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id >= 1) } - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) - + + assertthat::assert_that(is.null(rq) || + ("httr2_request" %in% class(rq))) + path <- if (is.null(session_id)) { sprintf(API_VOLUME_CSV_DOWNLOAD_LINK, vol_id) } else { sprintf(API_SESSION_CSV_DOWNLOAD_LINK, vol_id, session_id) } - + request_processing_task(path = path, rq = rq, vb = vb) } diff --git a/R/download_session_zip.R b/R/download_session_zip.R index 440a1be3..066b774f 100644 --- a/R/download_session_zip.R +++ b/R/download_session_zip.R @@ -13,6 +13,7 @@ NULL #' #' @param vol_id Volume identifier that owns the session. #' @param session_id Session identifier within the volume. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Default is `NULL`, in which case a #' default authenticated request is generated. #' @@ -36,16 +37,17 @@ download_session_zip <- function(vol_id = 31, assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - + assertthat::assert_that(length(session_id) == 1) assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id >= 1) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) - + + assertthat::assert_that(is.null(rq) || + ("httr2_request" %in% class(rq))) + path <- sprintf(API_SESSION_DOWNLOAD_LINK, vol_id, session_id) request_processing_task(path = path, rq = rq, vb = vb) } diff --git a/R/download_single_folder_asset_fr_df.R b/R/download_single_folder_asset_fr_df.R index 807c5945..98fc2e60 100644 --- a/R/download_single_folder_asset_fr_df.R +++ b/R/download_single_folder_asset_fr_df.R @@ -19,6 +19,7 @@ NULL #' @param make_portable_fn Logical. When `TRUE`, filenames are sanitized via #' `make_fn_portable()`. #' @param timeout_secs Numeric. Timeout applied to the signed download request. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq Optional `httr2` request object reused to request signed links. #' #' @returns Path to the downloaded asset or `NULL` if the download fails. @@ -38,7 +39,7 @@ download_single_folder_asset_fr_df <- function(i = NULL, assertthat::assert_that(length(i) == 1) assertthat::is.number(i) assertthat::assert_that(i > 0) - + assertthat::assert_that(is.data.frame(folder_df)) required_cols <- c("vol_id", "folder_id", "asset_id", "asset_name") missing_cols <- setdiff(required_cols, names(folder_df)) @@ -49,30 +50,34 @@ download_single_folder_asset_fr_df <- function(i = NULL, call. = FALSE ) } - + assertthat::assert_that(length(target_dir) == 1) assertthat::is.string(target_dir) - assertthat::assert_that(dir.exists(target_dir) || dir.create(target_dir, recursive = TRUE, showWarnings = FALSE)) + assertthat::assert_that( + dir.exists(target_dir) || + dir.create(target_dir, recursive = TRUE, showWarnings = FALSE) + ) assertthat::is.writeable(target_dir) - + assertthat::assert_that(length(add_folder_subdir) == 1) assertthat::assert_that(is.logical(add_folder_subdir)) - + assertthat::assert_that(length(overwrite) == 1) assertthat::assert_that(is.logical(overwrite)) - + assertthat::assert_that(length(make_portable_fn) == 1) assertthat::assert_that(is.logical(make_portable_fn)) - + assertthat::is.number(timeout_secs) assertthat::assert_that(length(timeout_secs) == 1) assertthat::assert_that(timeout_secs > 0) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) - + + assertthat::assert_that(is.null(rq) || + ("httr2_request" %in% class(rq))) + this_asset <- folder_df[i, , drop = FALSE] if (nrow(this_asset) == 0) { if (vb) { @@ -80,7 +85,7 @@ download_single_folder_asset_fr_df <- function(i = NULL, } return(NULL) } - + dest_dir <- if (isTRUE(add_folder_subdir)) { file.path(target_dir, this_asset$folder_id) } else { @@ -89,31 +94,32 @@ download_single_folder_asset_fr_df <- function(i = NULL, dir.create(dest_dir, recursive = TRUE, showWarnings = FALSE) assertthat::assert_that(dir.exists(dest_dir)) assertthat::is.writeable(dest_dir) - + base_name <- this_asset$asset_name if (is.null(base_name) || is.na(base_name) || base_name == "") { base_name <- paste0("asset-", this_asset$asset_id) } - + extension <- "" if ("format_extension" %in% names(this_asset)) { ext_value <- this_asset$format_extension - if (!is.null(ext_value) && !is.na(ext_value) && nzchar(ext_value)) { + if (!is.null(ext_value) && + !is.na(ext_value) && nzchar(ext_value)) { if (tools::file_ext(base_name) != ext_value) { extension <- paste0(".", ext_value) } } } - + candidate_name <- paste0(base_name, extension) - + if (make_portable_fn) { if (vb) { message("Making file name '", candidate_name, "' portable.") } candidate_name <- make_fn_portable(candidate_name, vb = vb) } - + dest_file <- file.path(dest_dir, candidate_name) if (file.exists(dest_file) && !overwrite) { if (vb) { @@ -133,7 +139,7 @@ download_single_folder_asset_fr_df <- function(i = NULL, ) dest_file <- file.path(dest_dir, candidate_name) } - + download_folder_asset( vol_id = this_asset$vol_id, folder_id = this_asset$folder_id, @@ -145,6 +151,3 @@ download_single_folder_asset_fr_df <- function(i = NULL, rq = rq ) } - - - diff --git a/R/download_single_session_asset_fr_df.R b/R/download_single_session_asset_fr_df.R index ce4fe68a..d96fc7eb 100644 --- a/R/download_single_session_asset_fr_df.R +++ b/R/download_single_session_asset_fr_df.R @@ -1,6 +1,6 @@ #' @eval options::as_params() #' @name options_params -#' +#' NULL #' Download a Single Asset From a Session Data Frame Row. @@ -19,6 +19,7 @@ NULL #' @param make_portable_fn Logical. When `TRUE`, filenames are sanitized via #' `make_fn_portable()`. #' @param timeout_secs Numeric. Timeout applied to the signed download request. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq Optional `httr2` request object reused to request signed links. #' #' @returns Path to the downloaded asset or `NULL` if the download fails. @@ -38,7 +39,7 @@ download_single_session_asset_fr_df <- function(i = NULL, assertthat::assert_that(length(i) == 1) assertthat::is.number(i) assertthat::assert_that(i > 0) - + assertthat::assert_that(is.data.frame(session_df)) required_cols <- c("vol_id", "session_id", "asset_id", "asset_name") missing_cols <- setdiff(required_cols, names(session_df)) @@ -49,30 +50,34 @@ download_single_session_asset_fr_df <- function(i = NULL, call. = FALSE ) } - + assertthat::assert_that(length(target_dir) == 1) assertthat::is.string(target_dir) - assertthat::assert_that(dir.exists(target_dir) || dir.create(target_dir, recursive = TRUE, showWarnings = FALSE)) + assertthat::assert_that( + dir.exists(target_dir) || + dir.create(target_dir, recursive = TRUE, showWarnings = FALSE) + ) assertthat::is.writeable(target_dir) - + assertthat::assert_that(length(add_session_subdir) == 1) assertthat::assert_that(is.logical(add_session_subdir)) - + assertthat::assert_that(length(overwrite) == 1) assertthat::assert_that(is.logical(overwrite)) - + assertthat::assert_that(length(make_portable_fn) == 1) assertthat::assert_that(is.logical(make_portable_fn)) - + assertthat::is.number(timeout_secs) assertthat::assert_that(length(timeout_secs) == 1) assertthat::assert_that(timeout_secs > 0) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) - + + assertthat::assert_that(is.null(rq) || + ("httr2_request" %in% class(rq))) + this_asset <- session_df[i, , drop = FALSE] if (nrow(this_asset) == 0) { if (vb) { @@ -80,7 +85,7 @@ download_single_session_asset_fr_df <- function(i = NULL, } return(NULL) } - + dest_dir <- if (isTRUE(add_session_subdir)) { file.path(target_dir, this_asset$session_id) } else { @@ -89,31 +94,32 @@ download_single_session_asset_fr_df <- function(i = NULL, dir.create(dest_dir, recursive = TRUE, showWarnings = FALSE) assertthat::assert_that(dir.exists(dest_dir)) assertthat::is.writeable(dest_dir) - + base_name <- this_asset$asset_name if (is.null(base_name) || is.na(base_name) || base_name == "") { base_name <- paste0("asset-", this_asset$asset_id) } - + extension <- "" if ("format_extension" %in% names(this_asset)) { ext_value <- this_asset$format_extension - if (!is.null(ext_value) && !is.na(ext_value) && nzchar(ext_value)) { + if (!is.null(ext_value) && + !is.na(ext_value) && nzchar(ext_value)) { if (tools::file_ext(base_name) != ext_value) { extension <- paste0(".", ext_value) } } } - + candidate_name <- paste0(base_name, extension) - + if (make_portable_fn) { if (vb) { message("Making file name '", candidate_name, "' portable.") } candidate_name <- make_fn_portable(candidate_name, vb = vb) } - + dest_file <- file.path(dest_dir, candidate_name) if (file.exists(dest_file) && !overwrite) { if (vb) { @@ -133,7 +139,7 @@ download_single_session_asset_fr_df <- function(i = NULL, ) dest_file <- file.path(dest_dir, candidate_name) } - + download_session_asset( vol_id = this_asset$vol_id, session_id = this_asset$session_id, diff --git a/R/download_video.R b/R/download_video.R index 8e24daec..471f376e 100644 --- a/R/download_video.R +++ b/R/download_video.R @@ -12,6 +12,7 @@ NULL #' value. #' @param target_dir Directory to save the downloaded file. Defaults to #' `tempdir()`. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq Optional `httr2` request object reused when requesting the signed #' link. #' @@ -39,15 +40,15 @@ download_video <- function(vol_id = 1, assertthat::assert_that(length(asset_id) == 1) assertthat::assert_that(is.numeric(asset_id)) assertthat::assert_that(asset_id >= 1) - + assertthat::assert_that(length(session_id) == 1) assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id >= 1) - + assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - + if (!is.null(file_name)) { assertthat::assert_that(length(file_name) == 1) assertthat::assert_that(is.character(file_name)) @@ -55,17 +56,21 @@ download_video <- function(vol_id = 1, stop("file_name must end with '.mp4' when provided.", call. = FALSE) } } - + assertthat::assert_that(length(target_dir) == 1) assertthat::assert_that(is.character(target_dir)) - assertthat::assert_that(dir.exists(target_dir) || dir.create(target_dir, recursive = TRUE, showWarnings = FALSE)) + assertthat::assert_that( + dir.exists(target_dir) || + dir.create(target_dir, recursive = TRUE, showWarnings = FALSE) + ) assertthat::is.writeable(target_dir) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) - + + assertthat::assert_that(is.null(rq) || + ("httr2_request" %in% class(rq))) + download_session_asset( vol_id = vol_id, session_id = session_id, diff --git a/R/download_volume_zip.R b/R/download_volume_zip.R index 8d44338c..89177938 100644 --- a/R/download_volume_zip.R +++ b/R/download_volume_zip.R @@ -11,7 +11,8 @@ NULL #' descriptor. When the archive is ready, Databrary emails a signed download #' link to the authenticated user. #' -#' @param vol_id Volume identifier. +#' @param vol_id An integer. Volume identifier. Default is 31. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Default is `NULL`, in which case a #' default authenticated request is generated. #' diff --git a/R/get_category_by_id.R b/R/get_category_by_id.R index 2119cf04..e9b02665 100644 --- a/R/get_category_by_id.R +++ b/R/get_category_by_id.R @@ -10,6 +10,7 @@ NULL #' that define data collection fields. #' #' @param category_id Numeric category identifier. Must be a positive integer. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return A list with the category's metadata including id, name, description, @@ -28,41 +29,37 @@ NULL #' } #' } #' @export -get_category_by_id <- function( - category_id = 1, - vb = options::opt("vb"), - rq = NULL -) { +get_category_by_id <- function(category_id = 1, + vb = options::opt("vb"), + rq = NULL) { # Validate category_id assertthat::assert_that(is.numeric(category_id)) assertthat::assert_that(length(category_id) == 1) assertthat::assert_that(category_id > 0) - assertthat::assert_that( - category_id == floor(category_id), - msg = "category_id must be an integer" - ) - + assertthat::assert_that(category_id == floor(category_id), msg = "category_id must be an integer") + # Validate vb assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - + # Validate rq - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + # Perform API call category <- perform_api_get( path = sprintf(API_CATEGORY_DETAIL, category_id), rq = rq, vb = vb ) - + if (is.null(category)) { if (vb) { message("Category ", category_id, " not found or inaccessible.") } return(NULL) } - + # Process metrics if present metrics <- NULL if (!is.null(category$metrics) && length(category$metrics) > 0) { @@ -79,7 +76,7 @@ get_category_by_id <- function( ) }) } - + # Return structured list list( category_id = category$id, diff --git a/R/get_db_stats.R b/R/get_db_stats.R index 35809aec..a92ab4a5 100644 --- a/R/get_db_stats.R +++ b/R/get_db_stats.R @@ -9,6 +9,7 @@ NULL #' the institutions, people, and data hosted on 'Databrary.org'. #' #' @param type Type of Databrary report to run "institutions", "people", "data" +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. #' #' @returns A data frame with the requested data or NULL if there is diff --git a/R/get_folder_by_id.R b/R/get_folder_by_id.R index 025b85c8..731b0082 100644 --- a/R/get_folder_by_id.R +++ b/R/get_folder_by_id.R @@ -7,6 +7,7 @@ NULL #' #' @param folder_id Folder identifier within the specified volume. #' @param vol_id Volume identifier containing the folder. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @returns A list representing the folder metadata, or `NULL` when the folder @@ -28,29 +29,32 @@ get_folder_by_id <- function(folder_id = 1, assertthat::assert_that(length(folder_id) == 1) assertthat::assert_that(is.numeric(folder_id)) assertthat::assert_that(folder_id >= 1) - + assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + folder <- perform_api_get( path = sprintf(API_FOLDER_DETAIL, vol_id, folder_id), rq = rq, vb = vb ) - + if (is.null(folder)) { if (vb) { - message("Cannot access requested folder ", folder_id, " in volume ", vol_id) + message("Cannot access requested folder ", + folder_id, + " in volume ", + vol_id) } return(NULL) } - + folder } - diff --git a/R/get_folder_file.R b/R/get_folder_file.R index 14999688..bbe78442 100644 --- a/R/get_folder_file.R +++ b/R/get_folder_file.R @@ -9,6 +9,7 @@ NULL #' @param folder_id An integer indicating a valid folder identifier #' linked to a volume. Default value is 9807, the materials folder for volume 1. #' @param file_id An integer indicating the file identifier. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An httr2 request object. #' #' @returns A JSON blob with the file data. If the user has previously logged @@ -25,36 +26,35 @@ NULL #' } #' @export get_folder_file <- - function( - vol_id = 1, - folder_id = 9807, - file_id, - vb = options::opt("vb"), - rq = NULL - ) { + function(vol_id = 1, + folder_id = 9807, + file_id, + vb = options::opt("vb"), + rq = NULL) { assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id > 0) assertthat::assert_that(length(vol_id) == 1) - + assertthat::assert_that(is.numeric(folder_id)) assertthat::assert_that(folder_id > 0) assertthat::assert_that(length(folder_id) == 1) - + assertthat::assert_that(is.numeric(file_id)) assertthat::assert_that(file_id > 0) assertthat::assert_that(length(file_id) == 1) - + assertthat::assert_that(is.logical(vb)) assertthat::assert_that(length(vb) == 1) - - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + file <- perform_api_get( path = sprintf(API_FOLDER_FILES_DETAIL, vol_id, folder_id, file_id), rq = rq, vb = vb ) - + if (is.null(file)) { if (vb) { message( @@ -68,6 +68,6 @@ get_folder_file <- } return(NULL) } - + file } diff --git a/R/get_funder_by_id.R b/R/get_funder_by_id.R index b13c765a..1d46b3f1 100644 --- a/R/get_funder_by_id.R +++ b/R/get_funder_by_id.R @@ -9,6 +9,7 @@ NULL #' Databrary using its unique identifier. #' #' @param funder_id Numeric funder identifier. Must be a positive integer. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return A list with the funder's metadata including id, name, and approval @@ -27,41 +28,37 @@ NULL #' } #' } #' @export -get_funder_by_id <- function( - funder_id = 1, - vb = options::opt("vb"), - rq = NULL -) { +get_funder_by_id <- function(funder_id = 1, + vb = options::opt("vb"), + rq = NULL) { # Validate funder_id assertthat::assert_that(is.numeric(funder_id)) assertthat::assert_that(length(funder_id) == 1) assertthat::assert_that(funder_id > 0) - assertthat::assert_that( - funder_id == floor(funder_id), - msg = "funder_id must be an integer" - ) - + assertthat::assert_that(funder_id == floor(funder_id), msg = "funder_id must be an integer") + # Validate vb assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - + # Validate rq - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + # Perform API call funder <- perform_api_get( path = sprintf(API_FUNDER_DETAIL, funder_id), rq = rq, vb = vb ) - + if (is.null(funder)) { if (vb) { message("Funder ", funder_id, " not found or inaccessible.") } return(NULL) } - + # Return structured list list( funder_id = funder$id, diff --git a/R/get_institution_avatar.R b/R/get_institution_avatar.R index 836dcc64..3df9ba2f 100644 --- a/R/get_institution_avatar.R +++ b/R/get_institution_avatar.R @@ -16,6 +16,7 @@ NULL #' provided, the filename will be determined from the response headers or #' will default to `institution__avatar.jpg`. If `NULL` (the default), #' the raw image bytes are returned instead of being saved to disk. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return If `dest_path` is provided, returns the full path to the saved @@ -47,144 +48,137 @@ NULL #' } #' } #' @export -get_institution_avatar <- function( - institution_id = 1, - dest_path = NULL, - vb = options::opt("vb"), - rq = NULL -) { +get_institution_avatar <- function(institution_id = 1, + dest_path = NULL, + vb = options::opt("vb"), + rq = NULL) { # Validate institution_id assertthat::assert_that(is.numeric(institution_id)) assertthat::assert_that(length(institution_id) == 1) assertthat::assert_that(institution_id > 0) - assertthat::assert_that( - institution_id == floor(institution_id), - msg = "institution_id must be an integer" - ) - + assertthat::assert_that(institution_id == floor(institution_id), msg = "institution_id must be an integer") + # Validate dest_path if (!is.null(dest_path)) { assertthat::assert_that(assertthat::is.string(dest_path)) } - + # Validate vb assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - + # Validate rq - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + # Build URL avatar_url <- sprintf(API_INSTITUTION_AVATAR, institution_id) full_url <- paste0(DATABRARY_BASE_URL, avatar_url) - + # Create request if (is.null(rq)) { req <- make_default_request() } else { req <- rq } - + # Build the request with the avatar URL req <- req %>% httr2::req_url(full_url) %>% httr2::req_method("GET") %>% - httr2::req_error(is_error = function(resp) FALSE) - + httr2::req_error( + is_error = function(resp) + FALSE + ) + if (vb) { message("Requesting avatar for institution ", institution_id) } - + # Perform request - tryCatch( - { - resp <- httr2::req_perform(req) - - # Check response status - status <- httr2::resp_status(resp) - if (status != 200) { - if (vb) { - message( - "Institution ", - institution_id, - " avatar not found or inaccessible (status: ", - status, - ")" - ) - } - return(NULL) - } - - # Get raw bytes - avatar_bytes <- httr2::resp_body_raw(resp) - - if (is.null(dest_path)) { - # Return raw bytes - if (vb) { - message("Downloaded ", length(avatar_bytes), " bytes") - } - return(avatar_bytes) - } else { - # Resolve destination path - # If dest_path is a directory, determine filename from response headers or URL - final_path <- dest_path - if (dir.exists(dest_path)) { - # Try to get filename from content-disposition header - filename <- "downloaded_file" - content_disp <- httr2::resp_header(resp, "content-disposition") - - if (!is.null(content_disp) && grepl("filename=", content_disp)) { - # Extract filename from content-disposition header - filename_match <- regmatches( - content_disp, - regexpr("filename=([^;]+)", content_disp) - ) - if (length(filename_match) > 0) { - filename <- sub("filename=", "", filename_match) - filename <- gsub('^"|"$', '', filename) # Remove quotes - filename <- trimws(filename) - } - } else { - # Fallback: use URL path basename - url_path <- sprintf(API_INSTITUTION_AVATAR, institution_id) - filename <- paste0("institution_", institution_id, "_avatar.jpg") - } - - final_path <- file.path(dest_path, filename) - } - - # Create parent directory if needed - parent_dir <- dirname(final_path) - if (!dir.exists(parent_dir)) { - dir.create(parent_dir, recursive = TRUE, showWarnings = FALSE) - } - - # Save to file - writeBin(avatar_bytes, final_path) - - if (vb) { - message( - "Saved avatar to: ", - final_path, - " (", - length(avatar_bytes), - " bytes)" - ) - } - - return(normalizePath(final_path)) - } - }, - error = function(e) { + tryCatch({ + resp <- httr2::req_perform(req) + + # Check response status + status <- httr2::resp_status(resp) + if (status != 200) { if (vb) { message( - "Error downloading avatar for institution ", + "Institution ", institution_id, - ": ", - e$message + " avatar not found or inaccessible (status: ", + status, + ")" ) } return(NULL) } - ) + + # Get raw bytes + avatar_bytes <- httr2::resp_body_raw(resp) + + if (is.null(dest_path)) { + # Return raw bytes + if (vb) { + message("Downloaded ", length(avatar_bytes), " bytes") + } + return(avatar_bytes) + } else { + # Resolve destination path + # If dest_path is a directory, determine filename from response headers or URL + final_path <- dest_path + if (dir.exists(dest_path)) { + # Try to get filename from content-disposition header + filename <- "downloaded_file" + content_disp <- httr2::resp_header(resp, "content-disposition") + + if (!is.null(content_disp) && + grepl("filename=", content_disp)) { + # Extract filename from content-disposition header + filename_match <- regmatches(content_disp, + regexpr("filename=([^;]+)", content_disp)) + if (length(filename_match) > 0) { + filename <- sub("filename=", "", filename_match) + filename <- gsub('^"|"$', '', filename) # Remove quotes + filename <- trimws(filename) + } + } else { + # Fallback: use URL path basename + url_path <- sprintf(API_INSTITUTION_AVATAR, institution_id) + filename <- paste0("institution_", institution_id, "_avatar.jpg") + } + + final_path <- file.path(dest_path, filename) + } + + # Create parent directory if needed + parent_dir <- dirname(final_path) + if (!dir.exists(parent_dir)) { + dir.create(parent_dir, + recursive = TRUE, + showWarnings = FALSE) + } + + # Save to file + writeBin(avatar_bytes, final_path) + + if (vb) { + message("Saved avatar to: ", + final_path, + " (", + length(avatar_bytes), + " bytes)") + } + + return(normalizePath(final_path)) + } + }, error = function(e) { + if (vb) { + message("Error downloading avatar for institution ", + institution_id, + ": ", + e$message) + } + return(NULL) + }) } diff --git a/R/get_institution_by_id.R b/R/get_institution_by_id.R index 267717c3..49c69653 100644 --- a/R/get_institution_by_id.R +++ b/R/get_institution_by_id.R @@ -5,7 +5,8 @@ NULL #' Get institution metadata #' -#' @param institution_id Institution identifier. +#' @param institution_id Institution identifier. Must be a positive integer. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @inheritParams options_params #' #' @return List of institution metadata or NULL when inaccessible. diff --git a/R/get_session_by_id.R b/R/get_session_by_id.R index 8f1d561b..aa6980ae 100644 --- a/R/get_session_by_id.R +++ b/R/get_session_by_id.R @@ -8,6 +8,7 @@ NULL #' @param session_id An integer indicating a valid session/slot identifier #' linked to a volume. Default value is 9807, the materials folder for volume 1. #' @param vol_id An integer indicating the volume identifier. Default is 1. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An httr2 request object. #' #' @returns A JSON blob with the session data. If the user has previously logged diff --git a/R/get_session_by_name.R b/R/get_session_by_name.R index 83defef3..5150cbb4 100644 --- a/R/get_session_by_name.R +++ b/R/get_session_by_name.R @@ -8,6 +8,7 @@ NULL #' @param session_name A string. The name of the target session. Defaults to "Advisory #' Board Meeting", the name of several of the sessions in the public Volume 1. #' @param vol_id An integer indicating the volume identifier. Default is 1. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An httr2 request, such as that generated by `make_default_request()`. #' #' @returns One or more JSON blobs (as lists) whose session name(s) match @@ -41,7 +42,8 @@ get_session_by_name <- assertthat::assert_that(is.logical(vb)) assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) sessions <- collect_paginated_get( path = sprintf(API_VOLUME_SESSIONS, vol_id), @@ -49,13 +51,19 @@ get_session_by_name <- rq = rq, vb = vb ) - + if (is.null(sessions) || length(sessions) == 0) { - if (vb) message("No sessions named '", session_name, "' in volume ", vol_id) + if (vb) + message("No sessions named '", session_name, "' in volume ", vol_id) return(NULL) } - + purrr::map(sessions, function(session) { - databraryr::get_session_by_id(session_id = session$id, vol_id = vol_id, vb = vb, rq = rq) + databraryr::get_session_by_id( + session_id = session$id, + vol_id = vol_id, + vb = vb, + rq = rq + ) }) } \ No newline at end of file diff --git a/R/get_session_file.R b/R/get_session_file.R index 404d3ff7..9e7e4532 100644 --- a/R/get_session_file.R +++ b/R/get_session_file.R @@ -9,6 +9,7 @@ NULL #' @param session_id An integer indicating a valid session/slot identifier #' linked to a volume. Default value is 9807, the materials folder for volume 1. #' @param file_id An integer indicating the file identifier. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An httr2 request object. #' #' @returns A JSON blob with the file data. If the user has previously logged @@ -25,36 +26,35 @@ NULL #' } #' @export get_session_file <- - function( - vol_id = 1, - session_id = 9807, - file_id, - vb = options::opt("vb"), - rq = NULL - ) { + function(vol_id = 1, + session_id = 9807, + file_id, + vb = options::opt("vb"), + rq = NULL) { assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id > 0) assertthat::assert_that(length(vol_id) == 1) - + assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id > 0) assertthat::assert_that(length(session_id) == 1) - + assertthat::assert_that(is.numeric(file_id)) assertthat::assert_that(file_id > 0) assertthat::assert_that(length(file_id) == 1) - + assertthat::assert_that(is.logical(vb)) assertthat::assert_that(length(vb) == 1) - - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + file <- perform_api_get( path = sprintf(API_SESSION_FILE_DETAIL, vol_id, session_id, file_id), rq = rq, vb = vb ) - + if (is.null(file)) { if (vb) { message( @@ -68,6 +68,6 @@ get_session_file <- } return(NULL) } - + file } diff --git a/R/get_tag_by_id.R b/R/get_tag_by_id.R index 529ea006..92fd8afa 100644 --- a/R/get_tag_by_id.R +++ b/R/get_tag_by_id.R @@ -9,6 +9,7 @@ NULL #' Databrary using its unique identifier. #' #' @param tag_id Numeric tag identifier. Must be a positive integer. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return A list with the tag's metadata including id and name, @@ -27,40 +28,35 @@ NULL #' } #' } #' @export -get_tag_by_id <- function(tag_id = 1, vb = options::opt("vb"), rq = NULL) { +get_tag_by_id <- function(tag_id = 1, + vb = options::opt("vb"), + rq = NULL) { # Validate tag_id assertthat::assert_that(is.numeric(tag_id)) assertthat::assert_that(length(tag_id) == 1) assertthat::assert_that(tag_id > 0) - assertthat::assert_that( - tag_id == floor(tag_id), - msg = "tag_id must be an integer" - ) - + assertthat::assert_that(tag_id == floor(tag_id), msg = "tag_id must be an integer") + # Validate vb assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - + # Validate rq - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + # Perform API call - tag <- perform_api_get( - path = sprintf(API_TAG_DETAIL, tag_id), - rq = rq, - vb = vb - ) - + tag <- perform_api_get(path = sprintf(API_TAG_DETAIL, tag_id), + rq = rq, + vb = vb) + if (is.null(tag)) { if (vb) { message("Tag ", tag_id, " not found or inaccessible.") } return(NULL) } - + # Return structured list - list( - tag_id = tag$id, - tag_name = tag$name - ) + list(tag_id = tag$id, tag_name = tag$name) } diff --git a/R/get_user_avatar.R b/R/get_user_avatar.R index c9fa961b..eaa84f98 100644 --- a/R/get_user_avatar.R +++ b/R/get_user_avatar.R @@ -40,87 +40,83 @@ NULL #' } #' } #' @export -get_user_avatar <- function( - user_id, - dest_path = NULL, - vb = options::opt("vb"), - rq = NULL -) { +get_user_avatar <- function(user_id, + dest_path = NULL, + vb = options::opt("vb"), + rq = NULL) { # Validate user_id assertthat::assert_that(length(user_id) == 1) - assertthat::assert_that(is.numeric(user_id) || is.integer(user_id)) + assertthat::assert_that(is.numeric(user_id) || + is.integer(user_id)) assertthat::assert_that(user_id > 0) - + # Validate dest_path if (!is.null(dest_path)) { assertthat::assert_that(assertthat::is.string(dest_path)) } - + # Validate vb assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - + # Validate rq - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + # Build URL path path <- sprintf(API_USER_AVATAR, user_id) - + if (vb) { message("Getting user avatar for user ID: ", user_id) } - + # Set up request if (is.null(rq)) { rq <- make_default_request() } - + # Perform request - resp <- tryCatch( - { - rq |> - httr2::req_url_path_append(path) |> - httr2::req_error(is_error = function(resp) FALSE) |> - httr2::req_perform() - }, - error = function(e) { - if (vb) { - message("Error downloading user avatar: ", conditionMessage(e)) - } - return(NULL) + resp <- tryCatch({ + rq |> + httr2::req_url_path_append(path) |> + httr2::req_error( + is_error = function(resp) + FALSE + ) |> + httr2::req_perform() + }, error = function(e) { + if (vb) { + message("Error downloading user avatar: ", conditionMessage(e)) } - ) - + return(NULL) + }) + if (is.null(resp)) { return(NULL) } - + # Check for errors if (httr2::resp_status(resp) != 200) { if (vb) { - message( - "Failed to download user avatar. Status: ", - httr2::resp_status(resp) - ) + message("Failed to download user avatar. Status: ", + httr2::resp_status(resp)) } return(NULL) } - + # Get avatar bytes avatar_bytes <- httr2::resp_body_raw(resp) - + # If no destination path, return bytes if (is.null(dest_path)) { if (vb) { - message( - "Returning avatar as raw bytes (", - length(avatar_bytes), - " bytes)" - ) + message("Returning avatar as raw bytes (", + length(avatar_bytes), + " bytes)") } return(avatar_bytes) } - + # Save to file # Resolve destination path # If dest_path is a directory, determine filename from response headers or URL @@ -129,13 +125,12 @@ get_user_avatar <- function( # Try to get filename from content-disposition header filename <- "downloaded_file" content_disp <- httr2::resp_header(resp, "content-disposition") - - if (!is.null(content_disp) && grepl("filename=", content_disp)) { + + if (!is.null(content_disp) && + grepl("filename=", content_disp)) { # Extract filename from content-disposition header - filename_match <- regmatches( - content_disp, - regexpr("filename=([^;]+)", content_disp) - ) + filename_match <- regmatches(content_disp, + regexpr("filename=([^;]+)", content_disp)) if (length(filename_match) > 0) { filename <- sub("filename=", "", filename_match) filename <- gsub('^"|"$', '', filename) # Remove quotes @@ -146,30 +141,27 @@ get_user_avatar <- function( url_path <- sprintf(API_USER_AVATAR, user_id) filename <- paste0("user_", user_id, "_avatar.jpg") } - + final_path <- file.path(dest_path, filename) } - + # Ensure parent directory exists parent_dir <- dirname(final_path) if (!dir.exists(parent_dir)) { dir.create(parent_dir, recursive = TRUE) } - + # Write to file - tryCatch( - { - writeBin(avatar_bytes, final_path) - if (vb) { - message("Avatar saved to: ", final_path) - } - return(normalizePath(final_path)) - }, - error = function(e) { - if (vb) { - message("Error saving avatar to file: ", conditionMessage(e)) - } - return(NULL) + tryCatch({ + writeBin(avatar_bytes, final_path) + if (vb) { + message("Avatar saved to: ", final_path) } - ) + return(normalizePath(final_path)) + }, error = function(e) { + if (vb) { + message("Error saving avatar to file: ", conditionMessage(e)) + } + return(NULL) + }) } diff --git a/R/get_user_by_id.R b/R/get_user_by_id.R index 52bc3ae0..f5455c9e 100644 --- a/R/get_user_by_id.R +++ b/R/get_user_by_id.R @@ -5,7 +5,8 @@ NULL #' Get public profile information for a Databrary user #' -#' @param user_id User identifier. +#' @param user_id User identifier. Must be a positive integer. Default is 6. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @inheritParams options_params #' #' @return A list with the user's public metadata. @@ -14,23 +15,25 @@ get_user_by_id <- function(user_id = 6, vb = options::opt("vb"), rq = NULL) { assertthat::assert_that(is.numeric(user_id), length(user_id) == 1, user_id > 0) - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + user <- perform_api_get( path = sprintf(API_USER_DETAIL, user_id), rq = rq, vb = vb ) - + if (is.null(user)) { - if (vb) message("User ", user_id, " not found or inaccessible.") + if (vb) + message("User ", user_id, " not found or inaccessible.") return(NULL) } - + affiliation <- user$affiliation institution_name <- affiliation$name institution_id <- affiliation$id - + tibble::tibble( id = user$id, prename = user$first_name, @@ -43,4 +46,3 @@ get_user_by_id <- function(user_id = 6, ) %>% as.list() } - diff --git a/R/get_volume_by_id.R b/R/get_volume_by_id.R index 9480730e..94b11352 100644 --- a/R/get_volume_by_id.R +++ b/R/get_volume_by_id.R @@ -5,7 +5,8 @@ NULL #' Get Summary Data About A Databrary Volume #' -#' @param vol_id Volume ID. +#' @param vol_id Volume ID. Must be a positive integer. Default is 1. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. If NULL (the default), a new request #' is generated using `make_default_request()`. To access restricted data, #' the user must login with a specific request object using `login_db()`. diff --git a/R/get_volume_collaborator_by_id.R b/R/get_volume_collaborator_by_id.R index 6819184c..0420dce7 100644 --- a/R/get_volume_collaborator_by_id.R +++ b/R/get_volume_collaborator_by_id.R @@ -12,6 +12,7 @@ NULL #' #' @param vol_id Target volume number. Must be a positive integer. #' @param collaborator_id Numeric collaborator identifier. Must be a positive integer. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return A list with the collaborator's metadata including id, volume, user @@ -32,44 +33,37 @@ NULL #' } #' } #' @export -get_volume_collaborator_by_id <- function( - vol_id = 1, - collaborator_id = 1, - vb = options::opt("vb"), - rq = NULL -) { +get_volume_collaborator_by_id <- function(vol_id = 1, + collaborator_id = 1, + vb = options::opt("vb"), + rq = NULL) { # Validate vol_id assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(vol_id >= 1) - assertthat::assert_that( - vol_id == floor(vol_id), - msg = "vol_id must be an integer" - ) - + assertthat::assert_that(vol_id == floor(vol_id), msg = "vol_id must be an integer") + # Validate collaborator_id assertthat::assert_that(is.numeric(collaborator_id)) assertthat::assert_that(length(collaborator_id) == 1) assertthat::assert_that(collaborator_id > 0) - assertthat::assert_that( - collaborator_id == floor(collaborator_id), - msg = "collaborator_id must be an integer" - ) - + assertthat::assert_that(collaborator_id == floor(collaborator_id), msg = "collaborator_id must be an integer") + # Validate vb assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - + # Validate rq - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + # Perform API call collaborator <- perform_api_get( path = sprintf(API_VOLUME_COLLABORATOR_DETAIL, vol_id, collaborator_id), rq = rq, vb = vb ) - + if (is.null(collaborator)) { if (vb) { message( @@ -82,7 +76,7 @@ get_volume_collaborator_by_id <- function( } return(NULL) } - + # Process user information user <- NULL if (!is.null(collaborator$user)) { @@ -95,7 +89,7 @@ get_volume_collaborator_by_id <- function( has_avatar = collaborator$user$has_avatar ) } - + # Process sponsor information sponsor <- NULL if (!is.null(collaborator$sponsor)) { @@ -106,7 +100,7 @@ get_volume_collaborator_by_id <- function( email = collaborator$sponsor$email ) } - + # Process sponsorship information sponsorship <- NULL if (!is.null(collaborator$sponsorship)) { @@ -117,13 +111,11 @@ get_volume_collaborator_by_id <- function( status = collaborator$sponsorship$status ) } - + # Process sponsored_users if present sponsored_users <- NULL - if ( - !is.null(collaborator$sponsored_users) && - length(collaborator$sponsored_users) > 0 - ) { + if (!is.null(collaborator$sponsored_users) && + length(collaborator$sponsored_users) > 0) { sponsored_users <- lapply(collaborator$sponsored_users, function(u) { list( user_id = u$id, @@ -133,7 +125,7 @@ get_volume_collaborator_by_id <- function( ) }) } - + # Return structured list list( collaborator_id = collaborator$id, diff --git a/R/get_volume_record_by_id.R b/R/get_volume_record_by_id.R index ea263481..aadf2447 100644 --- a/R/get_volume_record_by_id.R +++ b/R/get_volume_record_by_id.R @@ -10,8 +10,9 @@ NULL #' Records contain participant information including age, birthday, category, #' and associated measures collected during sessions. #' -#' @param vol_id Target volume number. Must be a positive integer. -#' @param record_id Numeric record identifier. Must be a positive integer. +#' @param vol_id Target volume number. Must be a positive integer. Default is 1. +#' @param record_id Numeric record identifier. Must be a positive integer. Default is 1. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return A list with the record's metadata including id, volume, category_id, diff --git a/R/list_asset_formats.R b/R/list_asset_formats.R index 5720a8be..6c2ec3db 100644 --- a/R/list_asset_formats.R +++ b/R/list_asset_formats.R @@ -5,6 +5,10 @@ NULL #' List Stored Assets (Files) By Type. #' +#' @description List the data (file) formats supported by Databrary. +#' +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. +#' #' @returns A data frame with information about the data formats Databrary #' supports. #' diff --git a/R/list_authorized_investigators.R b/R/list_authorized_investigators.R index e6419454..85d96982 100644 --- a/R/list_authorized_investigators.R +++ b/R/list_authorized_investigators.R @@ -5,6 +5,12 @@ NULL #' List authorized investigators for an institution #' +#' @description Lists the authorized investigators at an institution. +#' +#' @param institution_id Institution identifier. Must be a positive integer. Default is 12. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' #' @inheritParams list_institution_affiliates #' #' @return Tibble of investigators; NULL if none. @@ -12,19 +18,21 @@ NULL list_authorized_investigators <- function(institution_id = 12, vb = options::opt("vb"), rq = NULL) { - assertthat::assert_that(is.numeric(institution_id), length(institution_id) == 1, institution_id > 0) + assertthat::assert_that(is.numeric(institution_id), + length(institution_id) == 1, + institution_id > 0) assertthat::assert_that(is.logical(vb), length(vb) == 1) - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + affiliates <- list_institution_affiliates(institution_id, vb = vb, rq = rq) if (is.null(affiliates)) { return(NULL) } - + investigators <- affiliates |> dplyr::filter(.data$role == "investigator") if (nrow(investigators) == 0) { return(NULL) } investigators } - diff --git a/R/list_categories.R b/R/list_categories.R index dcc2c9d8..603a95a1 100644 --- a/R/list_categories.R +++ b/R/list_categories.R @@ -9,6 +9,7 @@ NULL #' define different types of data collection sessions and include nested #' metrics that specify the data fields collected for each category. #' +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return A tibble containing metadata for each category including id, name, @@ -31,29 +32,27 @@ list_categories <- function(vb = options::opt("vb"), rq = NULL) { # Validate vb assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - + # Validate rq - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + # Perform API call - categories <- perform_api_get( - path = API_CATEGORIES, - rq = rq, - vb = vb - ) - + categories <- perform_api_get(path = API_CATEGORIES, rq = rq, vb = vb) + if (is.null(categories) || length(categories) == 0) { if (vb) { message("No categories available.") } return(NULL) } - + # Process categories into tibble purrr::map_dfr(categories, function(category) { # Process metrics if present metrics <- NULL - if (!is.null(category$metrics) && length(category$metrics) > 0) { + if (!is.null(category$metrics) && + length(category$metrics) > 0) { metrics <- lapply(category$metrics, function(metric) { list( metric_id = metric$id, @@ -67,7 +66,7 @@ list_categories <- function(vb = options::opt("vb"), rq = NULL) { ) }) } - + tibble::tibble( category_id = category$id, category_name = category$name, diff --git a/R/list_folder_assets.R b/R/list_folder_assets.R index ccbac127..2ce1d87d 100644 --- a/R/list_folder_assets.R +++ b/R/list_folder_assets.R @@ -5,8 +5,11 @@ NULL #' List Assets Within a Databrary Folder. #' -#' @param folder_id Folder identifier scoped to the given volume. +#' @param folder_id Folder identifier scoped to the given volume. Must be a +#' positive integer. Default is 1. #' @param vol_id Volume containing the folder. Required for Django API calls. +#' Must be a positive integer. Default is 1. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @returns A tibble with metadata for files contained in the folder, or @@ -28,49 +31,52 @@ list_folder_assets <- function(folder_id = 1, assertthat::assert_that(length(folder_id) == 1) assertthat::assert_that(is.numeric(folder_id)) assertthat::assert_that(folder_id >= 1) - + if (is.null(vol_id)) { - stop("vol_id must be supplied for list_folder_assets(); folder identifiers are scoped to volumes.", - call. = FALSE) + stop( + "vol_id must be supplied for list_folder_assets(); folder identifiers are scoped to volumes.", + call. = FALSE + ) } - + assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + folder <- databraryr::get_folder_by_id( folder_id = folder_id, vol_id = vol_id, vb = vb, rq = rq ) - + if (is.null(folder)) { return(NULL) } - + files <- collect_paginated_get( path = sprintf(API_FOLDER_FILES, vol_id, folder_id), rq = rq, vb = vb ) - + if (is.null(files) || length(files) == 0) { if (vb) { message("No assets for folder_id ", folder_id) } return(NULL) } - + file_rows <- purrr::map_dfr(files, function(file) { format <- file$format uploader <- file$uploader - + tibble::tibble( asset_id = file$id, asset_name = file$name, @@ -90,7 +96,7 @@ list_folder_assets <- function(folder_id = 1, asset_thumbnail_url = file$thumbnail_url ) }) - + file_rows %>% dplyr::mutate( folder_id = folder_id, @@ -100,4 +106,3 @@ list_folder_assets <- function(folder_id = 1, folder_source_date = folder$source_date ) } - diff --git a/R/list_institution_affiliates.R b/R/list_institution_affiliates.R index 127c1a1a..a05508b6 100644 --- a/R/list_institution_affiliates.R +++ b/R/list_institution_affiliates.R @@ -5,7 +5,10 @@ NULL #' List affiliates for an institution #' -#' @param institution_id Institution identifier. +#' @param institution_id Institution identifier. Must be a positive integer. Default is 12. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' #' @inheritParams options_params #' #' @return Tibble of affiliates with roles and expiration dates. @@ -13,20 +16,28 @@ NULL list_institution_affiliates <- function(institution_id = 12, vb = options::opt("vb"), rq = NULL) { - assertthat::assert_that(is.numeric(institution_id), length(institution_id) == 1, institution_id > 0) - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + assertthat::assert_that(is.numeric(institution_id), + length(institution_id) == 1, + institution_id > 0) + + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + affiliates <- collect_paginated_get( path = sprintf(API_INSTITUTION_AFFILIATES, institution_id), rq = rq, vb = vb ) - + if (is.null(affiliates) || length(affiliates) == 0) { - if (vb) message("No affiliates for institution ", institution_id) + if (vb) + message("No affiliates for institution ", institution_id) return(NULL) } - + purrr::map_dfr(affiliates, function(entry) { user <- entry$user tibble::tibble( @@ -42,4 +53,3 @@ list_institution_affiliates <- function(institution_id = 12, ) }) } - diff --git a/R/list_institutions.R b/R/list_institutions.R index f86d3b50..e6854a46 100644 --- a/R/list_institutions.R +++ b/R/list_institutions.R @@ -10,6 +10,7 @@ NULL #' #' @param search_string Optional character string to filter institutions. If #' `NULL` (the default), returns all institutions. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return A tibble containing institutions with their metadata including id, @@ -33,29 +34,28 @@ NULL #' } #' } #' @export -list_institutions <- function( - search_string = NULL, - vb = options::opt("vb"), - rq = NULL -) { +list_institutions <- function(search_string = NULL, + vb = options::opt("vb"), + rq = NULL) { # Validate search_string if (!is.null(search_string)) { assertthat::assert_that(assertthat::is.string(search_string)) } - + # Validate vb assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - + # Validate rq - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + # Build params list params <- list() if (!is.null(search_string)) { params$search <- search_string } - + # Perform API call with pagination results <- collect_paginated_get( path = API_INSTITUTIONS_LIST, @@ -63,7 +63,7 @@ list_institutions <- function( rq = rq, vb = vb ) - + if (is.null(results) || length(results) == 0) { if (vb) { if (is.null(search_string)) { @@ -74,13 +74,16 @@ list_institutions <- function( } return(NULL) } - + # Process results into tibble purrr::map_dfr(results, function(entry) { tibble::tibble( institution_id = entry$id, institution_name = entry$name, - institution_url = if (is.null(entry$url)) NA_character_ else entry$url, + institution_url = if (is.null(entry$url)) + NA_character_ + else + entry$url, institution_date_signed = if (is.null(entry$date_signed)) { NA_character_ } else { diff --git a/R/list_session_activity.R b/R/list_session_activity.R index 915906e4..2e761f9f 100644 --- a/R/list_session_activity.R +++ b/R/list_session_activity.R @@ -5,11 +5,12 @@ NULL #' List Activity History in Databrary Session. #' -#' For an accessible session, returns the logged history events associated with +#' @description For an accessible session, returns the logged history events associated with #' the session. Requires authenticated access with sufficient permissions. #' -#' @param vol_id Volume identifier (required by the Django API). -#' @param session_id Session identifier. +#' @param vol_id Volume identifier (required by the Django API). Must be a positive integer. +#' @param session_id Session identifier. Must be a positive integer. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. When `NULL`, a #' default request is generated, but this will only permit public information #' to be returned. @@ -35,34 +36,35 @@ list_session_activity <- assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id > 0) - + assertthat::assert_that(length(session_id) == 1) assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id > 0) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + if (is.null(rq)) { rq <- databraryr::make_default_request() } rq <- httr2::req_timeout(rq, REQUEST_TIMEOUT_VERY_LONG) - + activities <- collect_paginated_get( path = sprintf(API_VOLUME_HISTORY, vol_id), rq = rq, vb = vb ) - + if (is.null(activities) || length(activities) == 0) { if (vb) { message("No activity history available for volume ", vol_id) } return(NULL) } - + session_details <- databraryr::get_session_by_id( session_id = session_id, vol_id = vol_id, @@ -73,7 +75,7 @@ list_session_activity <- if (!is.null(session_details)) { session_name <- session_details$name } - + session_entries <- purrr::keep(activities, function(entry) { session_identifier <- entry$session_id if (is.null(session_identifier) && !is.null(entry$session)) { @@ -84,25 +86,28 @@ list_session_activity <- session_identifier <- session_value } } - + if (!is.null(session_identifier)) { return(isTRUE(session_identifier == session_id)) } - + if (!is.null(session_name) && !is.null(entry$name)) { return(isTRUE(entry$name == session_name)) } - + FALSE }) - + if (length(session_entries) == 0) { if (vb) { - message("No activity history for session ", session_id, " within volume ", vol_id) + message("No activity history for session ", + session_id, + " within volume ", + vol_id) } return(NULL) } - + purrr::map_dfr(session_entries, function(entry) { history_user <- entry$history_user folder_id <- entry$folder_id @@ -114,15 +119,21 @@ list_session_activity <- folder_id <- folder } } - + safe_int <- function(value) { - if (is.null(value)) NA_integer_ else value + if (is.null(value)) + NA_integer_ + else + value } - + safe_chr <- function(value) { - if (is.null(value)) NA_character_ else value + if (is.null(value)) + NA_character_ + else + value } - + tibble::tibble( event_type = entry$type, event_timestamp = entry$timestamp, diff --git a/R/list_session_assets.R b/R/list_session_assets.R index 270658ec..af1b4c52 100644 --- a/R/list_session_assets.R +++ b/R/list_session_assets.R @@ -17,6 +17,7 @@ NULL #' @param vol_id Optional integer. The volume containing the session. Recent #' versions of the Databrary API require this value to be supplied because #' session identifiers are scoped to volumes. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. If NULL, a default request is generated #' from databraryr::make_default_request(). #' diff --git a/R/list_user_affiliates.R b/R/list_user_affiliates.R index 28876019..4550aded 100644 --- a/R/list_user_affiliates.R +++ b/R/list_user_affiliates.R @@ -5,7 +5,10 @@ NULL #' List affiliates for a user #' -#' @param user_id User identifier. +#' @param user_id User identifier. Must be an integer. Default is 6. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. +#' @param rq An `httr2` request object. Defaults to `NULL`. +#' #' @inheritParams options_params #' #' @return Tibble of affiliates for the user. @@ -16,6 +19,12 @@ list_user_affiliates <- function(user_id = 6, assertthat::assert_that(is.numeric(user_id), length(user_id) == 1, user_id > 0) assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + affiliates <- collect_paginated_get( path = sprintf(API_USER_AFFILIATES, user_id), rq = rq, diff --git a/R/list_user_history.R b/R/list_user_history.R index baa70ce5..c1f8721e 100644 --- a/R/list_user_history.R +++ b/R/list_user_history.R @@ -9,7 +9,8 @@ NULL #' user. Access is restricted to administrators and authorized investigators #' with sufficient privileges. #' -#' @param user_id Target user identifier. +#' @param user_id Target user identifier. Must be a positive integer. Default is 22582. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return A tibble containing authentication and activity events for the @@ -30,25 +31,26 @@ list_user_history <- function(user_id = 22582, assertthat::assert_that(is.numeric(user_id)) assertthat::assert_that(length(user_id) == 1) assertthat::assert_that(user_id > 0) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + history <- collect_paginated_get( path = sprintf(API_USERS_HISTORY, user_id), rq = rq, vb = vb ) - + if (is.null(history) || length(history) == 0) { if (vb) { message("No activity history available for user ", user_id) } return(NULL) } - + purrr::map_dfr(history, function(entry) { tibble::tibble( user_id = user_id, @@ -61,5 +63,3 @@ list_user_history <- function(user_id = 22582, ) }) } - - diff --git a/R/list_user_sponsors.R b/R/list_user_sponsors.R index 880e3d58..fae5445e 100644 --- a/R/list_user_sponsors.R +++ b/R/list_user_sponsors.R @@ -8,27 +8,35 @@ NULL #' @param user_id User identifier. #' @inheritParams options_params #' -#' @return Tibble of sponsors for the user. +#' @returns Tibble of sponsors for the user. #' @export list_user_sponsors <- function(user_id = 6, - vb = options::opt("vb"), - rq = NULL) { + vb = options::opt("vb"), + rq = NULL) { assertthat::assert_that(is.numeric(user_id), length(user_id) == 1, user_id > 0) - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + + assertthat::assert_that(length(vb) == 1) + assertthat::assert_that(is.logical(vb)) + + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + sponsorships <- collect_paginated_get( path = sprintf(API_USER_SPONSORSHIPS, user_id), rq = rq, vb = vb ) - + if (is.null(sponsorships) || length(sponsorships) == 0) { - if (vb) message("No sponsorships for user ", user_id) + if (vb) + message("No sponsorships for user ", user_id) return(NULL) } - + user <- get_user_by_id(user_id, vb = vb, rq = rq) - + purrr::map_dfr(sponsorships, function(entry) { sponsor <- entry$user tibble::tibble( @@ -47,4 +55,3 @@ list_user_sponsors <- function(user_id = 6, ) }) } - diff --git a/R/list_user_volumes.R b/R/list_user_volumes.R index 5ed63a00..e4448814 100644 --- a/R/list_user_volumes.R +++ b/R/list_user_volumes.R @@ -3,9 +3,12 @@ #' NULL -#' List volumes associated with a user +#' List Volumes Associated With A User #' -#' @param user_id User identifier. +#' @param user_id User identifier. Must be a positive integer. Default is 6. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. +#' @param rq An `httr2` request object. Default is NULL. +#' #' @inheritParams options_params #' #' @return Tibble of volumes the user owns or collaborates on. diff --git a/R/list_users.R b/R/list_users.R index 745916a5..1a35ab9a 100644 --- a/R/list_users.R +++ b/R/list_users.R @@ -19,6 +19,7 @@ NULL #' response to authorized investigators. #' @param has_api_access Optional logical value restricting the response to #' accounts with API access enabled. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return A tibble containing directory metadata for each user, or `NULL` when diff --git a/R/list_volume_activity.R b/R/list_volume_activity.R index cbef27f8..80a36a67 100644 --- a/R/list_volume_activity.R +++ b/R/list_volume_activity.R @@ -5,10 +5,11 @@ NULL #' List Activity In A Databrary Volume #' -#' If a user has access to a volume, this command lists the modification +#' @description If a user has access to a volume, this command lists the modification #' history of the volume as a #' -#' @param vol_id Selected volume number. +#' @param vol_id Selected volume number. Must be a positive integer. Default is 1892. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to NULL. #' #' @returns A list with the activity history on a volume. diff --git a/R/list_volume_assets.R b/R/list_volume_assets.R index d9c038ca..c7531bb2 100644 --- a/R/list_volume_assets.R +++ b/R/list_volume_assets.R @@ -5,7 +5,8 @@ NULL #' List Assets in Databrary Volume. #' -#' @param vol_id Target volume number. Default is 1. +#' @param vol_id Target volume number. Must be a positive integer. Default is 1. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Default is NULL. #' #' @returns A data frame with information about all assets in a volume. diff --git a/R/list_volume_collaborators.R b/R/list_volume_collaborators.R index 9b73f4a0..369e9c3b 100644 --- a/R/list_volume_collaborators.R +++ b/R/list_volume_collaborators.R @@ -8,7 +8,8 @@ NULL #' @description Retrieve collaboration metadata for a specified volume, #' including sponsor details and access levels. #' -#' @param vol_id Target volume number. +#' @param vol_id Target volume number. Must be a positive integer. Default is 1. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return A tibble summarizing collaborator relationships on the volume, or @@ -24,57 +25,95 @@ NULL #' } #' @export list_volume_collaborators <- function(vol_id = 1, - vb = options::opt("vb"), - rq = NULL) { + vb = options::opt("vb"), + rq = NULL) { assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id > 0) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + collaborators <- perform_api_get( path = sprintf(API_VOLUME_COLLABORATORS, vol_id), rq = rq, vb = vb ) - + if (is.null(collaborators) || length(collaborators) == 0) { if (vb) { message("No collaborators found for volume ", vol_id) } return(NULL) } - + purrr::map_dfr(collaborators, function(entry) { user <- entry$user sponsor <- entry$sponsor - - sponsor_id <- if (!is.null(sponsor)) sponsor$id else NA_integer_ - sponsor_first <- if (!is.null(sponsor)) sponsor$first_name else NA_character_ - sponsor_last <- if (!is.null(sponsor)) sponsor$last_name else NA_character_ - sponsor_email <- if (!is.null(sponsor)) sponsor$email else NA_character_ - + + sponsor_id <- if (!is.null(sponsor)) + sponsor$id + else + NA_integer_ + sponsor_first <- if (!is.null(sponsor)) + sponsor$first_name + else + NA_character_ + sponsor_last <- if (!is.null(sponsor)) + sponsor$last_name + else + NA_character_ + sponsor_email <- if (!is.null(sponsor)) + sponsor$email + else + NA_character_ + tibble::tibble( collaborator_id = entry$id, volume_id = vol_id, - collaborator_user_id = if (is.null(user)) NA_integer_ else user$id, - collaborator_first_name = if (is.null(user)) NA_character_ else user$first_name, - collaborator_last_name = if (is.null(user)) NA_character_ else user$last_name, - collaborator_email = if (is.null(user)) NA_character_ else user$email, - collaborator_is_authorized_investigator = if (is.null(user$is_authorized_investigator)) NA else user$is_authorized_investigator, - collaborator_has_avatar = if (is.null(user$has_avatar)) NA else user$has_avatar, + collaborator_user_id = if (is.null(user)) + NA_integer_ + else + user$id, + collaborator_first_name = if (is.null(user)) + NA_character_ + else + user$first_name, + collaborator_last_name = if (is.null(user)) + NA_character_ + else + user$last_name, + collaborator_email = if (is.null(user)) + NA_character_ + else + user$email, + collaborator_is_authorized_investigator = if (is.null(user$is_authorized_investigator)) + NA + else + user$is_authorized_investigator, + collaborator_has_avatar = if (is.null(user$has_avatar)) + NA + else + user$has_avatar, sponsor_user_id = sponsor_id, sponsor_first_name = sponsor_first, sponsor_last_name = sponsor_last, sponsor_email = sponsor_email, - access_level = if (is.null(entry$access_level)) NA_character_ else entry$access_level, - is_publicly_visible = if (is.null(entry$is_publicly_visible)) NA else entry$is_publicly_visible, - expiration_date = if (is.null(entry$expiration_date)) NA_character_ else entry$expiration_date + access_level = if (is.null(entry$access_level)) + NA_character_ + else + entry$access_level, + is_publicly_visible = if (is.null(entry$is_publicly_visible)) + NA + else + entry$is_publicly_visible, + expiration_date = if (is.null(entry$expiration_date)) + NA_character_ + else + entry$expiration_date ) }) } - - diff --git a/R/list_volume_folders.R b/R/list_volume_folders.R index ea19094b..52a66ca3 100644 --- a/R/list_volume_folders.R +++ b/R/list_volume_folders.R @@ -5,7 +5,8 @@ NULL #' List Folders in a Databrary Volume. #' -#' @param vol_id Target volume number. +#' @param vol_id Target volume number. Must be a positive integer. Default is 1. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @returns A tibble with metadata about folders in the selected volume, or @@ -26,31 +27,32 @@ list_volume_folders <- function(vol_id = 1, assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + folders <- collect_paginated_get( path = sprintf(API_VOLUME_FOLDERS, vol_id), rq = rq, vb = vb ) - + if (is.null(folders) || length(folders) == 0) { if (vb) { message("No folders available for volume ", vol_id) } return(NULL) } - + purrr::map_dfr(folders, function(folder) { volume_value <- folder$volume if (is.null(volume_value)) { volume_value <- vol_id } - + tibble::tibble( folder_id = folder$id, folder_name = folder$name, @@ -66,4 +68,3 @@ list_volume_folders <- function(vol_id = 1, ) }) } - diff --git a/R/list_volume_funding.R b/R/list_volume_funding.R index 64240d53..dd26495f 100644 --- a/R/list_volume_funding.R +++ b/R/list_volume_funding.R @@ -6,8 +6,9 @@ NULL #' Lists Funders Associated With a Databrary Volume. #' #' @param vol_id Target volume number. -#' @param add_id A logical value. Include the volume ID in the output. +#' @param add_id A logical value. Include the volume ID in the output. #' Default is TRUE. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. #' #' @returns A data frame with funder information for the volume. @@ -51,18 +52,18 @@ list_volume_funding <- function(vol_id = 1, if (vb) message("Summarizing funding for n=", length(vol_id), " volumes.") - + purrr::map(vol_id, function(id) { fundings <- perform_api_get( path = sprintf(API_VOLUME_FUNDINGS, id), rq = rq, vb = vb ) - + if (is.null(fundings) || length(fundings) == 0) { return(NULL) } - + rows <- purrr::map_dfr(fundings, function(entry) { funder <- entry$funder tibble::tibble( diff --git a/R/list_volume_info.R b/R/list_volume_info.R index 842f2ccf..3f24b0a2 100644 --- a/R/list_volume_info.R +++ b/R/list_volume_info.R @@ -5,8 +5,9 @@ NULL #' List Basic Volume Info. #' -#' @param vol_id Target volume number. -#' @param rq An `httr2` request object. If NULL (the default) +#' @param vol_id Target volume number. Must be a positive integer. Defaults to 1. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. +#' @param rq An `httr2` request object. If NULL (the default). #' a request will be generated, but this will only permit public information #' to be returned. #' diff --git a/R/list_volume_links.R b/R/list_volume_links.R index ced97f18..07e5b715 100644 --- a/R/list_volume_links.R +++ b/R/list_volume_links.R @@ -5,7 +5,8 @@ NULL #' Retrieves URL Links From A Databrary Volume. #' -#' @param vol_id Target volume number. +#' @param vol_id Target volume number. Must be a positive integer. Default is 1. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. #' #' @returns A data frame with the requested data. @@ -35,11 +36,11 @@ list_volume_links <- function(vol_id = 1, rq = rq, vb = vb ) - + if (is.null(links) || length(links) == 0) { return(NULL) } - + purrr::map_dfr(links, function(link) { tibble::tibble( link_id = link$id, diff --git a/R/list_volume_records.R b/R/list_volume_records.R index 69b61ad5..969c86b5 100644 --- a/R/list_volume_records.R +++ b/R/list_volume_records.R @@ -12,6 +12,7 @@ NULL #' @param vol_id Target volume number. Must be a positive integer. #' @param category_id Optional numeric category identifier to filter records #' by category type. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return A tibble containing metadata for each record including id, volume, @@ -34,45 +35,38 @@ NULL #' } #' } #' @export -list_volume_records <- function( - vol_id = 1, - category_id = NULL, - vb = options::opt("vb"), - rq = NULL -) { +list_volume_records <- function(vol_id = 1, + category_id = NULL, + vb = options::opt("vb"), + rq = NULL) { # Validate vol_id assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - assertthat::assert_that( - vol_id == floor(vol_id), - msg = "vol_id must be an integer" - ) - + assertthat::assert_that(vol_id == floor(vol_id), msg = "vol_id must be an integer") + # Validate category_id if (!is.null(category_id)) { assertthat::assert_that(length(category_id) == 1) assertthat::assert_that(is.numeric(category_id)) assertthat::assert_that(category_id > 0) - assertthat::assert_that( - category_id == floor(category_id), - msg = "category_id must be an integer" - ) + assertthat::assert_that(category_id == floor(category_id), msg = "category_id must be an integer") } - + # Validate vb assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - + # Validate rq - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + # Build params list params <- list() if (!is.null(category_id)) { params$category_id <- category_id } - + # Perform API call records <- collect_paginated_get( path = sprintf(API_VOLUME_RECORDS, vol_id), @@ -80,14 +74,14 @@ list_volume_records <- function( rq = rq, vb = vb ) - + if (is.null(records) || length(records) == 0) { if (vb) { message("No records found for volume ", vol_id) } return(NULL) } - + # Process records into tibble purrr::map_dfr(records, function(record) { # Process age if present @@ -98,7 +92,7 @@ list_volume_records <- function( age_formatted <- NA_character_ age_is_estimated <- NA age_is_blurred <- NA - + if (!is.null(record$age)) { age_years <- if (!is.null(record$age$years)) { record$age$years @@ -136,7 +130,7 @@ list_volume_records <- function( NA } } - + tibble::tibble( record_id = record$id, record_volume = record$volume, diff --git a/R/list_volume_session_assets.R b/R/list_volume_session_assets.R index 851fad24..09ff76d3 100644 --- a/R/list_volume_session_assets.R +++ b/R/list_volume_session_assets.R @@ -13,8 +13,9 @@ NULL #' requre the volume ID. The `list_volume_session_assets()` *requires* a volume #' ID. #' -#' @param vol_id Target volume number. +#' @param vol_id Target volume number. Must be a positive integer. #' @param session_id The session number in the selected volume. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. #' #' @returns A data frame with information about all assets in a volume. diff --git a/R/list_volume_sessions.R b/R/list_volume_sessions.R index d8020b29..d0a78ba9 100644 --- a/R/list_volume_sessions.R +++ b/R/list_volume_sessions.R @@ -5,9 +5,10 @@ NULL #' List Sessions in Databrary Volume. #' -#' @param vol_id Target volume number. +#' @param vol_id Target volume number. Must be a positive integer. Default is 1. #' @param include_vol_data A Boolean value. Include volume-level metadata #' or not. Default is FALSE. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. If NULL (the default) #' a request will be generated, but this will only permit public information #' to be returned. diff --git a/R/list_volume_tags.R b/R/list_volume_tags.R index ddb63768..b048bcac 100644 --- a/R/list_volume_tags.R +++ b/R/list_volume_tags.R @@ -5,7 +5,8 @@ NULL #' Lists Keywords And Tags For A Volume. #' -#' @param vol_id Target volume number. +#' @param vol_id Target volume number. Must be a positive integer. Default is 1. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Default is NULL. #' #' @returns A data frame with the requested data. diff --git a/R/list_volumes.R b/R/list_volumes.R index 7409bbd0..49cbf7d0 100644 --- a/R/list_volumes.R +++ b/R/list_volumes.R @@ -12,9 +12,10 @@ NULL #' description. #' @param ordering Optional character string indicating the sort field accepted #' by the API (e.g., `"title"`, `"-title"`). +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' -#' @return A tibble summarizing each accessible volume, or `NULL` when no +#' @returns A tibble summarizing each accessible volume, or `NULL` when no #' volumes match the supplied filters. #' #' @inheritParams options_params diff --git a/R/login_db.R b/R/login_db.R index 67b0251b..876cbf81 100644 --- a/R/login_db.R +++ b/R/login_db.R @@ -11,7 +11,7 @@ #' update stored credentials in keyring/keychain. #' @param SERVICE A character label for stored credentials in the keyring. #' Default is `org.databrary.databraryr`. -#' @param vb Show verbose messages. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' #' @returns Logical value indicating whether log in is successful or not. #' diff --git a/R/logout_db.R b/R/logout_db.R index 4cf1ea11..325f8234 100644 --- a/R/logout_db.R +++ b/R/logout_db.R @@ -5,7 +5,7 @@ NULL #' Log Out of Databrary.org. #' -#' @param rq An `httr2` request object. Defaults to NULL. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' #' @returns TRUE if logging out succeeds, FALSE otherwise. #' diff --git a/R/make_default_request.R b/R/make_default_request.R index aab67b5d..8ba8d226 100644 --- a/R/make_default_request.R +++ b/R/make_default_request.R @@ -8,6 +8,7 @@ #' Defaults to `TRUE` since all API calls now require authentication. #' @param refresh When `with_token = TRUE`, determines whether to refresh the #' cached token if it is near expiry. Defaults to `TRUE`. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' #' @returns An `httr2_request` object configured for the Databrary API. #' diff --git a/R/make_login_client.R b/R/make_login_client.R index 338a9254..1fd97438 100644 --- a/R/make_login_client.R +++ b/R/make_login_client.R @@ -9,6 +9,7 @@ NULL #' @param password Databrary password (not recommended as it will displayed as you type) #' @param store A boolean value. If TRUE store/retrieve credentials from the system keyring/keychain. #' @param overwrite A boolean value. If TRUE and store is TRUE, overwrite/ update stored credentials in keyring/keychain. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param SERVICE A character label for stored credentials in the keyring. Default is "databrary" #' @param rq An `httr2` request object. Defaults to NULL. #' diff --git a/R/search_for_funder.R b/R/search_for_funder.R index 0b0928b8..06f2cd54 100644 --- a/R/search_for_funder.R +++ b/R/search_for_funder.R @@ -5,9 +5,10 @@ NULL #' Report Information About A Funder. #' -#' @param search_string String to search. +#' @param search_string String to search. Default is "national science foundation". #' @param approved_only Logical. When TRUE (default) only approved funders are #' returned. Set to FALSE to include unapproved funders as well. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Default is NULL. #' #' @returns A data frame with information about the funder. diff --git a/R/search_for_tags.R b/R/search_for_tags.R index 873690a1..b0e72b69 100644 --- a/R/search_for_tags.R +++ b/R/search_for_tags.R @@ -6,6 +6,7 @@ NULL #' Search For Tags on Volumes or Sessions. #' #' @param search_string String to search. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Default is NULL. #' #' @returns An array of tags that match the tag_string. diff --git a/R/search_institutions.R b/R/search_institutions.R index c5b0ecc1..f5436449 100644 --- a/R/search_institutions.R +++ b/R/search_institutions.R @@ -10,6 +10,7 @@ NULL #' #' @param search_string Character string describing the institution search #' query. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return A tibble containing matching institutions ordered by relevance, or @@ -30,31 +31,41 @@ search_institutions <- function(search_string, assertthat::assert_that(assertthat::is.string(search_string)) assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - + assertthat::assert_that(is.null(rq) || + inherits(rq, "httr2_request")) + results <- collect_paginated_get( path = API_SEARCH_INSTITUTIONS, params = list(q = search_string), rq = rq, vb = vb ) - + if (is.null(results) || length(results) == 0) { if (vb) { - message("No institutions matched the search query '", search_string, "'.") + message("No institutions matched the search query '", + search_string, + "'.") } return(NULL) } - + purrr::map_dfr(results, function(entry) { tibble::tibble( institution_id = entry$id, institution_name = entry$name, - institution_url = if (is.null(entry$url)) NA_character_ else entry$url, - institution_has_avatar = if (is.null(entry$has_avatar)) NA else entry$has_avatar, - score = if (is.null(entry$score)) NA_real_ else entry$score + institution_url = if (is.null(entry$url)) + NA_character_ + else + entry$url, + institution_has_avatar = if (is.null(entry$has_avatar)) + NA + else + entry$has_avatar, + score = if (is.null(entry$score)) + NA_real_ + else + entry$score ) }) } - - diff --git a/R/search_users.R b/R/search_users.R index 4b803304..3a5e40d3 100644 --- a/R/search_users.R +++ b/R/search_users.R @@ -9,6 +9,7 @@ NULL #' email address. #' #' @param search_string Character string describing the search query. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return A tibble containing user matches ordered by relevance, or `NULL` diff --git a/R/search_volumes.R b/R/search_volumes.R index 16bce781..15a66d2f 100644 --- a/R/search_volumes.R +++ b/R/search_volumes.R @@ -9,6 +9,7 @@ NULL #' endpoint. #' #' @param search_string Character string describing the volume search query. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' #' @return A tibble containing matching volumes ordered by relevance, or `NULL` diff --git a/R/whoami.R b/R/whoami.R index 16954138..b8227887 100644 --- a/R/whoami.R +++ b/R/whoami.R @@ -5,8 +5,10 @@ #' `login_db()`. #' #' @inheritParams options_params +#' #' @param refresh Whether to attempt automatic token refresh when the current #' access token is expired. Defaults to `TRUE`. +#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' #' @returns A list containing `auth_method` and `user` fields (both lists) or #' `NULL` if the request fails due to lack of authentication. @@ -17,22 +19,24 @@ #' whoami() #' } #' @export -whoami <- function(refresh = TRUE, vb = options::opt("vb")) { +whoami <- function(refresh = TRUE, + vb = options::opt("vb")) { assertthat::assert_that(is.logical(refresh), length(refresh) == 1) assertthat::assert_that(is.logical(vb), length(vb) == 1) - + req <- tryCatch( make_default_request(refresh = refresh, vb = vb), error = function(err) { - if (vb) message("Authentication required: ", conditionMessage(err)) + if (vb) + message("Authentication required: ", conditionMessage(err)) NULL } ) - + if (is.null(req)) { return(NULL) } - + resp <- tryCatch( req |> httr2::req_url(OAUTH_TEST_URL) |> @@ -42,22 +46,28 @@ whoami <- function(refresh = TRUE, vb = options::opt("vb")) { if (vb) { message("whoami request failed: ", conditionMessage(err)) message("whoami -> request url: ", OAUTH_TEST_URL) - message("whoami -> authorization header: ", if (!is.null(req$headers$Authorization)) req$headers$Authorization else "") + message( + "whoami -> authorization header: ", + if (!is.null(req$headers$Authorization)) + req$headers$Authorization + else + "" + ) } NULL } ) - + if (is.null(resp)) { return(NULL) } - + status <- httr2::resp_status(resp) if (status >= 400) { - if (vb) message(httr2_error_message(resp)) + if (vb) + message(httr2_error_message(resp)) return(NULL) } - + httr2::resp_body_json(resp, simplifyVector = TRUE) } - From f1865ba37433499b237d217d7c5bbc4c16c5941e Mon Sep 17 00:00:00 2001 From: rogilmore Date: Mon, 2 Feb 2026 13:08:36 -0500 Subject: [PATCH 22/27] Change parameter documentation to include more useful default values; minor edits to function documentation; add .progress parameter to some `purrr()` calls; comment-out legacy checks on rq parameter for some functions. --- R/get_db_stats.R | 35 +++++++++++++------- R/get_folder_file.R | 4 +-- R/get_session_by_id.R | 4 +-- R/get_session_by_name.R | 4 +-- R/get_session_file.R | 16 ++++----- R/get_volume_collaborator_by_id.R | 5 +-- R/list_folder_assets.R | 6 ++-- R/list_user_volumes.R | 2 +- R/list_volume_activity.R | 12 +++---- R/list_volume_assets.R | 17 +++++----- R/list_volume_collaborators.R | 2 +- R/list_volume_funding.R | 15 +++++---- R/list_volume_records.R | 15 ++++++++- R/list_volume_session_assets.R | 55 ++++++++++++++++++------------- R/list_volume_sessions.R | 4 +++ R/list_volume_tags.R | 6 ++++ R/list_volumes.R | 5 ++- 17 files changed, 128 insertions(+), 79 deletions(-) diff --git a/R/get_db_stats.R b/R/get_db_stats.R index a92ab4a5..6447ffb3 100644 --- a/R/get_db_stats.R +++ b/R/get_db_stats.R @@ -5,11 +5,11 @@ NULL #' Get Stats About Databrary. #' -#' `get_db_stats` returns basic summary information about -#' the institutions, people, and data hosted on 'Databrary.org'. +#' Returns basic summary information about +#' the institutions, people, and video data hosted on Databrary. #' #' @param type Type of Databrary report to run "institutions", "people", "data" -#' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. +#' @param vb Show verbose messages. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. #' #' @returns A data frame with the requested data or NULL if there is @@ -21,8 +21,6 @@ NULL #' \donttest{ #' get_db_stats() #' get_db_stats("stats") -#' get_db_stats("people") # Information about the newest authorized investigators. -#' get_db_stats("places") # Information about the newest institutions. #' } #' @export get_db_stats <- function(type = "stats", vb = options::opt("vb"), rq = NULL) { @@ -45,6 +43,19 @@ get_db_stats <- function(type = "stats", vb = options::opt("vb"), rq = NULL) { ) ) + if (!type %in% c( + "institutions", + "people", + "researchers", + "investigators", + "data", + "stats", + "numbers" + )) { + if (vb) + message("Legacy parameter not supported in new API") + } + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) @@ -53,13 +64,13 @@ get_db_stats <- function(type = "stats", vb = options::opt("vb"), rq = NULL) { ("httr2_request" %in% class(rq)) ) - if (is.null(rq)) { - if (vb) { - message("\nNULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } + # if (is.null(rq)) { + # if (vb) { + # message("\nNULL request object. Will generate default.") + # message("Not logged in. Only public information will be returned.") + # } + # rq <- databraryr::make_default_request() + # } stats <- perform_api_get( path = API_ACTIVITY_SUMMARY, rq = rq, diff --git a/R/get_folder_file.R b/R/get_folder_file.R index bbe78442..042a011e 100644 --- a/R/get_folder_file.R +++ b/R/get_folder_file.R @@ -8,7 +8,7 @@ NULL #' @param vol_id An integer indicating the volume identifier. Default is 1. #' @param folder_id An integer indicating a valid folder identifier #' linked to a volume. Default value is 9807, the materials folder for volume 1. -#' @param file_id An integer indicating the file identifier. +#' @param file_id An integer indicating the file identifier. Default is 1. #' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An httr2 request object. #' @@ -28,7 +28,7 @@ NULL get_folder_file <- function(vol_id = 1, folder_id = 9807, - file_id, + file_id = 1, vb = options::opt("vb"), rq = NULL) { assertthat::assert_that(is.numeric(vol_id)) diff --git a/R/get_session_by_id.R b/R/get_session_by_id.R index aa6980ae..b6f636d7 100644 --- a/R/get_session_by_id.R +++ b/R/get_session_by_id.R @@ -6,7 +6,7 @@ NULL #' Get Session (Slot) Data From A Databrary Volume #' #' @param session_id An integer indicating a valid session/slot identifier -#' linked to a volume. Default value is 9807, the materials folder for volume 1. +#' linked to a volume. Default value is 6256 in volume 1. #' @param vol_id An integer indicating the volume identifier. Default is 1. #' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An httr2 request object. @@ -25,7 +25,7 @@ NULL #' } #' @export get_session_by_id <- - function(session_id = 9807, + function(session_id = 6256, vol_id = 1, vb = options::opt("vb"), rq = NULL) { diff --git a/R/get_session_by_name.R b/R/get_session_by_name.R index 5150cbb4..80f97a2e 100644 --- a/R/get_session_by_name.R +++ b/R/get_session_by_name.R @@ -3,11 +3,11 @@ #' NULL -#' Get Session (Slot) Data From A Databrary Volume By Session Name. +#' Get Session Data From A Databrary Volume By Session Name. #' #' @param session_name A string. The name of the target session. Defaults to "Advisory #' Board Meeting", the name of several of the sessions in the public Volume 1. -#' @param vol_id An integer indicating the volume identifier. Default is 1. +#' @param vol_id Volume identifier. Must be an integer. Default is 1. #' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An httr2 request, such as that generated by `make_default_request()`. #' diff --git a/R/get_session_file.R b/R/get_session_file.R index 9e7e4532..35d7cd5e 100644 --- a/R/get_session_file.R +++ b/R/get_session_file.R @@ -7,28 +7,28 @@ NULL #' #' @param vol_id An integer indicating the volume identifier. Default is 1. #' @param session_id An integer indicating a valid session/slot identifier -#' linked to a volume. Default value is 9807, the materials folder for volume 1. -#' @param file_id An integer indicating the file identifier. +#' linked to a volume. Default value is 9578. +#' @param file_id An integer indicating the file identifier. The default is +#' 27227. #' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An httr2 request object. #' -#' @returns A JSON blob with the file data. If the user has previously logged -#' in to Databrary via `login_db()`, then files that have restricted access -#' can be downloaded, subject to the sharing release levels on those files. +#' @returns Metadata about the file if the user has read privileges. #' #' @inheritParams options_params #' #' @examples #' \donttest{ #' \dontrun{ -#' get_session_file(vol_id = 2, session_id = 11, file_id = 1) +#' get_session_file(vol_id = 2, session_id = 11, file_id = 3) +#' # A video from volume 1, session 11. #' } #' } #' @export get_session_file <- function(vol_id = 1, - session_id = 9807, - file_id, + session_id = 9578, + file_id = 27227, vb = options::opt("vb"), rq = NULL) { assertthat::assert_that(is.numeric(vol_id)) diff --git a/R/get_volume_collaborator_by_id.R b/R/get_volume_collaborator_by_id.R index 0420dce7..64a95bff 100644 --- a/R/get_volume_collaborator_by_id.R +++ b/R/get_volume_collaborator_by_id.R @@ -10,8 +10,9 @@ NULL #' collaborator details including user information, sponsor details, access #' level, and visibility settings. #' -#' @param vol_id Target volume number. Must be a positive integer. -#' @param collaborator_id Numeric collaborator identifier. Must be a positive integer. +#' @param vol_id Target volume number. Must be a positive integer. Default is 1. +#' @param collaborator_id Numeric collaborator identifier. +#' Must be a positive integer. Default is 1. #' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' diff --git a/R/list_folder_assets.R b/R/list_folder_assets.R index 2ce1d87d..95d0ebe5 100644 --- a/R/list_folder_assets.R +++ b/R/list_folder_assets.R @@ -6,7 +6,7 @@ NULL #' List Assets Within a Databrary Folder. #' #' @param folder_id Folder identifier scoped to the given volume. Must be a -#' positive integer. Default is 1. +#' positive integer. Default is 9807. #' @param vol_id Volume containing the folder. Required for Django API calls. #' Must be a positive integer. Default is 1. #' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. @@ -24,8 +24,8 @@ NULL #' } #' } #' @export -list_folder_assets <- function(folder_id = 1, - vol_id = NULL, +list_folder_assets <- function(folder_id = 9807, + vol_id = 1, vb = options::opt("vb"), rq = NULL) { assertthat::assert_that(length(folder_id) == 1) diff --git a/R/list_user_volumes.R b/R/list_user_volumes.R index e4448814..0b8bdc6f 100644 --- a/R/list_user_volumes.R +++ b/R/list_user_volumes.R @@ -44,7 +44,7 @@ list_user_volumes <- function(user_id = 6, vol_access_level = entry$access_level, vol_sharing_level = entry$sharing_level ) - }) %>% + }, .progress = TRUE) %>% purrr::list_rbind() %>% dplyr::mutate(user_id = user_df$id, user_prename = user_df$prename, diff --git a/R/list_volume_activity.R b/R/list_volume_activity.R index 80a36a67..1dda6da7 100644 --- a/R/list_volume_activity.R +++ b/R/list_volume_activity.R @@ -6,9 +6,9 @@ NULL #' List Activity In A Databrary Volume #' #' @description If a user has access to a volume, this command lists the modification -#' history of the volume as a +#' history of the volume. #' -#' @param vol_id Selected volume number. Must be a positive integer. Default is 1892. +#' @param vol_id Selected volume number. Must be a positive integer. Default is NULL. #' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to NULL. #' @@ -19,15 +19,15 @@ NULL #' @examples #' \donttest{ #' \dontrun{ -#' # The following will only return output if the user has write privileges +#' # The following will only return output if the user has *write* privileges #' # on the volume. #' -#' list_volume_activity(vol_id = 1892) # Activity on volume 1892. +#' list_volume_activity(vol_id) #' } #' } #' @export list_volume_activity <- - function(vol_id = 1892, + function(vol_id = NULL, vb = options::opt("vb"), rq = NULL) { # Check parameters @@ -104,5 +104,5 @@ list_volume_activity <- folder_id = safe_int(folder_id), deleted_at = entry$deleted_at ) - }) + }, .progress = TRUE) } diff --git a/R/list_volume_assets.R b/R/list_volume_assets.R index c7531bb2..fcb7ec04 100644 --- a/R/list_volume_assets.R +++ b/R/list_volume_assets.R @@ -31,14 +31,15 @@ list_volume_assets <- function(vol_id = 1, assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) + # Not needed for DB2 API. Delete # Handle NULL rq - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } + # if (is.null(rq)) { + # if (vb) { + # message("NULL request object. Will generate default.") + # message("Not logged in. Only public information will be returned.") + # } + # rq <- databraryr::make_default_request() + # } sessions <- collect_paginated_get( path = sprintf(API_VOLUME_SESSIONS, vol_id), @@ -87,7 +88,7 @@ list_volume_assets <- function(vol_id = 1, session_date = session$source_date, session_release = session$release_level ) - }) %>% + }, .progress = TRUE) %>% purrr::list_rbind() }) %>% purrr::list_rbind() diff --git a/R/list_volume_collaborators.R b/R/list_volume_collaborators.R index 369e9c3b..6ec9297a 100644 --- a/R/list_volume_collaborators.R +++ b/R/list_volume_collaborators.R @@ -115,5 +115,5 @@ list_volume_collaborators <- function(vol_id = 1, else entry$expiration_date ) - }) + }, .progress = TRUE) } diff --git a/R/list_volume_funding.R b/R/list_volume_funding.R index dd26495f..e28b00ac 100644 --- a/R/list_volume_funding.R +++ b/R/list_volume_funding.R @@ -42,13 +42,14 @@ list_volume_funding <- function(vol_id = 1, assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - message("Not logged in. Only public information will be returned.") - } - rq <- databraryr::make_default_request() - } + # Not needed for new API. Delete + # if (is.null(rq)) { + # if (vb) { + # message("NULL request object. Will generate default.") + # message("Not logged in. Only public information will be returned.") + # } + # rq <- databraryr::make_default_request() + # } if (vb) message("Summarizing funding for n=", length(vol_id), " volumes.") diff --git a/R/list_volume_records.R b/R/list_volume_records.R index 969c86b5..b99fd210 100644 --- a/R/list_volume_records.R +++ b/R/list_volume_records.R @@ -77,11 +77,24 @@ list_volume_records <- function(vol_id = 1, if (is.null(records) || length(records) == 0) { if (vb) { - message("No records found for volume ", vol_id) + message("No records found with category_id = ", + category_id, + " for volume ", + vol_id) } return(NULL) } + if (vb) + message( + "Found n = ", + length(records), + " records with category_id = ", + category_id, + " in volume ", + vol_id + ) + # Process records into tibble purrr::map_dfr(records, function(record) { # Process age if present diff --git a/R/list_volume_session_assets.R b/R/list_volume_session_assets.R index 09ff76d3..c43bc052 100644 --- a/R/list_volume_session_assets.R +++ b/R/list_volume_session_assets.R @@ -1,27 +1,27 @@ #' @eval options::as_params() #' @name options_params -#' +#' NULL #' List Assets in a Session from a Databrary volume. #' #'#' @description #' `r lifecycle::badge("experimental")` -#' +#' #' `list_volume_session_assets()` is a new name for the = 1) - + assertthat::assert_that(length(session_id) == 1) assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id >= 1) - + assertthat::assert_that(length(vb) == 1) assertthat::assert_that(is.logical(vb)) - + assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) - if (is.null(rq)) { - if (vb) { - message("NULL request object. Will generate default.") - } - rq <- databraryr::make_default_request() - } - + + # Not needed in DB2 API. Delete. + # if (is.null(rq)) { + # if (vb) { + # message("NULL request object. Will generate default.") + # } + # rq <- databraryr::make_default_request() + # } + session <- perform_api_get( path = sprintf(API_SESSION_DETAIL, vol_id, session_id), rq = rq, vb = vb ) - + if (is.null(session)) { if (vb) message("No matching session_id: ", session_id) return(NULL) } - + files <- collect_paginated_get( path = sprintf(API_SESSION_FILES, vol_id, session_id), rq = rq, vb = vb ) - + if (is.null(files) || length(files) == 0) { if (vb) - message("No assets in session_id ", session_id) + message("No assets in vol_id ", vol_id, " session_id ", session_id) return(NULL) } - + if (vb) + message("Found n = ", + length(files), + " assets in vol_id ", + vol_id, + " session_id ", + session_id) + asset_rows <- purrr::map(files, function(file) { format <- file$format uploader <- file$uploader - + tibble::tibble( asset_id = file$id, asset_name = file$name, @@ -104,6 +113,6 @@ list_volume_session_assets <- ) }) %>% purrr::list_rbind() - + asset_rows } diff --git a/R/list_volume_sessions.R b/R/list_volume_sessions.R index d0a78ba9..1bc05527 100644 --- a/R/list_volume_sessions.R +++ b/R/list_volume_sessions.R @@ -55,6 +55,10 @@ list_volume_sessions <- message("No session data for volume ", vol_id) return(NULL) } + if (vb) message("Found n = ", + length(sessions), + " sessions in vol_id ", + vol_id) df <- purrr::map_dfr(sessions, function(session) { tibble::tibble( diff --git a/R/list_volume_tags.R b/R/list_volume_tags.R index b048bcac..ff5fe658 100644 --- a/R/list_volume_tags.R +++ b/R/list_volume_tags.R @@ -39,8 +39,14 @@ list_volume_tags <- function(vol_id = 1, ) if (is.null(tags) || length(tags) == 0) { + if (vb) + message("No tags for vol_id ", vol_id) return(NULL) } + if (vb) message("Found n = ", + length(tags), + " tags in vol_id ", + vol_id) tags } diff --git a/R/list_volumes.R b/R/list_volumes.R index 49cbf7d0..9f8be9a2 100644 --- a/R/list_volumes.R +++ b/R/list_volumes.R @@ -59,6 +59,9 @@ list_volumes <- function(search = NULL, } return(NULL) } + if (vb) message("Found n = ", + length(volumes), + " volumes that matched the supplied filters.") purrr::map_dfr(volumes, function(volume) { owner_connection <- volume$owner_connection @@ -81,7 +84,7 @@ list_volumes <- function(search = NULL, volume_owner_institution_id = if (is.null(owner_institution)) NA_integer_ else owner_institution$id, volume_owner_institution_name = if (is.null(owner_institution$name)) NA_character_ else owner_institution$name ) - }) + }, .progress = TRUE) } From 5428d052726fc6be687eaee08f800292cf36ff15 Mon Sep 17 00:00:00 2001 From: rogilmore Date: Tue, 3 Feb 2026 13:53:12 -0500 Subject: [PATCH 23/27] Minor edit to function documentation; Add verbose message. --- R/get_db_stats.R | 2 +- R/list_user_volumes.R | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/R/get_db_stats.R b/R/get_db_stats.R index 6447ffb3..979c21ef 100644 --- a/R/get_db_stats.R +++ b/R/get_db_stats.R @@ -3,7 +3,7 @@ #' NULL -#' Get Stats About Databrary. +#' Get Stats About Databrary #' #' Returns basic summary information about #' the institutions, people, and video data hosted on Databrary. diff --git a/R/list_user_volumes.R b/R/list_user_volumes.R index 0b8bdc6f..ccf2df9a 100644 --- a/R/list_user_volumes.R +++ b/R/list_user_volumes.R @@ -29,6 +29,7 @@ list_user_volumes <- function(user_id = 6, if (vb) message("No volume data for user ", user_id) return(NULL) } + if (vb) message("Found n = ", length(volumes), " volumes for user_id ", user_id, ".") user <- get_user_by_id(user_id, vb = vb, rq = rq) user_df <- tibble::as_tibble(user) From cb7e3186f0c79550f2327357bbed7a6c196600f2 Mon Sep 17 00:00:00 2001 From: rogilmore Date: Fri, 6 Feb 2026 09:35:54 -0500 Subject: [PATCH 24/27] Further mods to function docs; minor change to verbose messaging. --- R/download_folder_asset.R | 12 +++++++----- R/download_utils.R | 10 +++++----- R/get_folder_by_id.R | 9 +++++---- R/get_folder_file.R | 10 ++++++++-- tests/testthat/test-download_folder_asset.R | 3 ++- 5 files changed, 27 insertions(+), 17 deletions(-) diff --git a/R/download_folder_asset.R b/R/download_folder_asset.R index 9081a1dd..fa4b281f 100644 --- a/R/download_folder_asset.R +++ b/R/download_folder_asset.R @@ -11,8 +11,10 @@ NULL #' specified directory. #' #' @param vol_id Integer. Volume identifier containing the folder. Default is 1. -#' @param folder_id Integer. Folder identifier within the volume. Default is 1. -#' @param asset_id Integer. Asset identifier within the folder. Default is 1. +#' @param folder_id Integer. Folder identifier within the volume. Default is 9807, +#' the Materials folder for Volume 1. +#' @param asset_id Integer. Asset identifier within the folder. Default is 1, a +#' demo video called 'counting_demo_video.mp4'. #' @param file_name Optional character string. File name to use when saving the #' asset. Defaults to the API-provided file name. #' @param target_dir Character string. Directory where the file will be saved. @@ -32,15 +34,15 @@ NULL #' \donttest{ #' \dontrun{ #' download_folder_asset() # Default public asset in folder 1 of volume 1 -#' download_folder_asset(vol_id = 1, folder_id = 8460, asset_id = 19919, +#' download_folder_asset(vol_id = 1, folder_id = 9807, asset_id = 1, #' file_name = "video.mp4") #' } #' } #' #' @export download_folder_asset <- function(vol_id = 1, - folder_id = 8460, - asset_id = 19919, + folder_id = 9807, + asset_id = 1, file_name = "video.mp4", target_dir = tempdir(), timeout_secs = REQUEST_TIMEOUT, diff --git a/R/download_utils.R b/R/download_utils.R index caea1b26..74dbc968 100644 --- a/R/download_utils.R +++ b/R/download_utils.R @@ -70,6 +70,7 @@ download_signed_file <- function(download_url, assertthat::assert_that(assertthat::is.string(dest_path)) assertthat::is.number(timeout_secs) assertthat::assert_that(timeout_secs > 0) + assertthat::assert_that(length(timeout_secs == 1)) parent_dir <- dirname(dest_path) if (!dir.exists(parent_dir)) { @@ -77,16 +78,15 @@ download_signed_file <- function(download_url, } assertthat::is.writeable(parent_dir) - req <- httr2::request(download_url) | + req <- httr2::request(download_url) |> httr2::req_timeout(seconds = timeout_secs) - if (vb) { - message("Saving download to '", dest_path, "'.") - } - tryCatch( { httr2::req_perform(req, path = dest_path) + if (vb) { + message("Saving download to '", dest_path, "'.") + } dest_path }, httr2_error = function(cnd) { diff --git a/R/get_folder_by_id.R b/R/get_folder_by_id.R index 731b0082..480d12c1 100644 --- a/R/get_folder_by_id.R +++ b/R/get_folder_by_id.R @@ -3,10 +3,11 @@ #' NULL -#' Get Folder Metadata From a Databrary Volume. +#' Get Folder Metadata From a Databrary Volume #' -#' @param folder_id Folder identifier within the specified volume. -#' @param vol_id Volume identifier containing the folder. +#' @param folder_id Folder identifier within the specified volume. Default is +#' 9807, the Materials folder for Volume 1. +#' @param vol_id Volume identifier containing the folder. Default is 1. #' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Defaults to `NULL`. #' @@ -22,7 +23,7 @@ NULL #' } #' } #' @export -get_folder_by_id <- function(folder_id = 1, +get_folder_by_id <- function(folder_id = 9807, vol_id = 1, vb = options::opt("vb"), rq = NULL) { diff --git a/R/get_folder_file.R b/R/get_folder_file.R index 042a011e..099d9d3a 100644 --- a/R/get_folder_file.R +++ b/R/get_folder_file.R @@ -4,7 +4,12 @@ NULL #' Get Session File Data From A Databrary Volume -#' +#' +#' @description +#' Databrary volumes have folders where study or collection-wide files +#' can be stored and shared. `get_folder_file()` returns metadata about +#' specific files stored in a volume folder. +#' #' @param vol_id An integer indicating the volume identifier. Default is 1. #' @param folder_id An integer indicating a valid folder identifier #' linked to a volume. Default value is 9807, the materials folder for volume 1. @@ -21,7 +26,8 @@ NULL #' @examples #' \donttest{ #' \dontrun{ -#' get_folder_file(vol_id = 2, folder_id = 11, file_id = 1) +#' get_folder_file() # Data about file_id 1 from folder_id 9807 in Volume 1. +#' get_folder_file(vol_id = 2, folder_id = 9819, file_id = 16) # A PDF from Volume 2. #' } #' } #' @export diff --git a/tests/testthat/test-download_folder_asset.R b/tests/testthat/test-download_folder_asset.R index 279a2b6d..16ca27ac 100644 --- a/tests/testthat/test-download_folder_asset.R +++ b/tests/testthat/test-download_folder_asset.R @@ -60,7 +60,8 @@ test_that("download_folder_asset fetches signed link", { dest_path } ) - + skip_if_null_response(result, "download_folder_asset(vol_id = 1, folder_id = 2, asset_id = 3, target_dir = tmp_dir)") + expect_true(grepl("example.bin$", result)) expect_equal(result, captured_dest) expect_equal(captured_path, sprintf("/volumes/%s/folders/%s/files/%s/download-link/", 1, 2, 3)) From 1ef7701b914fd34d4abf30f729a1c1e0ad6fc04d Mon Sep 17 00:00:00 2001 From: rogilmore Date: Fri, 6 Feb 2026 11:57:37 -0500 Subject: [PATCH 25/27] Use validate_flag() throughout. --- DESCRIPTION | 4 ++- R/api_utils.R | 7 ++++ R/assign_constants.R | 2 +- R/auth_service.R | 2 ++ R/download_folder_asset.R | 3 +- R/download_folder_zip.R | 10 +++--- R/download_session_asset.R | 3 +- R/download_session_assets_fr_df.R | 8 +++-- R/download_session_csv.R | 9 +++--- R/download_session_zip.R | 9 +++--- R/download_single_folder_asset_fr_df.R | 14 +++----- R/download_single_session_asset_fr_df.R | 9 ++---- R/download_utils.R | 32 +++++++++--------- R/download_video.R | 3 +- R/download_volume_zip.R | 3 +- R/get_category_by_id.R | 6 +--- R/get_db_stats.R | 10 +----- R/get_folder_by_id.R | 3 +- R/get_folder_file.R | 3 +- R/get_funder_by_id.R | 8 ++--- R/get_institution_avatar.R | 7 +--- R/get_institution_by_id.R | 3 ++ R/get_session_by_id.R | 3 +- R/get_session_by_name.R | 3 +- R/get_session_file.R | 3 +- R/get_tag_by_id.R | 6 +--- R/get_user_avatar.R | 7 +--- R/get_user_by_id.R | 3 ++ R/get_volume_by_id.R | 3 +- R/get_volume_collaborator_by_id.R | 9 ++---- R/get_volume_record_by_id.R | 10 ++---- R/list_asset_formats.R | 3 +- R/list_authorized_investigators.R | 2 +- R/list_categories.R | 7 ++-- R/list_folder_assets.R | 3 +- R/list_institution_affiliates.R | 3 +- R/list_institutions.R | 6 +--- R/list_session_activity.R | 2 +- R/list_session_assets.R | 2 ++ R/list_user_affiliates.R | 3 +- R/list_user_history.R | 3 +- R/list_user_sponsors.R | 3 +- R/list_user_volumes.R | 1 + R/list_users.R | 7 ---- R/list_volume_activity.R | 5 +-- R/list_volume_assets.R | 13 +------- R/list_volume_collaborators.R | 3 +- R/list_volume_folders.R | 3 +- R/list_volume_funding.R | 14 ++------ R/list_volume_info.R | 3 +- R/list_volume_links.R | 3 +- R/list_volume_records.R | 7 +--- R/list_volume_session_assets.R | 11 +------ R/list_volume_sessions.R | 3 +- R/list_volume_tags.R | 3 +- R/list_volumes.R | 3 +- R/login_db.R | 4 +-- R/logout_db.R | 2 +- R/make_default_request.R | 7 ++-- R/make_login_client.R | 8 ++--- R/search_for_funder.R | 5 ++- R/search_for_tags.R | 3 +- R/search_institutions.R | 3 +- R/search_users.R | 3 +- R/search_volumes.R | 3 +- R/utils.R | 43 +++++++++++++------------ R/whoami.R | 4 +-- 67 files changed, 154 insertions(+), 252 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index dd58e65b..8b651a97 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -5,8 +5,10 @@ Version: 0.6.6.9002 Authors@R: c( person("Rick", "O. Gilmore", , "rog1@psu.edu", role = c("aut", "cre", "cph")), person("Jeffrey", "Spies", , "cran@jeffspies.com", role = "aut"), + person("Pawel", "Armatys", "pawel.armatys@montrosesoftware.com", role="aut") person("National Science Foundation OAC-2032713", role = "fnd"), - person("National Institutes of Health R01HD094830", role = "fnd") + person("National Institutes of Health R01HD094830", role = "fnd"), + person("National Science Foundation BCS 2444730, 2444731", role="fnd") ) Maintainer: Rick O. Gilmore Description: 'Databrary.org' is a restricted access repository for diff --git a/R/api_utils.R b/R/api_utils.R index 7c5787b5..ca95322f 100644 --- a/R/api_utils.R +++ b/R/api_utils.R @@ -174,3 +174,10 @@ snake_case_list <- function(obj) { } } +#' @noRd +validate_flag <- function(value, name) { + if (!is.null(value)) { + assertthat::assert_that(length(value) == 1) + assertthat::assert_that(is.logical(value), msg = paste0(name, " must be logical.")) + } +} \ No newline at end of file diff --git a/R/assign_constants.R b/R/assign_constants.R index 25360652..7ede9a2d 100644 --- a/R/assign_constants.R +++ b/R/assign_constants.R @@ -18,7 +18,7 @@ NULL #' } #' @export assign_constants <- function(vb = options::opt("vb"), rq = NULL) { - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") if (vb) { message("Retrieving grouped formats and static enums.") } diff --git a/R/auth_service.R b/R/auth_service.R index b747ca8e..100174b6 100644 --- a/R/auth_service.R +++ b/R/auth_service.R @@ -29,6 +29,7 @@ oauth_password_grant <- function(username, assertthat::assert_that(assertthat::is.string(password)) assertthat::assert_that(assertthat::is.string(client_id)) assertthat::assert_that(assertthat::is.string(client_secret)) + validate_flag(vb, "vb") req <- make_default_request(with_token = FALSE) |> httr2::req_url(OAUTH_TOKEN_URL) @@ -74,6 +75,7 @@ oauth_refresh_grant <- function(refresh_token, assertthat::assert_that(assertthat::is.string(refresh_token)) assertthat::assert_that(assertthat::is.string(client_id)) assertthat::assert_that(assertthat::is.string(client_secret)) + validate_flag(vb, "vb") req <- make_default_request() |> httr2::req_url(OAUTH_TOKEN_URL) diff --git a/R/download_folder_asset.R b/R/download_folder_asset.R index fa4b281f..30385935 100644 --- a/R/download_folder_asset.R +++ b/R/download_folder_asset.R @@ -73,8 +73,7 @@ download_folder_asset <- function(vol_id = 1, assertthat::assert_that(length(timeout_secs) == 1) assertthat::assert_that(timeout_secs > 0) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) diff --git a/R/download_folder_zip.R b/R/download_folder_zip.R index 4a762446..9ced2c48 100644 --- a/R/download_folder_zip.R +++ b/R/download_folder_zip.R @@ -11,8 +11,10 @@ NULL #' descriptor. When the archive is ready, Databrary emails a signed download #' link to the authenticated user. #' -#' @param vol_id Volume identifier for the folder. -#' @param folder_id Folder identifier scoped within the specified volume. +#' @param vol_id Volume identifier for the folder. Must be a positive integer. +#' Default is 1. +#' @param folder_id Folder identifier scoped within the specified volume. Must +#' be a positive integer. Default is 9807. #' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Default is `NULL`, in which case a #' default authenticated request is generated. @@ -25,13 +27,13 @@ NULL #' @examples #' \donttest{ #' \dontrun{ -#' download_folder_zip(vol_id = 1, folder_id = 1) +#' download_folder_zip() # Volume 1, folder 9807 #' } #' } #' #' @export download_folder_zip <- function(vol_id = 1, - folder_id = 1, + folder_id = 9807, vb = options::opt("vb"), rq = NULL) { assertthat::assert_that(length(vol_id) == 1) diff --git a/R/download_session_asset.R b/R/download_session_asset.R index f85687c5..ba8c2578 100644 --- a/R/download_session_asset.R +++ b/R/download_session_asset.R @@ -71,8 +71,7 @@ download_session_asset <- function(vol_id = 1, assertthat::assert_that(length(timeout_secs) == 1) assertthat::assert_that(timeout_secs > 0) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) diff --git a/R/download_session_assets_fr_df.R b/R/download_session_assets_fr_df.R index f26cda2c..e40dece6 100644 --- a/R/download_session_assets_fr_df.R +++ b/R/download_session_assets_fr_df.R @@ -11,7 +11,8 @@ NULL #' `list_session_assets()` or `list_volume_session_assets()` output. #' #' @param session_df Data frame describing assets. Must include `vol_id`, -#' `session_id`, `asset_id`, and `asset_name` columns. +#' `session_id`, `asset_id`, and `asset_name` columns. Default is the result +#' `download_session_assets_fr_df(session_id = assets, vol_id = 1)`. #' @param target_dir Character string. Base directory for downloads. Defaults to #' `tempdir()`. #' @param add_session_subdir Logical. When `TRUE`, creates a subdirectory per @@ -33,13 +34,14 @@ NULL #' @examples #' \donttest{ #' \dontrun{ -#' assets <- list_session_assets(vol_id = 1, session_id = 9807) +#' assets <- list_session_assets(vol_id = 1, session_id = 9224) #' download_session_assets_fr_df(assets, vb = TRUE) #' } #' } #' @export download_session_assets_fr_df <- - function(session_df = list_session_assets(), + function(session_df = list_session_assets(session_id = 9224, + vol_id = 1), target_dir = tempdir(), add_session_subdir = TRUE, overwrite = TRUE, diff --git a/R/download_session_csv.R b/R/download_session_csv.R index 90db279e..818b43fd 100644 --- a/R/download_session_csv.R +++ b/R/download_session_csv.R @@ -11,9 +11,10 @@ NULL #' entire volume when `session_id` is `NULL`. The API delivers the final signed #' download link via email once the export is ready. #' -#' @param vol_id Integer. Target volume identifier. Default is 1. +#' @param vol_id Integer. Target volume identifier. Default is 2. #' @param session_id Optional integer. When provided, requests a session-level -#' CSV export. When `NULL`, a volume-level CSV export is requested. +#' CSV export. When `NULL`, a volume-level CSV export is requested. Default is +#' 9. #' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Default is `NULL`, meaning a default #' authenticated request is generated. @@ -27,10 +28,10 @@ NULL #' \donttest{ #' \dontrun{ #' # Request a volume-wide CSV export -#' download_session_csv(vol_id = 1) +#' download_session_csv() # CSV for default volume 2 #' #' # Request a session-specific CSV export -#' download_session_csv(vol_id = 1, session_id = 9807) +#' download_session_csv(vol_id = 2, session_id = 9) #' } #' } #' diff --git a/R/download_session_zip.R b/R/download_session_zip.R index 066b774f..3315c10c 100644 --- a/R/download_session_zip.R +++ b/R/download_session_zip.R @@ -11,8 +11,10 @@ NULL #' summary. Once the archive is ready, Databrary emails a signed download link #' to the authenticated user. #' -#' @param vol_id Volume identifier that owns the session. -#' @param session_id Session identifier within the volume. +#' @param vol_id Volume identifier that owns the session. Must be a positive +#' integer. Default is 31. +#' @param session_id Session identifier within the volume. Must be a positive +#' integer. Default is 9803. #' @param vb Show verbose feedback. Defaults to `options::opt("vb")`. #' @param rq An `httr2` request object. Default is `NULL`, in which case a #' default authenticated request is generated. @@ -42,8 +44,7 @@ download_session_zip <- function(vol_id = 31, assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id >= 1) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) diff --git a/R/download_single_folder_asset_fr_df.R b/R/download_single_folder_asset_fr_df.R index 98fc2e60..29ea5637 100644 --- a/R/download_single_folder_asset_fr_df.R +++ b/R/download_single_folder_asset_fr_df.R @@ -59,21 +59,15 @@ download_single_folder_asset_fr_df <- function(i = NULL, ) assertthat::is.writeable(target_dir) - assertthat::assert_that(length(add_folder_subdir) == 1) - assertthat::assert_that(is.logical(add_folder_subdir)) - - assertthat::assert_that(length(overwrite) == 1) - assertthat::assert_that(is.logical(overwrite)) - - assertthat::assert_that(length(make_portable_fn) == 1) - assertthat::assert_that(is.logical(make_portable_fn)) + validate_flag(add_folder_subdir, "add_folder_subdir") + validate_flag(overwrite, "overwrite") + validate_flag(make_portable_fn, "make_portable_fn") assertthat::is.number(timeout_secs) assertthat::assert_that(length(timeout_secs) == 1) assertthat::assert_that(timeout_secs > 0) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) diff --git a/R/download_single_session_asset_fr_df.R b/R/download_single_session_asset_fr_df.R index d96fc7eb..18d84a30 100644 --- a/R/download_single_session_asset_fr_df.R +++ b/R/download_single_session_asset_fr_df.R @@ -59,11 +59,9 @@ download_single_session_asset_fr_df <- function(i = NULL, ) assertthat::is.writeable(target_dir) - assertthat::assert_that(length(add_session_subdir) == 1) - assertthat::assert_that(is.logical(add_session_subdir)) + validate_flag(add_session_subdir, "add_session_subdir") + validate_flag(overwrite, "overwrite") - assertthat::assert_that(length(overwrite) == 1) - assertthat::assert_that(is.logical(overwrite)) assertthat::assert_that(length(make_portable_fn) == 1) assertthat::assert_that(is.logical(make_portable_fn)) @@ -72,8 +70,7 @@ download_single_session_asset_fr_df <- function(i = NULL, assertthat::assert_that(length(timeout_secs) == 1) assertthat::assert_that(timeout_secs > 0) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) diff --git a/R/download_utils.R b/R/download_utils.R index 74dbc968..76a0449c 100644 --- a/R/download_utils.R +++ b/R/download_utils.R @@ -8,18 +8,18 @@ request_processing_task <- function(path, rq = NULL, vb = FALSE) { vb = vb, normalize = TRUE ) - + if (is.null(task)) { if (vb) { message("Cannot access requested resource on Databrary. Exiting.") } return(NULL) } - + if (vb && !is.null(task$message)) { message(task$message) } - + class(task) <- unique(c("databrary_processing_task", class(task))) task } @@ -32,21 +32,21 @@ request_signed_download_link <- function(path, rq = NULL, vb = FALSE) { vb = vb, normalize = TRUE ) - + if (is.null(link)) { if (vb) { message("Cannot access requested resource on Databrary. Exiting.") } return(NULL) } - + if (is.null(link$download_url)) { if (vb) { message("Download link payload missing 'download_url'.") } return(NULL) } - + link$download_url <- ensure_absolute_url(link$download_url) class(link) <- unique(c("databrary_signed_download", class(link))) link @@ -70,23 +70,27 @@ download_signed_file <- function(download_url, assertthat::assert_that(assertthat::is.string(dest_path)) assertthat::is.number(timeout_secs) assertthat::assert_that(timeout_secs > 0) - assertthat::assert_that(length(timeout_secs == 1)) - + parent_dir <- dirname(dest_path) if (!dir.exists(parent_dir)) { dir.create(parent_dir, recursive = TRUE, showWarnings = FALSE) } assertthat::is.writeable(parent_dir) - + + token <- require_access_token() + req <- httr2::request(download_url) |> + httr2::req_user_agent(USER_AGENT) |> + httr2::req_headers(Authorization = paste("Bearer", token)) |> httr2::req_timeout(seconds = timeout_secs) - + + if (vb) { + message("Saving download to '", dest_path, "'.") + } + tryCatch( { httr2::req_perform(req, path = dest_path) - if (vb) { - message("Saving download to '", dest_path, "'.") - } dest_path }, httr2_error = function(cnd) { @@ -97,5 +101,3 @@ download_signed_file <- function(download_url, } ) } - - diff --git a/R/download_video.R b/R/download_video.R index 471f376e..575fdf04 100644 --- a/R/download_video.R +++ b/R/download_video.R @@ -65,8 +65,7 @@ download_video <- function(vol_id = 1, ) assertthat::is.writeable(target_dir) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) diff --git a/R/download_volume_zip.R b/R/download_volume_zip.R index 89177938..30c350ac 100644 --- a/R/download_volume_zip.R +++ b/R/download_volume_zip.R @@ -36,8 +36,7 @@ download_volume_zip <- function(vol_id = 31, assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || ("httr2_request" %in% class(rq))) diff --git a/R/get_category_by_id.R b/R/get_category_by_id.R index e9b02665..ebda2afb 100644 --- a/R/get_category_by_id.R +++ b/R/get_category_by_id.R @@ -32,17 +32,13 @@ NULL get_category_by_id <- function(category_id = 1, vb = options::opt("vb"), rq = NULL) { - # Validate category_id assertthat::assert_that(is.numeric(category_id)) assertthat::assert_that(length(category_id) == 1) assertthat::assert_that(category_id > 0) assertthat::assert_that(category_id == floor(category_id), msg = "category_id must be an integer") - # Validate vb - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") - # Validate rq assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/get_db_stats.R b/R/get_db_stats.R index 979c21ef..f84d9f1f 100644 --- a/R/get_db_stats.R +++ b/R/get_db_stats.R @@ -56,21 +56,13 @@ get_db_stats <- function(type = "stats", vb = options::opt("vb"), rq = NULL) { message("Legacy parameter not supported in new API") } - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that( is.null(rq) | ("httr2_request" %in% class(rq)) ) - # if (is.null(rq)) { - # if (vb) { - # message("\nNULL request object. Will generate default.") - # message("Not logged in. Only public information will be returned.") - # } - # rq <- databraryr::make_default_request() - # } stats <- perform_api_get( path = API_ACTIVITY_SUMMARY, rq = rq, diff --git a/R/get_folder_by_id.R b/R/get_folder_by_id.R index 480d12c1..b68a2a9b 100644 --- a/R/get_folder_by_id.R +++ b/R/get_folder_by_id.R @@ -35,8 +35,7 @@ get_folder_by_id <- function(folder_id = 9807, assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/get_folder_file.R b/R/get_folder_file.R index 099d9d3a..ba8b272e 100644 --- a/R/get_folder_file.R +++ b/R/get_folder_file.R @@ -49,8 +49,7 @@ get_folder_file <- assertthat::assert_that(file_id > 0) assertthat::assert_that(length(file_id) == 1) - assertthat::assert_that(is.logical(vb)) - assertthat::assert_that(length(vb) == 1) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/get_funder_by_id.R b/R/get_funder_by_id.R index 1d46b3f1..138e6194 100644 --- a/R/get_funder_by_id.R +++ b/R/get_funder_by_id.R @@ -31,17 +31,13 @@ NULL get_funder_by_id <- function(funder_id = 1, vb = options::opt("vb"), rq = NULL) { - # Validate funder_id assertthat::assert_that(is.numeric(funder_id)) assertthat::assert_that(length(funder_id) == 1) assertthat::assert_that(funder_id > 0) assertthat::assert_that(funder_id == floor(funder_id), msg = "funder_id must be an integer") - # Validate vb - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) - - # Validate rq + validate_flag(vb, "vb") + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/get_institution_avatar.R b/R/get_institution_avatar.R index 3df9ba2f..a94b7361 100644 --- a/R/get_institution_avatar.R +++ b/R/get_institution_avatar.R @@ -52,22 +52,17 @@ get_institution_avatar <- function(institution_id = 1, dest_path = NULL, vb = options::opt("vb"), rq = NULL) { - # Validate institution_id assertthat::assert_that(is.numeric(institution_id)) assertthat::assert_that(length(institution_id) == 1) assertthat::assert_that(institution_id > 0) assertthat::assert_that(institution_id == floor(institution_id), msg = "institution_id must be an integer") - # Validate dest_path if (!is.null(dest_path)) { assertthat::assert_that(assertthat::is.string(dest_path)) } - # Validate vb - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") - # Validate rq assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/get_institution_by_id.R b/R/get_institution_by_id.R index 49c69653..cfe60e8d 100644 --- a/R/get_institution_by_id.R +++ b/R/get_institution_by_id.R @@ -15,6 +15,9 @@ get_institution_by_id <- function(institution_id = 12, vb = options::opt("vb"), rq = NULL) { assertthat::assert_that(is.numeric(institution_id), length(institution_id) == 1, institution_id > 0) + + validate_flag(vb, "vb") + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) institution <- perform_api_get( diff --git a/R/get_session_by_id.R b/R/get_session_by_id.R index b6f636d7..e7d7d1cb 100644 --- a/R/get_session_by_id.R +++ b/R/get_session_by_id.R @@ -38,8 +38,7 @@ get_session_by_id <- assertthat::assert_that(vol_id > 0) assertthat::assert_that(length(vol_id) == 1) - assertthat::assert_that(is.logical(vb)) - assertthat::assert_that(length(vb) == 1) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/get_session_by_name.R b/R/get_session_by_name.R index 80f97a2e..6a348a3e 100644 --- a/R/get_session_by_name.R +++ b/R/get_session_by_name.R @@ -39,8 +39,7 @@ get_session_by_name <- assertthat::assert_that(vol_id > 0) assertthat::assert_that(length(vol_id) == 1) - assertthat::assert_that(is.logical(vb)) - assertthat::assert_that(length(vb) == 1) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/get_session_file.R b/R/get_session_file.R index 35d7cd5e..cb4fc389 100644 --- a/R/get_session_file.R +++ b/R/get_session_file.R @@ -43,8 +43,7 @@ get_session_file <- assertthat::assert_that(file_id > 0) assertthat::assert_that(length(file_id) == 1) - assertthat::assert_that(is.logical(vb)) - assertthat::assert_that(length(vb) == 1) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/get_tag_by_id.R b/R/get_tag_by_id.R index 92fd8afa..4044c698 100644 --- a/R/get_tag_by_id.R +++ b/R/get_tag_by_id.R @@ -31,17 +31,13 @@ NULL get_tag_by_id <- function(tag_id = 1, vb = options::opt("vb"), rq = NULL) { - # Validate tag_id assertthat::assert_that(is.numeric(tag_id)) assertthat::assert_that(length(tag_id) == 1) assertthat::assert_that(tag_id > 0) assertthat::assert_that(tag_id == floor(tag_id), msg = "tag_id must be an integer") - # Validate vb - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") - # Validate rq assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/get_user_avatar.R b/R/get_user_avatar.R index eaa84f98..e7f555d9 100644 --- a/R/get_user_avatar.R +++ b/R/get_user_avatar.R @@ -44,22 +44,17 @@ get_user_avatar <- function(user_id, dest_path = NULL, vb = options::opt("vb"), rq = NULL) { - # Validate user_id assertthat::assert_that(length(user_id) == 1) assertthat::assert_that(is.numeric(user_id) || is.integer(user_id)) assertthat::assert_that(user_id > 0) - # Validate dest_path if (!is.null(dest_path)) { assertthat::assert_that(assertthat::is.string(dest_path)) } - # Validate vb - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") - # Validate rq assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/get_user_by_id.R b/R/get_user_by_id.R index f5455c9e..d200c133 100644 --- a/R/get_user_by_id.R +++ b/R/get_user_by_id.R @@ -15,6 +15,9 @@ get_user_by_id <- function(user_id = 6, vb = options::opt("vb"), rq = NULL) { assertthat::assert_that(is.numeric(user_id), length(user_id) == 1, user_id > 0) + + validate_flag(vb, "vb") + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/get_volume_by_id.R b/R/get_volume_by_id.R index 94b11352..78196edf 100644 --- a/R/get_volume_by_id.R +++ b/R/get_volume_by_id.R @@ -28,8 +28,7 @@ get_volume_by_id <- function(vol_id = 1, assertthat::assert_that(vol_id > 0) assertthat::assert_that(length(vol_id) == 1) - assertthat::assert_that(is.logical(vb)) - assertthat::assert_that(length(vb) == 1) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) diff --git a/R/get_volume_collaborator_by_id.R b/R/get_volume_collaborator_by_id.R index 64a95bff..452b26db 100644 --- a/R/get_volume_collaborator_by_id.R +++ b/R/get_volume_collaborator_by_id.R @@ -38,23 +38,18 @@ get_volume_collaborator_by_id <- function(vol_id = 1, collaborator_id = 1, vb = options::opt("vb"), rq = NULL) { - # Validate vol_id assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(vol_id >= 1) assertthat::assert_that(vol_id == floor(vol_id), msg = "vol_id must be an integer") - # Validate collaborator_id assertthat::assert_that(is.numeric(collaborator_id)) assertthat::assert_that(length(collaborator_id) == 1) assertthat::assert_that(collaborator_id > 0) assertthat::assert_that(collaborator_id == floor(collaborator_id), msg = "collaborator_id must be an integer") - # Validate vb - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) - - # Validate rq + validate_flag(vb, "vb") + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/get_volume_record_by_id.R b/R/get_volume_record_by_id.R index aadf2447..18cf7c24 100644 --- a/R/get_volume_record_by_id.R +++ b/R/get_volume_record_by_id.R @@ -36,9 +36,7 @@ get_volume_record_by_id <- function( vol_id = 1, record_id = 1, vb = options::opt("vb"), - rq = NULL -) { - # Validate vol_id + rq = NULL) { assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(vol_id >= 1) @@ -47,7 +45,6 @@ get_volume_record_by_id <- function( msg = "vol_id must be an integer" ) - # Validate record_id assertthat::assert_that(is.numeric(record_id)) assertthat::assert_that(length(record_id) == 1) assertthat::assert_that(record_id > 0) @@ -56,11 +53,8 @@ get_volume_record_by_id <- function( msg = "record_id must be an integer" ) - # Validate vb - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") - # Validate rq assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) # Perform API call diff --git a/R/list_asset_formats.R b/R/list_asset_formats.R index 6c2ec3db..ce2fda06 100644 --- a/R/list_asset_formats.R +++ b/R/list_asset_formats.R @@ -21,8 +21,7 @@ NULL #' @export list_asset_formats <- function(vb = options::opt("vb")) { # Check parameters - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") db_constants <- databraryr::assign_constants() diff --git a/R/list_authorized_investigators.R b/R/list_authorized_investigators.R index 85d96982..3992ded3 100644 --- a/R/list_authorized_investigators.R +++ b/R/list_authorized_investigators.R @@ -21,7 +21,7 @@ list_authorized_investigators <- function(institution_id = 12, assertthat::assert_that(is.numeric(institution_id), length(institution_id) == 1, institution_id > 0) - assertthat::assert_that(is.logical(vb), length(vb) == 1) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/list_categories.R b/R/list_categories.R index 603a95a1..b0c67f51 100644 --- a/R/list_categories.R +++ b/R/list_categories.R @@ -29,11 +29,8 @@ NULL #' } #' @export list_categories <- function(vb = options::opt("vb"), rq = NULL) { - # Validate vb - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) - - # Validate rq + validate_flag(vb, "vb") + assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/list_folder_assets.R b/R/list_folder_assets.R index 95d0ebe5..e37c643f 100644 --- a/R/list_folder_assets.R +++ b/R/list_folder_assets.R @@ -43,8 +43,7 @@ list_folder_assets <- function(folder_id = 9807, assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/list_institution_affiliates.R b/R/list_institution_affiliates.R index a05508b6..ff8afe19 100644 --- a/R/list_institution_affiliates.R +++ b/R/list_institution_affiliates.R @@ -20,8 +20,7 @@ list_institution_affiliates <- function(institution_id = 12, length(institution_id) == 1, institution_id > 0) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/list_institutions.R b/R/list_institutions.R index e6854a46..7eab34c5 100644 --- a/R/list_institutions.R +++ b/R/list_institutions.R @@ -37,16 +37,12 @@ NULL list_institutions <- function(search_string = NULL, vb = options::opt("vb"), rq = NULL) { - # Validate search_string if (!is.null(search_string)) { assertthat::assert_that(assertthat::is.string(search_string)) } - # Validate vb - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") - # Validate rq assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/list_session_activity.R b/R/list_session_activity.R index 2e761f9f..f1a9cf12 100644 --- a/R/list_session_activity.R +++ b/R/list_session_activity.R @@ -42,7 +42,7 @@ list_session_activity <- assertthat::assert_that(session_id > 0) assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/list_session_assets.R b/R/list_session_assets.R index af1b4c52..1a5d0c71 100644 --- a/R/list_session_assets.R +++ b/R/list_session_assets.R @@ -47,6 +47,8 @@ list_session_assets <- function(session_id = 9807, assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) + validate_flag(vb, "vb") + assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) diff --git a/R/list_user_affiliates.R b/R/list_user_affiliates.R index 4550aded..f8c84af9 100644 --- a/R/list_user_affiliates.R +++ b/R/list_user_affiliates.R @@ -19,8 +19,7 @@ list_user_affiliates <- function(user_id = 6, assertthat::assert_that(is.numeric(user_id), length(user_id) == 1, user_id > 0) assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/list_user_history.R b/R/list_user_history.R index c1f8721e..a132ff55 100644 --- a/R/list_user_history.R +++ b/R/list_user_history.R @@ -32,8 +32,7 @@ list_user_history <- function(user_id = 22582, assertthat::assert_that(length(user_id) == 1) assertthat::assert_that(user_id > 0) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/list_user_sponsors.R b/R/list_user_sponsors.R index fae5445e..012232a9 100644 --- a/R/list_user_sponsors.R +++ b/R/list_user_sponsors.R @@ -17,8 +17,7 @@ list_user_sponsors <- function(user_id = 6, assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/list_user_volumes.R b/R/list_user_volumes.R index ccf2df9a..33124e87 100644 --- a/R/list_user_volumes.R +++ b/R/list_user_volumes.R @@ -17,6 +17,7 @@ list_user_volumes <- function(user_id = 6, vb = options::opt("vb"), rq = NULL) { assertthat::assert_that(is.numeric(user_id), length(user_id) == 1, user_id > 0) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) volumes <- collect_paginated_get( diff --git a/R/list_users.R b/R/list_users.R index 1a35ab9a..86fbf48a 100644 --- a/R/list_users.R +++ b/R/list_users.R @@ -45,13 +45,6 @@ list_users <- function(search = NULL, assertthat::assert_that(assertthat::is.string(search)) } - validate_flag <- function(value, name) { - if (!is.null(value)) { - assertthat::assert_that(length(value) == 1) - assertthat::assert_that(is.logical(value), msg = paste0(name, " must be logical.")) - } - } - validate_flag(include_suspended, "include_suspended") validate_flag(exclude_self, "exclude_self") validate_flag(is_authorized_investigator, "is_authorized_investigator") diff --git a/R/list_volume_activity.R b/R/list_volume_activity.R index 1dda6da7..04a896ac 100644 --- a/R/list_volume_activity.R +++ b/R/list_volume_activity.R @@ -35,8 +35,9 @@ list_volume_activity <- assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id > 0) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") + + validate_flag(vb, "vb") if (vb) message('list_volume_activity()...') diff --git a/R/list_volume_assets.R b/R/list_volume_assets.R index fcb7ec04..68a92e0b 100644 --- a/R/list_volume_assets.R +++ b/R/list_volume_assets.R @@ -28,18 +28,7 @@ list_volume_assets <- function(vol_id = 1, assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) - - # Not needed for DB2 API. Delete - # Handle NULL rq - # if (is.null(rq)) { - # if (vb) { - # message("NULL request object. Will generate default.") - # message("Not logged in. Only public information will be returned.") - # } - # rq <- databraryr::make_default_request() - # } + validate_flag(vb, "vb") sessions <- collect_paginated_get( path = sprintf(API_VOLUME_SESSIONS, vol_id), diff --git a/R/list_volume_collaborators.R b/R/list_volume_collaborators.R index 6ec9297a..451c6e38 100644 --- a/R/list_volume_collaborators.R +++ b/R/list_volume_collaborators.R @@ -31,8 +31,7 @@ list_volume_collaborators <- function(vol_id = 1, assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id > 0) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/list_volume_folders.R b/R/list_volume_folders.R index 52a66ca3..00d3f184 100644 --- a/R/list_volume_folders.R +++ b/R/list_volume_folders.R @@ -28,8 +28,7 @@ list_volume_folders <- function(vol_id = 1, assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/list_volume_funding.R b/R/list_volume_funding.R index e28b00ac..4155ff41 100644 --- a/R/list_volume_funding.R +++ b/R/list_volume_funding.R @@ -36,21 +36,11 @@ list_volume_funding <- function(vol_id = 1, assertthat::assert_that(length(add_id) == 1) assertthat::assert_that(is.logical(add_id)) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) - - # Not needed for new API. Delete - # if (is.null(rq)) { - # if (vb) { - # message("NULL request object. Will generate default.") - # message("Not logged in. Only public information will be returned.") - # } - # rq <- databraryr::make_default_request() - # } - + if (vb) message("Summarizing funding for n=", length(vol_id), " volumes.") diff --git a/R/list_volume_info.R b/R/list_volume_info.R index 3f24b0a2..8db32a45 100644 --- a/R/list_volume_info.R +++ b/R/list_volume_info.R @@ -32,8 +32,7 @@ list_volume_info <- assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) diff --git a/R/list_volume_links.R b/R/list_volume_links.R index 07e5b715..d243b44b 100644 --- a/R/list_volume_links.R +++ b/R/list_volume_links.R @@ -28,8 +28,7 @@ list_volume_links <- function(vol_id = 1, assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id > 0) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") links <- perform_api_get( path = sprintf(API_VOLUME_LINKS, vol_id), diff --git a/R/list_volume_records.R b/R/list_volume_records.R index b99fd210..27f7ce31 100644 --- a/R/list_volume_records.R +++ b/R/list_volume_records.R @@ -39,13 +39,11 @@ list_volume_records <- function(vol_id = 1, category_id = NULL, vb = options::opt("vb"), rq = NULL) { - # Validate vol_id assertthat::assert_that(length(vol_id) == 1) assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id >= 1) assertthat::assert_that(vol_id == floor(vol_id), msg = "vol_id must be an integer") - # Validate category_id if (!is.null(category_id)) { assertthat::assert_that(length(category_id) == 1) assertthat::assert_that(is.numeric(category_id)) @@ -53,11 +51,8 @@ list_volume_records <- function(vol_id = 1, assertthat::assert_that(category_id == floor(category_id), msg = "category_id must be an integer") } - # Validate vb - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") - # Validate rq assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/list_volume_session_assets.R b/R/list_volume_session_assets.R index c43bc052..7ade992b 100644 --- a/R/list_volume_session_assets.R +++ b/R/list_volume_session_assets.R @@ -42,20 +42,11 @@ list_volume_session_assets <- assertthat::assert_that(is.numeric(session_id)) assertthat::assert_that(session_id >= 1) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) - # Not needed in DB2 API. Delete. - # if (is.null(rq)) { - # if (vb) { - # message("NULL request object. Will generate default.") - # } - # rq <- databraryr::make_default_request() - # } - session <- perform_api_get( path = sprintf(API_SESSION_DETAIL, vol_id, session_id), rq = rq, diff --git a/R/list_volume_sessions.R b/R/list_volume_sessions.R index 1bc05527..3c132991 100644 --- a/R/list_volume_sessions.R +++ b/R/list_volume_sessions.R @@ -37,8 +37,7 @@ list_volume_sessions <- assertthat::assert_that(is.logical(include_vol_data)) assertthat::assert_that(length(include_vol_data) == 1) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) diff --git a/R/list_volume_tags.R b/R/list_volume_tags.R index ff5fe658..a1a325fd 100644 --- a/R/list_volume_tags.R +++ b/R/list_volume_tags.R @@ -26,8 +26,7 @@ list_volume_tags <- function(vol_id = 1, assertthat::assert_that(is.numeric(vol_id)) assertthat::assert_that(vol_id > 0) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) diff --git a/R/list_volumes.R b/R/list_volumes.R index 9f8be9a2..11d23b60 100644 --- a/R/list_volumes.R +++ b/R/list_volumes.R @@ -38,8 +38,7 @@ list_volumes <- function(search = NULL, assertthat::assert_that(assertthat::is.string(ordering)) } - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/login_db.R b/R/login_db.R index 876cbf81..71b33ce4 100644 --- a/R/login_db.R +++ b/R/login_db.R @@ -36,8 +36,8 @@ login_db <- function(email = NULL, SERVICE = KEYRING_SERVICE, vb = options::opt("vb")) { assertthat::assert_that(length(store) == 1, is.logical(store)) - assertthat::assert_that(length(overwrite) == 1, is.logical(overwrite)) - assertthat::assert_that(length(vb) == 1, is.logical(vb)) + validate_flag(overwrite, "overwrite") + validate_flag(vb, "vb") assertthat::assert_that(length(SERVICE) == 1, is.character(SERVICE)) # If the user wants to store or use their stored credentials, diff --git a/R/logout_db.R b/R/logout_db.R index 325f8234..cd0d42e5 100644 --- a/R/logout_db.R +++ b/R/logout_db.R @@ -17,7 +17,7 @@ NULL #' } #' @export logout_db <- function(vb = options::opt("vb")) { - assertthat::assert_that(is.logical(vb), length(vb) == 1) + validate_flag(vb, "vb") bundle <- get_token_bundle() if (is.null(bundle)) { diff --git a/R/make_default_request.R b/R/make_default_request.R index 8ba8d226..428d061a 100644 --- a/R/make_default_request.R +++ b/R/make_default_request.R @@ -18,9 +18,10 @@ make_default_request <- function(with_token = TRUE, refresh = TRUE, vb = options::opt("vb")) { - assertthat::assert_that(is.logical(with_token), length(with_token) == 1) - assertthat::assert_that(is.logical(refresh), length(refresh) == 1) - assertthat::assert_that(is.logical(vb), length(vb) == 1) + + validate_flag(with_token, "with_token") + validate_flag(refresh, "refresh") + validate_flag(vb, "vb") req <- httr2::request(DATABRARY_BASE_URL) |> httr2::req_user_agent(USER_AGENT) |> diff --git a/R/make_login_client.R b/R/make_login_client.R index 1fd97438..6dfc20d4 100644 --- a/R/make_login_client.R +++ b/R/make_login_client.R @@ -41,11 +41,9 @@ make_login_client <- function(email = NULL, assertthat::assert_that(length(store) == 1) assertthat::assert_that(is.logical(store)) - assertthat::assert_that(length(overwrite) == 1) - assertthat::assert_that(is.logical(overwrite)) - - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(store, "store") + validate_flag(overwrite, "overwrite") + validate_flag(vb, "vb") assertthat::assert_that(length(SERVICE) == 1) assertthat::assert_that(is.character(SERVICE)) diff --git a/R/search_for_funder.R b/R/search_for_funder.R index 06f2cd54..622a76da 100644 --- a/R/search_for_funder.R +++ b/R/search_for_funder.R @@ -31,9 +31,8 @@ search_for_funder <- search_string <- gsub("[+]", " ", search_string) pattern <- stringr::str_trim(search_string) - assertthat::assert_that(is.logical(approved_only), length(approved_only) == 1) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(approved_only, "approved_only") + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) diff --git a/R/search_for_tags.R b/R/search_for_tags.R index b0e72b69..f08705e3 100644 --- a/R/search_for_tags.R +++ b/R/search_for_tags.R @@ -27,8 +27,7 @@ search_for_tags <- assertthat::assert_that(length(search_string) == 1) assertthat::assert_that(is.character(search_string)) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) | ("httr2_request" %in% class(rq))) diff --git a/R/search_institutions.R b/R/search_institutions.R index f5436449..8bb9abee 100644 --- a/R/search_institutions.R +++ b/R/search_institutions.R @@ -29,8 +29,7 @@ search_institutions <- function(search_string, vb = options::opt("vb"), rq = NULL) { assertthat::assert_that(assertthat::is.string(search_string)) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) diff --git a/R/search_users.R b/R/search_users.R index 3a5e40d3..79b228eb 100644 --- a/R/search_users.R +++ b/R/search_users.R @@ -28,8 +28,7 @@ search_users <- function(search_string, vb = options::opt("vb"), rq = NULL) { assertthat::assert_that(assertthat::is.string(search_string)) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) results <- collect_paginated_get( diff --git a/R/search_volumes.R b/R/search_volumes.R index 15a66d2f..1c1d67fb 100644 --- a/R/search_volumes.R +++ b/R/search_volumes.R @@ -28,8 +28,7 @@ search_volumes <- function(search_string, vb = options::opt("vb"), rq = NULL) { assertthat::assert_that(assertthat::is.string(search_string)) - assertthat::assert_that(length(vb) == 1) - assertthat::assert_that(is.logical(vb)) + validate_flag(vb, "vb") assertthat::assert_that(is.null(rq) || inherits(rq, "httr2_request")) results <- collect_paginated_get( diff --git a/R/utils.R b/R/utils.R index e1e1059f..c2723162 100644 --- a/R/utils.R +++ b/R/utils.R @@ -8,7 +8,7 @@ #' NULL - + #---------------------------------------------------------------------------- #' Extract Databrary Permission Levels. #' @@ -23,10 +23,11 @@ NULL #' #' @export get_permission_levels <- function(vb = options::opt("vb")) { + validate_flag(vb, "vb") enums <- get_permission_levels_enums() enums$volume_access_levels } - + #---------------------------------------------------------------------------- #' Convert Timestamp String To ms. #' @@ -43,11 +44,10 @@ HHMMSSmmm_to_ms <- function(HHMMSSmmm = "01:01:01:333") { stop("HHMMSSmmm must be a string.") } - if (stringr::str_detect(HHMMSSmmm, - "([0-9]{2}):([0-9]{2}):([0-9]{2}):([0-9]{3})")) { + if (stringr::str_detect(HHMMSSmmm, "([0-9]{2}):([0-9]{2}):([0-9]{2}):([0-9]{3})")) { time_segs <- stringr::str_match(HHMMSSmmm, "([0-9]{2}):([0-9]{2}):([0-9]{2}):([0-9]{3})") - as.numeric(time_segs[5]) + as.numeric(time_segs[4]) * + as.numeric(time_segs[5]) + as.numeric(time_segs[4]) * 1000 + as.numeric(time_segs[3]) * 1000 * 60 + as.numeric(time_segs[2]) * 1000 * 60 * 60 } else { @@ -69,8 +69,10 @@ HHMMSSmmm_to_ms <- function(HHMMSSmmm = "01:01:01:333") { #' #' @export get_release_levels <- function(vb = options::opt("vb")) { -enums <- get_release_levels_enums() -vapply(enums$levels, function(item) item$code, character(1)) + validate_flag(vb, "vb") + enums <- get_release_levels_enums() + vapply(enums$levels, function(item) + item$code, character(1)) } #---------------------------------------------------------------------------- @@ -88,13 +90,14 @@ vapply(enums$levels, function(item) item$code, character(1)) #' #' @export get_supported_file_types <- function(vb = options::opt("vb")) { -constants <- assign_constants(vb = vb) -constants$format_df |> - dplyr::rename( - asset_type = name, - asset_type_id = id, - asset_category = category - ) + validate_flag(vb, "vb") + constants <- assign_constants(vb = vb) + constants$format_df |> + dplyr::rename( + asset_type = name, + asset_type_id = id, + asset_category = category + ) } #---------------------------------------------------------------------------- @@ -103,7 +106,7 @@ constants$format_df |> #' @param fn Databrary party ID #' @param replace_regex A character string. A regular expression to capture #' the "non-portable" characters in fn. -#' @param replacement_char A character string. The character(s) that will +#' @param replacement_char A character string. The character(s) that will #' replace the non-portable characters. #' #' @returns A "cleaned" portable file name @@ -111,16 +114,15 @@ constants$format_df |> #' @inheritParams options_params #' make_fn_portable <- function(fn, - vb = options::opt("vb"), - replace_regex = "[ &\\!\\)\\(\\}\\{\\[\\]\\+\\=@#\\$%\\^\\*]", - replacement_char = "_") { + vb = options::opt("vb"), + replace_regex = "[ &\\!\\)\\(\\}\\{\\[\\]\\+\\=@#\\$%\\^\\*]", + replacement_char = "_") { assertthat::is.string(fn) assertthat::assert_that(!is.numeric(fn)) assertthat::assert_that(!is.logical(fn)) assertthat::assert_that(length(fn) == 1) - assertthat::assert_that(is.logical(vb)) - assertthat::assert_that(length(vb) == 1) + validate_flag(vb, "vb") assertthat::is.string(replace_regex) assertthat::assert_that(length(replace_regex) == 1) @@ -135,4 +137,3 @@ make_fn_portable <- function(fn, new_fn <- stringr::str_replace_all(fn, replace_regex, replacement_char) new_fn } - \ No newline at end of file diff --git a/R/whoami.R b/R/whoami.R index b8227887..7647f3e4 100644 --- a/R/whoami.R +++ b/R/whoami.R @@ -21,8 +21,8 @@ #' @export whoami <- function(refresh = TRUE, vb = options::opt("vb")) { - assertthat::assert_that(is.logical(refresh), length(refresh) == 1) - assertthat::assert_that(is.logical(vb), length(vb) == 1) + validate_flag(refresh, "refresh") + validate_flag(vb, "vb") req <- tryCatch( make_default_request(refresh = refresh, vb = vb), From 5a61dc44370d78a34b2f79d31a0a81488c3ad79f Mon Sep 17 00:00:00 2001 From: rogilmore Date: Fri, 6 Feb 2026 12:02:17 -0500 Subject: [PATCH 26/27] Bump version; add Pawel as author; add NSF HNDS-I grant to DESCRIPTION. --- DESCRIPTION | 2 +- NEWS.md | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8b651a97..3645964e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: databraryr Title: Interact with the 'Databrary.org' API -Version: 0.6.6.9002 +Version: 1.0.0.9000 Authors@R: c( person("Rick", "O. Gilmore", , "rog1@psu.edu", role = c("aut", "cre", "cph")), person("Jeffrey", "Spies", , "cran@jeffspies.com", role = "aut"), diff --git a/NEWS.md b/NEWS.md index bfc017d1..0d3bc7d5 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,8 @@ -# databraryr (development version) +# databraryr 1.0.0 + +## Major changes + +- Adapted all package functions to Databrary 2.0 API. # databraryr 0.6.6 From fc6ac6c5e3b680737cb549a5ec3ae05d91fdb5c7 Mon Sep 17 00:00:00 2001 From: rogilmore Date: Fri, 6 Feb 2026 13:30:21 -0500 Subject: [PATCH 27/27] Fix typo in DESCRIPTION. --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3645964e..d68b1a78 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -5,7 +5,7 @@ Version: 1.0.0.9000 Authors@R: c( person("Rick", "O. Gilmore", , "rog1@psu.edu", role = c("aut", "cre", "cph")), person("Jeffrey", "Spies", , "cran@jeffspies.com", role = "aut"), - person("Pawel", "Armatys", "pawel.armatys@montrosesoftware.com", role="aut") + person("Pawel", "Armatys", "pawel.armatys@montrosesoftware.com", role="aut"), person("National Science Foundation OAC-2032713", role = "fnd"), person("National Institutes of Health R01HD094830", role = "fnd"), person("National Science Foundation BCS 2444730, 2444731", role="fnd")