# --- Helpers --------------------------------------------------------------- # Build a fake pb_releases() return value fake_releases <- function(tags = "v0.1.0") { if (length(tags) == 0) { return(data.frame( tag_name = character(0), name = character(0), draft = logical(0), prerelease = logical(0), stringsAsFactors = FALSE )) } data.frame( tag_name = tags, name = tags, draft = FALSE, prerelease = FALSE, stringsAsFactors = FALSE ) } # Helper: empty releases (0-row data frame) empty_releases <- function() fake_releases(character(0)) # Build a fake pb_list() return value. # Uses "tag" (not "tag_name") to match real piggyback output. fake_asset_list <- function( files = c("study_a.zip", "study_a_metadata.json"), tags = "v0.1.0", sizes = rep(4 * 1024 * 1024, length(files)) ) { data.frame( file_name = files, size = sizes, tag = rep(tags, length.out = length(files)), stringsAsFactors = FALSE ) } # Create a temporary directory with a metadata.json inside make_fake_cache_with_meta <- function(source_name = "my_study") { fake_cache <- file.path(tempdir(), paste0("ctd_cache_", sample.int(1e5, 1))) study_dir <- file.path(fake_cache, source_name) dir.create(study_dir, recursive = TRUE) meta <- list( source = source_name, description = "A test study", domains = list(adam = list("adsl", "adae")), n_subjects = 100, version = "v0.1.0", license = "Test license", source_url = "https://example.com" ) jsonlite::write_json(meta, file.path(study_dir, "metadata.json"), auto_unbox = TRUE, pretty = TRUE) fake_cache } # Create a valid zip file whose contents extract to a named directory make_fake_zip <- function(dest_dir, source_name = "my_study") { study_path <- file.path(dest_dir, source_name) adam_path <- file.path(study_path, "adam") dir.create(adam_path, recursive = TRUE) writeLines("{}", file.path(study_path, "metadata.json")) writeLines("placeholder", file.path(adam_path, "adsl.parquet")) zip_path <- file.path(dest_dir, paste0(source_name, ".zip")) # Build zip from inside dest_dir so the zip root is the study folder old_wd <- setwd(dest_dir) on.exit(setwd(old_wd), add = TRUE) utils::zip(zip_path, files = source_name, flags = "-rq") # Remove the unzipped source so we can verify extraction later unlink(study_path, recursive = TRUE) zip_path } # --- %||% operator -------------------------------------------------------- test_that("%||% returns x when non-NULL", { expect_equal(1 %||% 2, 1) expect_equal("a" %||% "b", "a") }) test_that("%||% returns y when x is NULL", { expect_equal(NULL %||% 42, 42) expect_equal(NULL %||% "fallback", "fallback") }) # --- has_package ---------------------------------------------------------- test_that("has_package returns TRUE for an installed package", { expect_true(has_package("testthat")) }) test_that("has_package returns FALSE for a non-existent package", { expect_false(has_package("packageThatSurelyDoesNotExist999")) }) # --- cache_dir ------------------------------------------------------------ test_that("cache_dir returns a character string", { cd <- cache_dir() expect_type(cd, "character") expect_length(cd, 1) }) # --- .print_dataset_info -------------------------------------------------- test_that(".print_dataset_info includes source name and version", { meta <- list(source = "test_study", version = "v1.2.3") expect_message(.print_dataset_info(meta), "test_study") expect_message(.print_dataset_info(meta), "v1.2.3") }) test_that(".print_dataset_info handles missing version", { meta <- list(source = "test_study") msg <- capture_messages(.print_dataset_info(meta)) expect_true(any(grepl("test_study", msg))) }) test_that(".print_dataset_info shows description and domains", { meta <- list( source = "s", description = "My study description", domains = list(adam = list("adsl", "adae"), sdtm = list("dm")), n_subjects = 50, license = "MIT", source_url = "https://example.com" ) msg <- paste(capture_messages(.print_dataset_info(meta)), collapse = "") expect_true(grepl("My study description", msg)) expect_true(grepl("adam", msg)) expect_true(grepl("adsl", msg)) expect_true(grepl("Subjects:", msg)) }) test_that(".print_dataset_info truncates domains with more than 8 datasets", { datasets <- as.list(paste0("ds", seq_len(12))) meta <- list(source = "s", domains = list(adam = datasets)) msg <- paste(capture_messages(.print_dataset_info(meta)), collapse = "") expect_true(grepl("12 total", msg)) }) # --- dataset_info --------------------------------------------------------- test_that("dataset_info reads from local cache when available", { fake_cache <- make_fake_cache_with_meta("cached_study") on.exit(unlink(fake_cache, recursive = TRUE)) local_mocked_bindings(cache_dir = function() fake_cache) expect_message(result <- dataset_info("cached_study"), "cached_study") expect_type(result, "list") expect_equal(result$source, "cached_study") expect_equal(result$n_subjects, 100) }) test_that("dataset_info reads bundled metadata for cdisc_pilot", { # This test uses the real bundled data in inst/exampledata/cdisc_pilot # Mock cache_dir to a non-existent path so it falls through to bundled local_mocked_bindings(cache_dir = function() tempfile()) expect_message(result <- dataset_info("cdisc_pilot"), "cdisc_pilot") expect_type(result, "list") expect_equal(result$source, "cdisc_pilot") expect_equal(result$n_subjects, 225) }) test_that("dataset_info cache takes priority over bundled metadata", { # Create a cached version of cdisc_pilot with different metadata fake_cache <- make_fake_cache_with_meta("cdisc_pilot") on.exit(unlink(fake_cache, recursive = TRUE)) # Overwrite metadata so it's distinguishable from the bundled version meta <- list(source = "cdisc_pilot", n_subjects = 999, version = "v99.0.0") jsonlite::write_json(meta, file.path(fake_cache, "cdisc_pilot", "metadata.json"), auto_unbox = TRUE) local_mocked_bindings(cache_dir = function() fake_cache) expect_message(result <- dataset_info("cdisc_pilot"), "cdisc_pilot") # Should get the cached version (999), not the bundled one (225) expect_equal(result$n_subjects, 999) }) test_that("dataset_info parses all metadata fields from cache", { fake_cache <- make_fake_cache_with_meta("full_meta_study") on.exit(unlink(fake_cache, recursive = TRUE)) local_mocked_bindings(cache_dir = function() fake_cache) expect_message(result <- dataset_info("full_meta_study"), "full_meta_study") expect_equal(result$source, "full_meta_study") expect_equal(result$description, "A test study") expect_equal(result$n_subjects, 100) expect_equal(result$version, "v0.1.0") expect_equal(result$license, "Test license") expect_equal(result$source_url, "https://example.com") expect_type(result$domains, "list") expect_equal(unlist(result$domains$adam), c("adsl", "adae")) }) test_that("dataset_info handles minimal metadata (missing optional fields)", { fake_cache <- file.path(tempdir(), paste0("ctd_min_", sample.int(1e5, 1))) study_dir <- file.path(fake_cache, "minimal_study") dir.create(study_dir, recursive = TRUE) on.exit(unlink(fake_cache, recursive = TRUE)) # Write metadata with only source — all other fields absent jsonlite::write_json(list(source = "minimal_study"), file.path(study_dir, "metadata.json"), auto_unbox = TRUE) local_mocked_bindings(cache_dir = function() fake_cache) expect_message(result <- dataset_info("minimal_study"), "minimal_study") expect_equal(result$source, "minimal_study") expect_null(result$description) expect_null(result$n_subjects) expect_null(result$domains) }) test_that("dataset_info errors on malformed JSON in cache", { fake_cache <- file.path(tempdir(), paste0("ctd_bad_", sample.int(1e5, 1))) study_dir <- file.path(fake_cache, "bad_json_study") dir.create(study_dir, recursive = TRUE) on.exit(unlink(fake_cache, recursive = TRUE)) writeLines("this is { not valid json !!!", file.path(study_dir, "metadata.json")) local_mocked_bindings(cache_dir = function() fake_cache) expect_error(dataset_info("bad_json_study")) }) test_that("dataset_info parses bundled cdisc_pilot domains correctly", { local_mocked_bindings(cache_dir = function() tempfile()) expect_message(result <- dataset_info("cdisc_pilot"), "cdisc_pilot") expect_true("adam" %in% names(result$domains)) expect_true("sdtm" %in% names(result$domains)) expect_true("adsl" %in% unlist(result$domains$adam)) expect_true("dm" %in% unlist(result$domains$sdtm)) expect_equal(length(unlist(result$domains$adam)), 11) expect_equal(length(unlist(result$domains$sdtm)), 22) }) test_that("dataset_info errors when GitHub is unreachable", { local_mocked_bindings( cache_dir = function() tempfile(), has_package = function(pkg) TRUE, .pb_releases = function(...) stop("connection refused") ) expect_error(dataset_info("remote_study"), "Could not reach GitHub") }) test_that("dataset_info errors when no releases exist", { local_mocked_bindings( cache_dir = function() tempfile(), has_package = function(pkg) TRUE, .pb_releases = function(...) empty_releases() ) expect_error(dataset_info("remote_study"), "No releases found") }) test_that("dataset_info errors when metadata asset is not found", { local_mocked_bindings( cache_dir = function() tempfile(), has_package = function(pkg) TRUE, .pb_releases = function(...) fake_releases(), .pb_list = function(...) fake_asset_list( files = c("other_study.zip"), tags = "v0.1.0" ) ) expect_error(dataset_info("missing_study"), "No metadata found") }) test_that("dataset_info errors when pb_list returns NULL", { local_mocked_bindings( cache_dir = function() tempfile(), has_package = function(pkg) TRUE, .pb_releases = function(...) fake_releases(), .pb_list = function(...) NULL ) expect_error(dataset_info("some_study"), "No metadata found") }) test_that("dataset_info remote happy path fetches and parses metadata", { meta_json <- jsonlite::toJSON( list(source = "remote_study", version = "v0.1.0", n_subjects = 50), auto_unbox = TRUE ) # Build a minimal httr response object fake_resp <- structure( list( status_code = 200L, content = charToRaw(as.character(meta_json)), headers = list(`content-type` = "application/json") ), class = "response" ) local_mocked_bindings( cache_dir = function() tempfile(), has_package = function(pkg) TRUE, .pb_releases = function(...) fake_releases(), .pb_list = function(...) fake_asset_list( files = c("remote_study_metadata.json"), tags = "v0.1.0" ), .httr_get = function(...) fake_resp, # Safety net: if httr mock doesn't prevent the fallback (e.g. R CMD check # namespace differences), write valid JSON so the test still passes. .download_file = function(url, destfile, ...) { writeLines(as.character(meta_json), destfile) invisible(0L) } ) expect_message(result <- dataset_info("remote_study"), "remote_study") expect_equal(result$source, "remote_study") expect_equal(result$n_subjects, 50) }) test_that("dataset_info falls back to download.file when httr fails", { meta <- list(source = "fallback_study", version = "v1.0.0", n_subjects = 75) # Create a temp JSON file that download.file will "produce" tmp_json <- tempfile(fileext = ".json") jsonlite::write_json(meta, tmp_json, auto_unbox = TRUE) json_content <- readLines(tmp_json, warn = FALSE) unlink(tmp_json) local_mocked_bindings( cache_dir = function() tempfile(), has_package = function(pkg) TRUE, .pb_releases = function(...) fake_releases(), .pb_list = function(...) fake_asset_list( files = c("fallback_study_metadata.json"), tags = "v0.1.0" ), .httr_get = function(...) stop("httr connection error"), .download_file = function(url, destfile, ...) { writeLines(json_content, destfile) invisible(0L) } ) expect_message(result <- dataset_info("fallback_study"), "fallback_study") expect_equal(result$source, "fallback_study") expect_equal(result$n_subjects, 75) }) test_that("dataset_info errors on malformed JSON from remote", { fake_resp <- structure( list( status_code = 200L, content = charToRaw("this is {not valid json"), headers = list(`content-type` = "application/json") ), class = "response" ) local_mocked_bindings( cache_dir = function() tempfile(), has_package = function(pkg) TRUE, .pb_releases = function(...) fake_releases(), .pb_list = function(...) fake_asset_list( files = c("bad_study_metadata.json"), tags = "v0.1.0" ), .httr_get = function(...) fake_resp, # Ensure fallback also produces invalid JSON .download_file = function(url, destfile, ...) { writeLines("this is {not valid json", destfile) invisible(0L) } ) expect_error(dataset_info("bad_study"), "Failed to parse metadata JSON") }) test_that("dataset_info uses tag_name column when tag column is absent", { meta_json <- jsonlite::toJSON( list(source = "tagname_study", version = "v0.1.0"), auto_unbox = TRUE ) fake_resp <- structure( list( status_code = 200L, content = charToRaw(as.character(meta_json)), headers = list(`content-type` = "application/json") ), class = "response" ) # Return assets with tag_name instead of tag assets <- data.frame( file_name = "tagname_study_metadata.json", size = 1024, tag_name = "v0.1.0", stringsAsFactors = FALSE ) local_mocked_bindings( cache_dir = function() tempfile(), has_package = function(pkg) TRUE, .pb_releases = function(...) fake_releases(), .pb_list = function(...) assets, .httr_get = function(...) fake_resp, .download_file = function(url, destfile, ...) { writeLines(as.character(meta_json), destfile) invisible(0L) } ) expect_message(result <- dataset_info("tagname_study"), "tagname_study") expect_equal(result$source, "tagname_study") }) # --- list_available_studies ----------------------------------------------- test_that("list_available_studies errors when GitHub is unreachable", { local_mocked_bindings( has_package = function(pkg) TRUE, cache_dir = function() tempfile(), # empty cache — no fallback available .pb_releases = function(...) stop("timeout") ) expect_error(list_available_studies(), "Could not fetch releases") }) test_that("list_available_studies returns empty df when no releases", { local_mocked_bindings( has_package = function(pkg) TRUE, .pb_releases = function(...) empty_releases() ) expect_message(result <- list_available_studies(), "No releases found") expect_s3_class(result, "data.frame") expect_equal(nrow(result), 0) expect_named(result, c("source", "version", "size_mb", "cached")) }) test_that("list_available_studies returns empty df when no assets", { local_mocked_bindings( has_package = function(pkg) TRUE, cache_dir = function() tempfile(), # empty cache — no fallback .pb_releases = function(...) fake_releases(), .pb_list = function(...) NULL ) expect_message(result <- list_available_studies(), "No dataset assets") expect_equal(nrow(result), 0) }) test_that("list_available_studies returns empty df when pb_list has 0 rows", { local_mocked_bindings( has_package = function(pkg) TRUE, cache_dir = function() tempfile(), # empty cache — no fallback .pb_releases = function(...) fake_releases(), .pb_list = function(...) data.frame( file_name = character(0), size = numeric(0), tag = character(0), stringsAsFactors = FALSE ) ) expect_message(result <- list_available_studies(), "No dataset assets") expect_equal(nrow(result), 0) }) test_that("list_available_studies returns empty df when no .zip assets", { local_mocked_bindings( has_package = function(pkg) TRUE, .pb_releases = function(...) fake_releases(), .pb_list = function(...) fake_asset_list( files = c("readme.md", "data_metadata.json") ) ) expect_message(result <- list_available_studies(), "No .zip study assets") expect_equal(nrow(result), 0) }) test_that("list_available_studies happy path returns correct data frame", { fake_cache <- file.path(tempdir(), paste0("ctd_list_", sample.int(1e5, 1))) cached_dir <- file.path(fake_cache, "study_a") dir.create(cached_dir, recursive = TRUE) on.exit(unlink(fake_cache, recursive = TRUE)) local_mocked_bindings( has_package = function(pkg) TRUE, cache_dir = function() fake_cache, .pb_releases = function(...) fake_releases("v0.2.0"), .pb_list = function(...) fake_asset_list( files = c("study_a.zip", "study_b.zip", "study_a_metadata.json"), tags = "v0.2.0", sizes = c(4 * 1024^2, 2 * 1024^2, 1024) ) ) result <- list_available_studies() expect_s3_class(result, "data.frame") expect_named(result, c("source", "version", "size_mb", "cached")) expect_equal(nrow(result), 2) # only .zip files expect_equal(result$source, c("study_a", "study_b")) expect_equal(result$version, c("v0.2.0", "v0.2.0")) expect_true(result$cached[result$source == "study_a"]) expect_false(result$cached[result$source == "study_b"]) }) test_that("list_available_studies handles tag_name column variant", { fake_cache <- tempfile() on.exit(unlink(fake_cache, recursive = TRUE)) assets <- data.frame( file_name = c("study_x.zip"), size = 1024^2, tag_name = "v1.0.0", stringsAsFactors = FALSE ) local_mocked_bindings( has_package = function(pkg) TRUE, cache_dir = function() fake_cache, .pb_releases = function(...) fake_releases("v1.0.0"), .pb_list = function(...) assets ) result <- list_available_studies() expect_equal(result$version, "v1.0.0") expect_equal(result$source, "study_x") }) # --- list_available_studies: offline fallback ------------------------------ test_that("list_available_studies saves cache on success", { fake_cache <- file.path(tempdir(), paste0("ctd_sc_", sample.int(1e5, 1))) dir.create(fake_cache, recursive = TRUE) on.exit(unlink(fake_cache, recursive = TRUE)) local_mocked_bindings( has_package = function(pkg) TRUE, cache_dir = function() fake_cache, .pb_releases = function(...) fake_releases("v0.2.0"), .pb_list = function(...) fake_asset_list( files = c("study_a.zip"), tags = "v0.2.0", sizes = 2 * 1024^2 ) ) list_available_studies() cache_file <- file.path(fake_cache, ".studies_cache.rds") expect_true(file.exists(cache_file)) cached <- readRDS(cache_file) expect_s3_class(cached, "data.frame") expect_equal(cached$source, "study_a") }) test_that("list_available_studies falls back to stale cache when GitHub is unreachable", { fake_cache <- file.path(tempdir(), paste0("ctd_fb_", sample.int(1e5, 1))) dir.create(fake_cache, recursive = TRUE) on.exit(unlink(fake_cache, recursive = TRUE)) # Pre-seed the cache with a stale listing stale_data <- data.frame( source = c("old_study_a", "old_study_b"), version = c("v0.1.0", "v0.1.0"), size_mb = c(3.0, 1.5), cached = c(TRUE, FALSE), stringsAsFactors = FALSE ) saveRDS(stale_data, file.path(fake_cache, ".studies_cache.rds")) local_mocked_bindings( has_package = function(pkg) TRUE, cache_dir = function() fake_cache, .pb_releases = function(...) stop("network timeout") ) expect_warning( result <- list_available_studies(), "cached study list" ) expect_s3_class(result, "data.frame") expect_equal(result$source, c("old_study_a", "old_study_b")) }) test_that("offline fallback recomputes cached column from filesystem", { fake_cache <- file.path(tempdir(), paste0("ctd_rc_", sample.int(1e5, 1))) dir.create(fake_cache, recursive = TRUE) # Create a directory for study_b (simulating it was downloaded after the # stale listing was saved) dir.create(file.path(fake_cache, "study_b"), recursive = TRUE) on.exit(unlink(fake_cache, recursive = TRUE)) stale_data <- data.frame( source = c("study_a", "study_b"), version = c("v1.0.0", "v1.0.0"), size_mb = c(2.0, 3.0), cached = c(TRUE, FALSE), # stale: both wrong stringsAsFactors = FALSE ) saveRDS(stale_data, file.path(fake_cache, ".studies_cache.rds")) local_mocked_bindings( has_package = function(pkg) TRUE, cache_dir = function() fake_cache, .pb_releases = function(...) stop("offline") ) result <- suppressWarnings(list_available_studies()) # study_a has no directory → FALSE; study_b has a directory → TRUE expect_false(result$cached[result$source == "study_a"]) expect_true(result$cached[result$source == "study_b"]) }) test_that("list_available_studies still errors when offline with no cache", { fake_cache <- tempfile() # non-existent directory, no cache file on.exit(unlink(fake_cache, recursive = TRUE)) local_mocked_bindings( has_package = function(pkg) TRUE, cache_dir = function() fake_cache, .pb_releases = function(...) stop("network error") ) expect_error(list_available_studies(), "Could not fetch releases") }) test_that("list_available_studies falls back when pb_list fails with stale cache", { fake_cache <- file.path(tempdir(), paste0("ctd_pbl_", sample.int(1e5, 1))) dir.create(fake_cache, recursive = TRUE) on.exit(unlink(fake_cache, recursive = TRUE)) stale_data <- data.frame( source = "cached_study", version = "v0.1.0", size_mb = 2.0, cached = FALSE, stringsAsFactors = FALSE ) saveRDS(stale_data, file.path(fake_cache, ".studies_cache.rds")) local_mocked_bindings( has_package = function(pkg) TRUE, cache_dir = function() fake_cache, .pb_releases = function(...) fake_releases("v0.1.0"), .pb_list = function(...) NULL ) expect_warning( result <- list_available_studies(), "cached study list" ) expect_equal(result$source, "cached_study") }) # --- download_study ------------------------------------------------------- test_that("download_study reports cached study without downloading", { fake_cache <- file.path(tempdir(), paste0("ctd_dl_", sample.int(1e5, 1))) fake_study <- file.path(fake_cache, "fake_study") dir.create(fake_study, recursive = TRUE) on.exit(unlink(fake_cache, recursive = TRUE)) local_mocked_bindings( cache_dir = function() fake_cache, has_package = function(pkg) TRUE ) expect_message(download_study("fake_study"), "already cached") }) test_that("download_study returns cached path invisibly", { fake_cache <- file.path(tempdir(), paste0("ctd_dl2_", sample.int(1e5, 1))) fake_study <- file.path(fake_cache, "cached_ret") dir.create(fake_study, recursive = TRUE) on.exit(unlink(fake_cache, recursive = TRUE)) local_mocked_bindings( cache_dir = function() fake_cache, has_package = function(pkg) TRUE ) result <- suppressMessages(download_study("cached_ret")) expect_equal(result, fake_study) }) test_that("download_study errors when GitHub is unreachable (latest)", { fake_cache <- tempfile() on.exit(unlink(fake_cache, recursive = TRUE)) local_mocked_bindings( cache_dir = function() fake_cache, has_package = function(pkg) TRUE, .pb_releases = function(...) stop("network error") ) expect_error(download_study("study_x"), "Could not fetch releases") }) test_that("download_study errors when no releases exist (latest)", { fake_cache <- tempfile() on.exit(unlink(fake_cache, recursive = TRUE)) local_mocked_bindings( cache_dir = function() fake_cache, has_package = function(pkg) TRUE, .pb_releases = function(...) empty_releases() ) expect_error(download_study("study_x"), "No releases found") }) test_that("download_study errors when pb_list fails", { fake_cache <- tempfile() on.exit(unlink(fake_cache, recursive = TRUE)) local_mocked_bindings( cache_dir = function() fake_cache, has_package = function(pkg) TRUE, .pb_releases = function(...) fake_releases("v0.1.0"), .pb_list = function(...) stop("asset listing failed") ) expect_error(download_study("study_x"), "Could not list assets") }) test_that("download_study errors when asset not found in release", { fake_cache <- tempfile() on.exit(unlink(fake_cache, recursive = TRUE)) local_mocked_bindings( cache_dir = function() fake_cache, has_package = function(pkg) TRUE, .pb_releases = function(...) fake_releases("v0.1.0"), .pb_list = function(...) fake_asset_list( files = c("other_study.zip"), tags = "v0.1.0" ) ) expect_error(download_study("missing_study"), "not found in release") }) test_that("download_study happy path downloads, extracts, and locks", { fake_cache <- file.path(tempdir(), paste0("ctd_hp_", sample.int(1e5, 1))) dir.create(fake_cache, recursive = TRUE) on.exit({ # Unlock before cleanup so file permissions don't block deletion study_path <- file.path(fake_cache, "my_study") if (dir.exists(study_path)) unlock_study(study_path) unlink(fake_cache, recursive = TRUE) }) local_mocked_bindings( cache_dir = function() fake_cache, has_package = function(pkg) TRUE, .pb_releases = function(...) fake_releases("v0.1.0"), .pb_list = function(...) fake_asset_list( files = c("my_study.zip", "my_study_metadata.json"), tags = "v0.1.0" ), # pb_download mock: create a real zip in the dest directory .pb_download = function(file, dest, ...) { make_fake_zip(dest, source_name = "my_study") invisible(NULL) } ) result <- suppressMessages(download_study("my_study")) expect_equal(result, file.path(fake_cache, "my_study")) expect_true(dir.exists(result)) expect_true(is_study_locked(result)) }) test_that("download_study with explicit version skips release resolution", { fake_cache <- file.path(tempdir(), paste0("ctd_exv_", sample.int(1e5, 1))) dir.create(fake_cache, recursive = TRUE) on.exit({ study_path <- file.path(fake_cache, "versioned_study") if (dir.exists(study_path)) unlock_study(study_path) unlink(fake_cache, recursive = TRUE) }) pb_releases_called <- FALSE local_mocked_bindings( cache_dir = function() fake_cache, has_package = function(pkg) TRUE, # pb_releases should NOT be called when an explicit version is given .pb_releases = function(...) { pb_releases_called <<- TRUE; fake_releases("v0.1.0") }, .pb_list = function(...) fake_asset_list( files = c("versioned_study.zip"), tags = "v0.1.0" ), .pb_download = function(file, dest, ...) { make_fake_zip(dest, source_name = "versioned_study") invisible(NULL) } ) result <- suppressMessages(download_study("versioned_study", version = "v0.1.0")) expect_equal(result, file.path(fake_cache, "versioned_study")) expect_true(dir.exists(result)) expect_false(pb_releases_called) }) test_that("download_study with force re-downloads even when cached", { fake_cache <- file.path(tempdir(), paste0("ctd_force_", sample.int(1e5, 1))) study_path <- file.path(fake_cache, "force_study") dir.create(study_path, recursive = TRUE) # Create a marker file that should be gone after force re-download writeLines("old", file.path(study_path, "old_marker.txt")) on.exit({ if (dir.exists(study_path)) unlock_study(study_path) unlink(fake_cache, recursive = TRUE) }) local_mocked_bindings( cache_dir = function() fake_cache, has_package = function(pkg) TRUE, .pb_releases = function(...) fake_releases("v0.1.0"), .pb_list = function(...) fake_asset_list( files = c("force_study.zip"), tags = "v0.1.0" ), .pb_download = function(file, dest, ...) { make_fake_zip(dest, source_name = "force_study") invisible(NULL) } ) result <- suppressMessages(download_study("force_study", force = TRUE)) expect_true(dir.exists(result)) # Old marker should be gone (directory was replaced) expect_false(file.exists(file.path(result, "old_marker.txt"))) expect_true(is_study_locked(result)) }) test_that("download_study errors when zip file is missing after download", { fake_cache <- file.path(tempdir(), paste0("ctd_nozip_", sample.int(1e5, 1))) dir.create(fake_cache, recursive = TRUE) on.exit(unlink(fake_cache, recursive = TRUE)) local_mocked_bindings( cache_dir = function() fake_cache, has_package = function(pkg) TRUE, .pb_releases = function(...) fake_releases("v0.1.0"), .pb_list = function(...) fake_asset_list( files = c("ghost_study.zip"), tags = "v0.1.0" ), # pb_download mock that does NOT create the zip file .pb_download = function(file, dest, ...) invisible(NULL) ) expect_error( suppressMessages(download_study("ghost_study")), "zip file not found" ) }) test_that("download_study errors when extraction produces wrong directory", { fake_cache <- file.path(tempdir(), paste0("ctd_badzip_", sample.int(1e5, 1))) dir.create(fake_cache, recursive = TRUE) on.exit(unlink(fake_cache, recursive = TRUE)) local_mocked_bindings( cache_dir = function() fake_cache, has_package = function(pkg) TRUE, .pb_releases = function(...) fake_releases("v0.1.0"), .pb_list = function(...) fake_asset_list( files = c("expected_name.zip"), tags = "v0.1.0" ), # pb_download creates a zip but with a different internal directory name .pb_download = function(file, dest, ...) { make_fake_zip(dest, source_name = "wrong_name") # Rename the zip to what download_study expects file.rename( file.path(dest, "wrong_name.zip"), file.path(dest, "expected_name.zip") ) invisible(NULL) } ) expect_error( suppressMessages(download_study("expected_name")), "Extraction did not produce expected directory" ) })