add nexrad source functionality

NAMESPACE

@@ -8,3 +8,4 @@ export(get_weather_radars)
 export(set_secret)
 importFrom(dplyr,.data)
 importFrom(lubridate,"%within%")
+importFrom(rlang,.env)

NEWS.md

@@ -1,5 +1,6 @@
 # getRad (development version)
 
+* Implement download of `vpts` data from birdcast by Alexander Tedeschi. 
 * Implement reading `vpts` data from a local directory (#135).
 * Clarify HTTP 429 error for the Netherlands (#165).
 * Clarify error for Estonia and propagate call (#173).

R/getRad-package.R

@@ -3,6 +3,7 @@
 
 ## usethis namespace: start
 #' @importFrom dplyr .data
+#' @importFrom rlang .env
 #' @importFrom lubridate %within%
 ## usethis namespace: end
 NULL

R/get_vpts.R

@@ -34,8 +34,8 @@
 #'   - A vector of datetimes or dates, between which all data files are
 #'   downloaded.
 #'   - A [lubridate::interval()], between which all data files are downloaded.
-#' @param source Source of the data. One of `"baltrad"`, `"uva"`, `"ecog-04003"`
-#'   or `"rmi"`. Only one source can be queried at a time. If not provided,
+#' @param source Source of the data. One of `"baltrad"`, `"uva"`, `"ecog-04003"`,
+#'   `"rmi"`, or `"birdcast"`. Only one source can be queried at a time. If not provided,
 #'   `"baltrad"` is used. Alternatively a local directory can be specified,
 #'   see details for an explanation of the file format.
 #' @param return_type Type of object that should be returned. Either:
@@ -77,10 +77,12 @@
 #'   source = "baltrad",
 #'   return_type = "tibble"
 #' )
+#' #' Get VPTS data from the public BirdCast NEXRAD archive
+#' get_vpts(radar = "KABR", datetime = "2023-01-01", source = "birdcast")
 get_vpts <- function(
   radar,
   datetime,
-  source = c("baltrad", "uva", "ecog-04003", "rmi"),
+  source = c("baltrad", "uva", "ecog-04003", "rmi", "birdcast"),
   return_type = c("vpts", "tibble")
 ) {
   # Input checks ----
@@ -205,14 +207,19 @@ get_vpts <- function(
   # Query the selected radars ----
   # Directing to the correct get_vpts_* helper based on source.
   cl <- rlang::caller_env(0)
+
+  aloft_sources <- eval(formals("get_vpts_aloft")$source)
+
+  source_type <- dplyr::case_when(
+    source == "rmi" ~ "rmi",
+    source == "birdcast" ~ "birdcast",
+    source %in% aloft_sources ~ "aloft",
+    dir.exists(source) ~ "local"
+  )
+
   fetched_vpts <-
     switch(
-      dplyr::case_when(
-        source == "rmi" ~ "rmi",
-        source %in% eval(formals("get_vpts_aloft")$source) ~ "aloft",
-        # this is the last option to avoid using a local source if an online exists
-        dir.exists(source) ~ "local"
-      ),
+      source_type,
       rmi = purrr::map(
         radar,
         ~ get_vpts_rmi(.x, rounded_interval),
@@ -227,6 +234,14 @@ get_vpts <- function(
         ),
         .purrr_error_call = cl
       ),
+      birdcast = purrr::map(
+        radar,
+        ~ get_vpts_birdcast(
+          .x,
+          rounded_interval = rounded_interval
+        ),
+        .purrr_error_call = cl
+      ),
       local = get_vpts_local(radar, rounded_interval, directory = source)
     ) |>
     radar_to_name()

R/get_vpts_aloft.R

@@ -30,7 +30,9 @@ get_vpts_aloft <- function(
   radar_odim_code,
   rounded_interval,
   source = c("baltrad", "uva", "ecog-04003"),
-  coverage = get_vpts_coverage_aloft()
+  coverage = get_vpts_coverage_aloft(),
+  ...,
+  call = rlang::caller_env()
 ) {
   # rename source argument for readability
   selected_source <- source
@@ -45,7 +47,8 @@ get_vpts_aloft <- function(
       "Can't find radar {.val {missing_radar}} in the coverage file (see
        {.fun get_vpts_coverage}).",
       missing_radar = missing_radar,
-      class = "getRad_error_aloft_radar_not_found"
+      class = "getRad_error_aloft_radar_not_found",
+      call = call
     )
   }
 
@@ -61,7 +64,8 @@ get_vpts_aloft <- function(
   if (!at_least_one_radar_date_combination_exists) {
     cli::cli_abort(
       "Can't find any data for the requested radar(s) and date(s).",
-      class = "getRad_error_date_not_found"
+      class = "getRad_error_date_not_found",
+      call = call
     )
   }
 
@@ -79,7 +83,8 @@ get_vpts_aloft <- function(
     cli::cli_abort(
       "Can't find radar{?s} {.val {missing_radars}} in the coverage file (see
        {.fun get_vpts_coverage}).",
-      class = "getRad_error_radar_not_found"
+      class = "getRad_error_radar_not_found",
+      call = call
     )
   }
 

R/get_vpts_birdcast.R

@@ -0,0 +1,95 @@
+#' Get VPTS data from the public BirdCast NEXRAD archive
+#'
+#' Gets VPTS data from the public BirdCast NEXRAD archive.
+#'
+#' @details
+#' By default, data are retrieved from the public BirdCast S3 archive at
+#' `https://birdcastdata.s3.amazonaws.com/nexrad/daily`.
+#'
+#' The expected path format is:
+#' `"{radar}/{year}/{radar}_vpts_{year}{month}{day}.csv"`.
+#'
+#' @section Inner working:
+#' - Checks that the requested radar is present in the NEXRAD coverage file.
+#' - Checks that data exist for the requested radar/date combination.
+#' - Constructs the S3 paths for the daily VPTS files from the coverage file.
+#' - Performs parallel HTTP requests to fetch the VPTS CSV data.
+#' - Parses the response bodies with the shared VPTS column classes.
+#' - Uses uppercase NEXRAD radar codes for archive paths.
+#' - Adds a column with the radar source.
+#'
+#' @param radar NEXRAD radar code.
+#' @param rounded_interval Interval to fetch data for, rounded to nearest day.
+#' @param coverage A data frame containing the coverage of the BirdCast NEXRAD
+#'   archive. If not provided, it will be fetched via the internet.
+#' @param ... Used to prevent accidentally using the `call` argument
+#' @param call A call used for error messaging.
+#' @return A tibble with VPTS data.
+#' @noRd
+get_vpts_birdcast <- function(
+  radar,
+  rounded_interval,
+  coverage = get_vpts_coverage_birdcast(),
+  ...,
+  call = rlang::caller_env()
+) {
+  radar <- toupper(radar)
+
+  # Check that only one radar is provided.
+  check_odim_nexrad_scalar(radar)
+
+  # Check if the requested radar is present in the coverage.
+  if (!all(radar %in% coverage$radar)) {
+    missing_radar <- radar[!radar %in% coverage$radar]
+
+    cli::cli_abort(
+      "Can't find radar {.val {missing_radar}} in the birdcast coverage file
+       (see {.fun get_vpts_coverage}).",
+      missing_radar = missing_radar,
+      class = "getRad_error_birdcast_radar_not_found",
+      call = call
+    )
+  }
+
+  # Check if the requested radar/date combination is present in the coverage.
+  filtered_coverage <- dplyr::filter(
+    coverage,
+    .data$radar %in% .env$radar,
+    .data$date %within% rounded_interval
+  )
+
+  if (nrow(filtered_coverage) == 0) {
+    cli::cli_abort(
+      "Can't find any data for the requested radar(s) and date(s).",
+      class = "getRad_error_date_not_found",
+      call = call
+    )
+  }
+
+  # Convert the selected coverage rows into paths on the BirdCast NEXRAD archive.
+  s3_paths <- filtered_coverage |>
+    dplyr::mutate(
+      path = glue::glue(
+        "{radar}/{year}/{radar}_vpts_{year}{month}{day}.csv",
+        radar = .data$radar,
+        year = lubridate::year(.data$date),
+        month = sprintf("%02d", lubridate::month(.data$date)),
+        day = sprintf("%02d", lubridate::day(.data$date))
+      )
+    ) |>
+    dplyr::pull(.data$path)
+
+  # Read the VPTS CSV files.
+  birdcast_data_url <- getOption("getRad.birdcast_vpts_data_url")
+  radar_out <- tolower(radar)
+
+  out <- paste(birdcast_data_url, "nexrad", "daily", s3_paths, sep = "/") |>
+    read_vpts_from_url() |>
+    purrr::keep(.p = ~ as.logical(nrow(.x))) |>
+    purrr::list_rbind()
+
+  out$radar <- radar_out
+  out$source <- "birdcast"
+
+  out
+}

R/get_vpts_coverage.R

@@ -3,7 +3,7 @@
 #' Gets the VPTS file coverage from supported sources per radar and date.
 #'
 #' @param source Source of the data. One or more of `"baltrad"`, `"uva"`,
-#'   `"ecog-04003"` or `"rmi"`. If not provided, `"baltrad"` is used.
+#'   `"ecog-04003"` or `"rmi"` or `"birdcast"`. If not provided, `"baltrad"` is used.
 #'   Alternatively `"all"` can be used if data from all sources should be
 #'   returned.
 #' @param ... Arguments passed on to internal functions.
@@ -13,7 +13,7 @@
 #' @examplesIf interactive()
 #' get_vpts_coverage()
 get_vpts_coverage <- function(
-  source = c("baltrad", "uva", "ecog-04003", "rmi"),
+  source = c("baltrad", "uva", "ecog-04003", "rmi", "birdcast"),
   ...
 ) {
   # argument all returns all possible sources
@@ -40,7 +40,8 @@ get_vpts_coverage <- function(
     rmi = get_vpts_coverage_rmi,
     baltrad = get_vpts_coverage_aloft,
     uva = get_vpts_coverage_aloft,
-    "ecog-04003" = get_vpts_coverage_aloft
+    "ecog-04003" = get_vpts_coverage_aloft,
+    birdcast = get_vpts_coverage_birdcast
   )
   cl <- rlang::caller_env(0)
   # Run the helpers, but every helper only once.

R/get_vpts_coverage_aloft.R

@@ -25,7 +25,6 @@ get_vpts_coverage_aloft <- function(
     req_user_agent_getrad() |>
     req_retry_getrad() |>
     req_cache_getrad(use_cache = use_cache) |>
-    httr2::req_progress(type = "down") |>
     httr2::req_perform(error_call = call) |>
     httr2::resp_body_raw()
 

R/get_vpts_coverage_birdcast.R

@@ -0,0 +1,49 @@
+#' Get VPTS file coverage from the public BirdCast NEXRAD archive
+#'
+#' Gets the VPTS file coverage from the public BirdCast NEXRAD archive. This is
+#' derived from a coverage file at
+#' <`r file.path(getOption("getRad.birdcast_vpts_data_url"), "coverage.csv")`>. By
+#' default this file is cached for 6 hours.
+#'
+#' @param ... Used to prevent accidentally using the `call` argument
+#' @param call A call used for error messaging.
+#' @inheritParams req_cache_getrad
+#' @return A data frame of the coverage file in the birdcast VPTS archive.
+#' @noRd
+#' @examplesIf interactive()
+#' get_vpts_coverage_birdcast()
+get_vpts_coverage_birdcast <- function(
+  use_cache = TRUE,
+  ...,
+  call = rlang::caller_env()
+) {
+  birdcast_vpts_data_url <- getOption("getRad.birdcast_vpts_data_url")
+
+  coverage_raw <-
+    httr2::request(birdcast_vpts_data_url) |>
+    httr2::req_url_path_append("coverage.csv") |>
+    req_user_agent_getrad() |>
+    req_retry_getrad() |>
+    req_cache_getrad(use_cache = use_cache) |>
+    httr2::req_perform(error_call = call) |>
+    httr2::resp_body_raw()
+
+  coverage <-
+    vroom::vroom(
+      coverage_raw,
+      progress = FALSE,
+      show_col_types = FALSE
+    ) |>
+    dplyr::mutate(
+      source = "birdcast",
+      radar = string_extract(.data$directory, "(?<=daily\\/)[A-Z0-9]{4}"),
+      date = as.Date(
+        string_extract(
+          .data$directory,
+          "[0-9]{4}\\/[0-9]{2}\\/[0-9]{2}$"
+        )
+      )
+    )
+
+  return(coverage)
+}

R/zzz.R

@@ -21,6 +21,7 @@
     ),
     getRad.aloft_data_url = "https://aloftdata.s3-eu-west-1.amazonaws.com",
     getRad.nexrad_data_url = "https://unidata-nexrad-level2.s3.amazonaws.com",
+    getRad.birdcast_vpts_data_url = "https://birdcastdata.s3.amazonaws.com",
     getRad.cache = cachem::cache_mem(
       max_size = 128 * 1024^2,
       max_age = 60^2 * 24

tests/testthat/test-get_pvol_ee.R

@@ -1,19 +1,27 @@
 test_that("Pvol for estonia can be downloaded", {
   skip_if_offline()
   withr::local_options(list(httr2_progress = FALSE))
-  # The api frequently sends a 429 response therefore test is allowed to fail
+
+  time <- as.POSIXct("2024-4-4 21:00:00", tz = "Europe/Helsinki")
+
+  # The API frequently sends 429/500 responses, therefore this test is allowed
+  # to skip when the download is unsuccessful.
   show_failure(expect_no_error(
     pvol <- get_pvol(
       "eesur",
-      time <- as.POSIXct("2024-4-4 21:00:00", tz = "Europe/Helsinki"),
+      time,
       param = "all"
     )
   ))
-  ## If get_pvol() returns an error, the other tests are skipped.
+
   skip_if_not(
     inherits(pvol, "pvol"),
-    message = "PVOL download for estonia was unsuccesful, succes is variable in testing environments"
+    message = paste(
+      "PVOL download for Estonia was unsuccessful;",
+      "success is variable in testing environments"
+    )
   )
+
   expect_s3_class(pvol, "pvol")
   expect_true(bioRad::is.pvol(pvol))
   expect_identical(pvol$datetime, lubridate::with_tz(time, "UTC"))