From b4e3e3dacad97ce7b69a2fdc46de516371cad0bd Mon Sep 17 00:00:00 2001 From: Michal Huryn Date: Mon, 8 Dec 2025 13:57:37 +0100 Subject: [PATCH 01/16] 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 c42b7c1..239ac0f 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 02/16] 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 765a14b..d96b6c2 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 f6d676b..6f07bd5 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 0000000..01c688e --- /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 0000000..70c66bd --- /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 0000000..95fe7cd --- /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 03/16] 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 d96b6c2..c522432 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 6f07bd5..6f32d68 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 0000000..6f30314 --- /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 0000000..4c0d0e3 --- /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 0000000..4008c66 --- /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 04/16] 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 c522432..4cff29c 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 6f32d68..bea05d8 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 0000000..1b13769 --- /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 0000000..a5c08ed --- /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 0000000..2b29034 --- /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 05/16] 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 4cff29c..bbefb66 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 bea05d8..9837f77 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 0000000..338a8b8 --- /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 0000000..1bce307 --- /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 0000000..a88170a --- /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 06/16] 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 bbefb66..1b98e87 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 9837f77..a6bb8a3 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 0000000..c67ffdf --- /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 0000000..c195131 --- /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 0000000..79f07aa --- /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 07/16] 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 1b98e87..b420615 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 a6bb8a3..5025634 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 0000000..5638cef --- /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 0000000..9ed51ad --- /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 0000000..d402a59 --- /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 08/16] 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 b420615..84852ff 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 5025634..7afef60 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 0000000..8137eea --- /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 0000000..a79fd42 --- /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 0000000..7875319 --- /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 09/16] 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 84852ff..cacbeef 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 0000000..2ce3535 --- /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 0000000..b3f3ada --- /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 0000000..f04e468 --- /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 10/16] 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 cacbeef..49f2bda 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 7afef60..97199e5 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 0000000..13d1392 --- /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 0000000..e6a7e15 --- /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 0000000..e0c14a6 --- /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 11/16] 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 49f2bda..1d62eff 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 0000000..ae174b4 --- /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 0000000..2b1b0f1 --- /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 0000000..08fe7fe --- /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 12/16] 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 1d62eff..f27b9b0 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 0000000..895ce27 --- /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 0000000..041298a --- /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 0000000..dd6e300 --- /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 13/16] 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 f27b9b0..270686d 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 f605de0..e1e1059 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 2f85028..0000000 --- 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 d0da8d1..6286b45 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 14/16] =?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 270686d..a406a9d 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 97199e5..ec0a15e 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 0000000..997ca29 --- /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 0000000..6154145 --- /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 0000000..21e88c0 --- /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 15/16] 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 1b13769..2119cf0 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 239ac0f..35809ae 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 997ca29..57bc7e3 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 01c688e..b13c765 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 2ce3535..836dcc6 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 895ce27..404d3ff 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 6f30314..529ea00 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 ae174b4..c9fa961 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 8137eea..6819184 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 5638cef..ea26348 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 338a8b8..dcc2c9d 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 13d1392..f86d3b5 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 c67ffdf..69b61ad 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 16/16] 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 57bc7e3..1499968 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 6154145..4188985 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) } } }