Issue/22

DESCRIPTION

@@ -48,7 +48,8 @@ Suggests:
     BiocStyle,
     knitr,
     liftOver,
-    testthat (>= 3.0.0)
+    testthat (>= 3.0.0),
+    withr
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.3.3

R/bedbaser.R

@@ -308,12 +308,14 @@ bb_example <- function(bedbase, rec_type = c("bed", "bedset")) {
 bb_metadata <- function(bedbase, id, full = FALSE) {
     rsp <- bedbase$get_bed_metadata_v1_bed__bed_id__metadata_get(
         bed_id = id,
-        full = full
+        full = full,
+        test_request = .is_test_request()
     )
     if (rsp$status_code != 200) {
         rsp <- bedbase$get_bedset_metadata_v1_bedset__bedset_id__metadata_get(
             bedset_id = id,
-            full = full
+            full = full,
+            test_request = .is_test_request()
         )
     }
     result <- httr::content(rsp)
@@ -391,7 +393,8 @@ bb_list_bedsets <- function(bedbase, query = "", limit = 1000, offset = 0) {
     rsp <- bedbase$list_bedsets_v1_bedset_list_get(
         query = query,
         limit = limit,
-        offset = offset
+        offset = offset,
+        test_request = .is_test_request()
     )
     recs <- httr::content(rsp)
     results <- tibble::tibble()
@@ -480,7 +483,8 @@ bb_bed_text_search <- function(bedbase, query, genome = NULL, assay = NULL,
         genome = genome,
         assay = assay,
         limit = limit,
-        offset = offset
+        offset = offset,
+        test_request = .is_test_request()
     )
     recs <- httr::content(rsp)
     results <- tibble::tibble()
@@ -516,11 +520,7 @@ bb_bed_text_search <- function(bedbase, query, genome = NULL, assay = NULL,
 #'
 #' @export
 bb_to_granges <- function(bedbase, bed_id, extra_cols = NULL, quietly = TRUE) {
-    metadata <- bb_metadata(bedbase, bed_id, TRUE)
-    file_path <- .get_file(
-        metadata, getCache(bedbase, "bedfiles"), "http",
-        quietly
-    )
+    file_path <- .get_file(bedbase, bed_id, getCache(bedbase, "bedfiles"), quietly)
 
     tryCatch(
         R.utils::gunzip(file_path, remove = FALSE),
@@ -529,6 +529,7 @@ bb_to_granges <- function(bedbase, bed_id, extra_cols = NULL, quietly = TRUE) {
         }
     )
 
+    metadata <- bb_metadata(bedbase, bed_id, TRUE)
     .bed_file_to_granges(file_path, metadata, extra_cols, quietly)
 }
 
@@ -597,7 +598,6 @@ bb_save <- function(bedbase, bed_or_bedset_id, path, quietly = TRUE) {
         )
     }
     for (id in ids) {
-        metadata <- bb_metadata(bedbase, id, TRUE)
-        .get_file(metadata, path, "http", quietly)
+        .get_file(bedbase, id, path, quietly)
     }
 }

R/utils.R

@@ -1,3 +1,15 @@
+#' Return TRUE if a test_request to prevent impact to BEDbase statistics
+#'
+#' @param default logical(1) (default \code{FALSE}) internal parameter for
+#' testing purposes
+#'
+#' @return logical(1)
+#'
+#' @noRd
+.is_test_request <- function(default = FALSE) {
+    getOption("bedbaser.test_request", default = default)
+}
+
 #' Get file name from URL for a file
 #'
 #' @param a_url character(1) URL
@@ -13,57 +25,36 @@
     url_parts[length(url_parts)]
 }
 
-#' Get BEDbase url for BED file
-#'
-#' @param records list() metadata
-#' @param access_type character(1) s3 or http
-#'
-#' @return character(1) url to BED file
-#'
-#' @examples
-#' bedbase <- BEDbase()
-#' ex_bed <- bb_example(bedbase, "bed")
-#' ex_metadata <- bb_metadata(bedbase, ex_bed$id, TRUE)
-#' .get_url(ex_bed$files, "http")
-#'
-#' @noRd
-.get_url <- function(metadata, access_type = c("s3", "http")) {
-    access_type <- match.arg(access_type)
-    file_details <- dplyr::bind_rows(metadata$files) |>
-        tidyr::unnest_wider(access_methods) |>
-        tidyr::unnest_wider(access_url) |>
-        dplyr::filter(
-            name == "bed_file",
-            access_id == access_type
-        )
-    file_details$url
-}
-
 #' Get a BED file
 #'
 #' @description Download or retrieve the file the cache. If not available, get
 #' the file from bedbase.org and save to the cache or a path. If a directory
 #' does not exist along specified path, it will raise an error message.
 #'
-#' @param metadata list() full metadata
+#' @param bedbase BEDbase() object
+#' @param bed_id integer(1) BED record identifier
 #' @param cache_or_path [BiocFileCache][BiocFileCache::BiocFileCache-class] or
 #'        character(1) cache or save path
-#' @param access_type character(1) s3 or http
 #' @param quietly logical(1) (default \code{TRUE}) display messages
 #'
 #' @return character(1) file path
 #'
 #' @examples
 #' bedbase <- BEDbase()
 #' ex_bed <- bb_example(bedbase, "bed")
-#' md <- bb_metadata(bedbase, ex_bed$id, TRUE)
-#' .get_file(md, tempdir(), "http")
+#' .get_file(bedbase, ex_bed$id, tempdir())
 #'
 #' @noRd
-.get_file <- function(metadata, cache_or_path, access_type, quietly = TRUE) {
-    file_url <- .get_url(metadata, access_type)
+.get_file <- function(bedbase, id, cache_or_path, quietly = TRUE) {
+    resp = httr::content(
+        bedbase$get_bed_files_v1_bed__bed_id__metadata_files_get(id)
+    )
+    file_url <- bedbase$redirect_to_download_v1_files__file_path__get(
+        file_path = resp$bed_file$path,
+        test_request = .is_test_request()
+    )$url
     if (methods::is(cache_or_path, "BiocFileCache")) {
-        bed_file <- .cache_bedfile(metadata$id, file_url, cache_or_path)
+        bed_file <- .cache_bedfile(id, file_url, cache_or_path)
     } else {
         bed_file <- file.path(cache_or_path, .get_file_name(file_url))
         curl::curl_download(file_url, bed_file, quiet = quietly)
@@ -88,8 +79,7 @@
 #' @examples
 #' bedbase <- BEDbase()
 #' ex_bedset <- bb_example(bedbase, "bedset")
-#' md <- bb_metadata(bedbase, ex_bedset$bed_ids[[1]], TRUE)
-#' file_path <- .get_file(md, getCache(bedbase), "http")
+#' file_path <- .get_file(bedbase, ex_bedset$bed_ids[[1]], getCache(bedbase))
 #' .get_extra_cols(file_path, 3, 9)
 #'
 #' @noRd
@@ -123,8 +113,8 @@
 #' @examples
 #' bedbase <- BEDbase()
 #' ex_bed <- bb_example(bedbase, "bed")
-#' md <- bb_metadata(bedbase, ex_bed$id, TRUE)
-#' file_path <- .get_file(md, getCache(bedbase), "http")
+#' metadata <- bb_metadata(bedbase, ex_bed$id, TRUE)
+#' file_path <- .get_file(bedbase, ex_bed$id, getCache(bedbase))
 #' args <- list(
 #'     con = file_path,
 #'     format = gsub("peak", "Peak", metadata$data_format),
@@ -158,8 +148,8 @@
 #' @examples
 #' bedbase <- BEDbase()
 #' ex_bed <- bb_example(bedbase, "bed")
+#' file_path <- .get_file(bedbase, ex_bed$id, getCache(bedbase))
 #' md <- bb_metadata(bedbase, ex_bed$id, TRUE)
-#' file_path <- .get_file(md, getCache(bedbase), "http")
 #' format <- .get_format(file_path, md$data_format)
 #'
 #' @noRd
@@ -192,8 +182,7 @@
 #' @examples
 #' bedbase <- BEDbase()
 #' ex_bed <- bb_example(bedbase, "bed")
-#' md <- bb_metadata(bedbase, ex_bed$id, TRUE)
-#' file_path <- .get_file(md, getCache(bedbase), "http")
+#' file_path <- .get_file(bedbase, ex_bed$id, getCache(bedbase))
 #' .bed_file_to_granges(file_path, md)
 #'
 #' @noRd

inst/service/bedbase/README.md

@@ -26,3 +26,17 @@ Convert openapi.json from OpenAPI 3.1 to 3.0:
 Convert from OpenAPI 3.0 to Swagger 2.0:
 
     api-spec-converter -f openapi_3 -t swagger_2 openapi_3_0.json > api.yaml
+
+Run `add_test_requests` to add a hidden parameter `test_request` for the
+following endpoints:
+
+* /v1/bed/search/text
+* /v1/bed/{bed_id}/metadata
+* /v1/bedset/{bedset_id}/metadata
+* /v1/bedset/list
+* /v1/files/{file_path}
+
+If `test_request` is TRUE, the request will not be counted in BEDbase
+statistics.
+
+    bash add_test_request

inst/service/bedbase/add_test_requests

@@ -0,0 +1,18 @@
+# requires jq
+# run with
+# bash add_test_requests
+
+jq --indent 2 '
+  {
+    "default": false,
+    "in": "query",
+    "name": "test_request",
+    "required": false,
+    "type": "boolean"
+  } as $test_request |
+  .paths["/v1/bed/{bed_id}/metadata"].get.parameters += [$test_request] |
+  .paths["/v1/bed/search/text"].get.parameters += [$test_request] |
+  .paths["/v1/bedset/{bedset_id}/metadata"].get.parameters += [$test_request] |
+  .paths["/v1/bedset/list"].get.parameters += [$test_request] |
+  .paths["/v1/files/{file_path}"].get.parameters += [$test_request]
+' api.yaml > tmp.yaml && mv tmp.yaml api.yaml

inst/service/bedbase/api.yaml

@@ -369,6 +369,13 @@
             "name": "offset",
             "required": false,
             "type": "integer"
+          },
+          {
+            "default": false,
+            "in": "query",
+            "name": "test_request",
+            "required": false,
+            "type": "boolean"
           }
         ],
         "responses": {
@@ -532,6 +539,13 @@
             "in": "query",
             "name": "full",
             "required": false
+          },
+          {
+            "default": false,
+            "in": "query",
+            "name": "test_request",
+            "required": false,
+            "type": "boolean"
           }
         ],
         "responses": {
@@ -1031,6 +1045,13 @@
             "name": "offset",
             "required": false,
             "type": "integer"
+          },
+          {
+            "default": false,
+            "in": "query",
+            "name": "test_request",
+            "required": false,
+            "type": "boolean"
           }
         ],
         "responses": {
@@ -1109,6 +1130,13 @@
             "name": "full",
             "required": false,
             "type": "boolean"
+          },
+          {
+            "default": false,
+            "in": "query",
+            "name": "test_request",
+            "required": false,
+            "type": "boolean"
           }
         ],
         "responses": {
@@ -1390,6 +1418,13 @@
             "name": "file_path",
             "required": true,
             "type": "string"
+          },
+          {
+            "default": false,
+            "in": "query",
+            "name": "test_request",
+            "required": false,
+            "type": "boolean"
           }
         ],
         "responses": {

tests/testthat/setup.R

@@ -0,0 +1,4 @@
+withr::local_options(
+    bedbaser.test_request = TRUE,
+    .local_envir = teardown_env()
+)

tests/testthat/test-cache.R

@@ -42,7 +42,13 @@ test_that("bed files are cached", {
     cache <- getCache(bedbase, "bedfiles")
     rid <- BiocFileCache::bfcquery(cache, id, "rname")$rid
     expect_length(rid, 0)
-    bedbase_url <- .get_url(bb_metadata(bedbase, id, TRUE), "http")
+    resp <- httr::content(
+        bedbase$get_bed_files_v1_bed__bed_id__metadata_files_get(id)
+    )
+    bedbase_url <- bedbase$redirect_to_download_v1_files__file_path__get(
+        file_path = resp$bed_file$path,
+        test_request = .is_test_request()
+    )$url
     rpath <- .cache_bedfile(id, bedbase_url, cache)
     expect_true(file.exists(rpath))
     rid <- BiocFileCache::bfcquery(cache, id, "rname")$rid

tests/testthat/test-utils.R

@@ -1,7 +1,6 @@
 bedbase <- BEDbase(tempdir(), quietly = TRUE)
 ex_bed <- bb_example(bedbase, "bed")
 ex_bedset <- bb_example(bedbase, "bedset")
-ex_bed_md <- bb_metadata(bedbase, ex_bed$id, TRUE)
 
 test_that(".get_file_name returns file name", {
     expect_equal(
@@ -10,24 +9,20 @@ test_that(".get_file_name returns file name", {
     )
 })
 
-test_that(".get_url returns a url", {
-    file_url <- .get_url(ex_bed_md, "http")
-    expect_true(stringr::str_detect(file_url, "(https?|ftp|s3)://"))
-})
-
 test_that(".get_file returns a valid file path", {
-    file_path <- .get_file(ex_bed_md, tempdir(), "http")
+    file_path <- .get_file(bedbase, ex_bed$id, tempdir())
     expect_true(file.exists(file_path))
-    file_path <- .get_file(ex_bed_md, getCache(bedbase, "bedfiles"), "http")
+    file_path <- .get_file(bedbase, ex_bed$id, getCache(bedbase, "bedfiles"))
     expect_true(file.exists(file_path))
 })
 
 test_that(".get_extra_cols returns a named vector", {
-    ex_bed_md2 <- bb_metadata(bedbase, ex_bedset$bed_ids[[1]], TRUE)
-    file_path <- .get_file(ex_bed_md2, getCache(bedbase, "bedfiles"), "http")
-    x_y <- strsplit(gsub("bed", "", ex_bed_md2$bed_compliance),
+    id <- ex_bedset$bed_ids[[1]]
+    file_path <- .get_file(bedbase, id, getCache(bedbase, "bedfiles"))
+    ex_bed_md <- bb_metadata(bedbase, id, TRUE)
+    x_y <- strsplit(gsub("bed", "", ex_bed_md$bed_compliance),
                     "+",
-                    fixed= TRUE)[[1]]
+                    fixed = TRUE)[[1]]
     extra_cols <- .get_extra_cols(file_path,
                                   as.numeric(x_y[1]),
                                   as.numeric(x_y[2]))