diff --git a/NAMESPACE b/NAMESPACE index 365c657c..46be60d9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,3 +8,4 @@ export(get_weather_radars) export(set_secret) importFrom(dplyr,.data) importFrom(lubridate,"%within%") +importFrom(rlang,.env) diff --git a/NEWS.md b/NEWS.md index cb81256b..628027f4 100644 --- a/NEWS.md +++ b/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). diff --git a/R/getRad-package.R b/R/getRad-package.R index 0c6cd517..7036fb97 100644 --- a/R/getRad-package.R +++ b/R/getRad-package.R @@ -3,6 +3,7 @@ ## usethis namespace: start #' @importFrom dplyr .data +#' @importFrom rlang .env #' @importFrom lubridate %within% ## usethis namespace: end NULL diff --git a/R/get_vpts.R b/R/get_vpts.R index 9b3826c0..6fc3707d 100644 --- a/R/get_vpts.R +++ b/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() diff --git a/R/get_vpts_aloft.R b/R/get_vpts_aloft.R index 32e7eb18..b41fc839 100644 --- a/R/get_vpts_aloft.R +++ b/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 ) } diff --git a/R/get_vpts_birdcast.R b/R/get_vpts_birdcast.R new file mode 100644 index 00000000..4cf428dd --- /dev/null +++ b/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 +} diff --git a/R/get_vpts_coverage.R b/R/get_vpts_coverage.R index 303aa660..e9f94851 100644 --- a/R/get_vpts_coverage.R +++ b/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. diff --git a/R/get_vpts_coverage_aloft.R b/R/get_vpts_coverage_aloft.R index 1ad43f86..6c29b96d 100644 --- a/R/get_vpts_coverage_aloft.R +++ b/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() diff --git a/R/get_vpts_coverage_birdcast.R b/R/get_vpts_coverage_birdcast.R new file mode 100644 index 00000000..208cd476 --- /dev/null +++ b/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) +} diff --git a/R/zzz.R b/R/zzz.R index c5bfef36..bd016b2f 100644 --- a/R/zzz.R +++ b/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 diff --git a/man/get_vpts.Rd b/man/get_vpts.Rd index ef77d423..23b74da8 100644 --- a/man/get_vpts.Rd +++ b/man/get_vpts.Rd @@ -7,7 +7,7 @@ get_vpts( radar, datetime, - source = c("baltrad", "uva", "ecog-04003", "rmi"), + source = c("baltrad", "uva", "ecog-04003", "rmi", "birdcast"), return_type = c("vpts", "tibble") ) } @@ -26,8 +26,8 @@ downloaded. \item A \code{\link[lubridate:interval]{lubridate::interval()}}, between which all data files are downloaded. }} -\item{source}{Source of the data. One of \code{"baltrad"}, \code{"uva"}, \code{"ecog-04003"} -or \code{"rmi"}. Only one source can be queried at a time. If not provided, +\item{source}{Source of the data. One of \code{"baltrad"}, \code{"uva"}, \code{"ecog-04003"}, +\code{"rmi"}, or \code{"birdcast"}. Only one source can be queried at a time. If not provided, \code{"baltrad"} is used. Alternatively a local directory can be specified, see details for an explanation of the file format.} @@ -101,5 +101,7 @@ get_vpts( source = "baltrad", return_type = "tibble" ) +#' Get VPTS data from the public BirdCast NEXRAD archive +get_vpts(radar = "KABR", datetime = "2023-01-01", source = "birdcast") \dontshow{\}) # examplesIf} } diff --git a/man/get_vpts_coverage.Rd b/man/get_vpts_coverage.Rd index c4ab9586..ac0d0034 100644 --- a/man/get_vpts_coverage.Rd +++ b/man/get_vpts_coverage.Rd @@ -4,11 +4,14 @@ \alias{get_vpts_coverage} \title{Get VPTS file coverage from supported sources} \usage{ -get_vpts_coverage(source = c("baltrad", "uva", "ecog-04003", "rmi"), ...) +get_vpts_coverage( + source = c("baltrad", "uva", "ecog-04003", "rmi", "birdcast"), + ... +) } \arguments{ \item{source}{Source of the data. One or more of \code{"baltrad"}, \code{"uva"}, -\code{"ecog-04003"} or \code{"rmi"}. If not provided, \code{"baltrad"} is used. +\code{"ecog-04003"} or \code{"rmi"} or \code{"birdcast"}. If not provided, \code{"baltrad"} is used. Alternatively \code{"all"} can be used if data from all sources should be returned.} diff --git a/tests/testthat/test-get_pvol_ee.R b/tests/testthat/test-get_pvol_ee.R index a89eb0d9..a8722f7a 100644 --- a/tests/testthat/test-get_pvol_ee.R +++ b/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")) diff --git a/tests/testthat/test-get_pvol_se.R b/tests/testthat/test-get_pvol_se.R index 963e67e8..0a1fd728 100644 --- a/tests/testthat/test-get_pvol_se.R +++ b/tests/testthat/test-get_pvol_se.R @@ -34,8 +34,8 @@ test_that("Pvol for Sweden can be downloaded", { test_that("Pvol for Sweden fails out of time range", { skip_if_offline("opendata-download-radar.smhi.se") + skip_if_se_not_updated("hudiksvall", Sys.time() - lubridate::hours(4)) time <- Sys.time() - lubridate::hours(40) - skip_if_se_not_updated("hudiksvall", time) expect_error( get_pvol("sehuv", time), diff --git a/tests/testthat/test-get_vpts_birdcast.R b/tests/testthat/test-get_vpts_birdcast.R new file mode 100644 index 00000000..d65fc448 --- /dev/null +++ b/tests/testthat/test-get_vpts_birdcast.R @@ -0,0 +1,132 @@ +birdcast_coverage <- tibble::tibble( + radar = "KABR", + date = as.Date(c("2013-09-01", "2013-09-02")) +) + +test_that("get_vpts_birdcast() returns error on invalid radar code", { + expect_error( + getRad:::get_vpts_birdcast( + radar = "KAB", + rounded_interval = lubridate::interval("2013-09-01", "2013-09-02"), + coverage = birdcast_coverage + ), + class = "getRad_error_radar_not_single_odim_nexrad" + ) + + expect_error( + getRad:::get_vpts_birdcast( + radar = 12345, + rounded_interval = lubridate::interval("2013-09-01", "2013-09-02"), + coverage = birdcast_coverage + ), + class = "getRad_error_radar_not_single_odim_nexrad" + ) +}) + +test_that("get_vpts_birdcast() returns error when multiple radars are queried", { + expect_error( + getRad:::get_vpts_birdcast( + radar = c("KABR", "KABX"), + rounded_interval = lubridate::interval("2013-09-01", "2013-09-02"), + coverage = birdcast_coverage + ), + class = "getRad_error_radar_not_single_odim_nexrad" + ) +}) + +test_that("get_vpts_birdcast() returns error when radar is not found in coverage", { + expect_error( + getRad:::get_vpts_birdcast( + radar = "ZZZZ", + rounded_interval = lubridate::interval("2013-09-01", "2013-09-02"), + coverage = birdcast_coverage + ), + class = "getRad_error_birdcast_radar_not_found" + ) + + expect_identical( + rlang::catch_cnd( + getRad:::get_vpts_birdcast( + radar = "ZZZZ", + rounded_interval = lubridate::interval("2013-09-01", "2013-09-02"), + coverage = birdcast_coverage + ), + classes = "getRad_error_birdcast_radar_not_found" + )$missing_radar, + "ZZZZ" + ) +}) + +test_that("get_vpts_birdcast() returns error when date is requested not in coverage", { + expect_error( + getRad:::get_vpts_birdcast( + radar = "KABR", + rounded_interval = lubridate::interval("1900-01-01", "1900-01-02"), + coverage = birdcast_coverage + ), + class = "getRad_error_date_not_found" + ) +}) + +test_that("get_vpts_birdcast() can fetch daily VPTS data from BirdCast archive", { + skip_if_offline() + + birdcast_vpts_tbl <- getRad:::get_vpts_birdcast( + radar = "KABR", + rounded_interval = lubridate::interval("2013-09-01", "2013-09-02"), + coverage = birdcast_coverage + ) + + expect_type(birdcast_vpts_tbl, "list") + expect_s3_class(birdcast_vpts_tbl, "tbl_df") + + expect_named( + birdcast_vpts_tbl, + c( + "radar", + "datetime", + "height", + "height_reference", + "u", + "v", + "w", + "ff", + "dd", + "sd_vvp", + "gap", + "eta", + "dens", + "dbz", + "dbz_all", + "n", + "n_dbz", + "n_all", + "n_dbz_all", + "rcs", + "sd_vvp_threshold", + "vcp", + "radar_latitude", + "radar_longitude", + "radar_height", + "radar_wavelength", + "source_file", + "source" + ) + ) + + expect_true(nrow(birdcast_vpts_tbl) > 0) + expect_true(all(birdcast_vpts_tbl$radar == "kabr")) + expect_true(all(birdcast_vpts_tbl$source == "birdcast")) +}) +test_that("get_vpts() can fetch daily VPTS data from BirdCast archive", { + skip_if_offline() + date <- as.Date("2026-4-1") + vpts <- getRad:::get_vpts( + radar = "KABX", + date, + source = "birdcast" + ) + expect_s3_class(vpts, "vpts") + expect_all_true(as.Date(vpts$datetime) == date) + expect_false(vpts$regular) +}) diff --git a/tests/testthat/test-get_vpts_coverage.R b/tests/testthat/test-get_vpts_coverage.R index 2c69aa9f..6e93262d 100644 --- a/tests/testthat/test-get_vpts_coverage.R +++ b/tests/testthat/test-get_vpts_coverage.R @@ -10,7 +10,7 @@ test_that("Source argument as expected", { ) }) -test_that("format as expect for aloft", { +test_that("format as expected for aloft", { skip_if_offline() data <- get_vpts_coverage("uva") @@ -19,7 +19,7 @@ test_that("format as expect for aloft", { expect_true(all(is_odim(data$radar))) }) -test_that("format as expect for rmi", { +test_that("format as expected for rmi", { skip_if_offline("opendata.meteo.be") data <- get_vpts_coverage("rmi") @@ -28,6 +28,16 @@ test_that("format as expect for rmi", { expect_true(all(is_odim(data$radar))) }) +test_that("format as expected for birdcast", { + skip_if_offline() + + data <- get_vpts_coverage("birdcast") + expect_true(all(c("source", "radar", "date") %in% names(data))) + expect_s3_class(data$date, "Date") + expect_true(all(grepl("^[A-Z0-9]{4}$", data$radar))) + expect_true(all(data$source == "birdcast")) +}) + test_that("combined retrieval works", { skip_if_offline("opendata.meteo.be") @@ -48,8 +58,9 @@ test_that("get_vpts_coverage() returns 'baltrad' as a default source", { test_that("The argument source='all' returns all data", { + all_coverage <- get_vpts_coverage(source = "all") expect_equal( - get_vpts_coverage(source = "all") |> + all_coverage |> dplyr::pull(source) |> table(), get_vpts_coverage( @@ -58,4 +69,9 @@ test_that("The argument source='all' returns all data", { dplyr::pull(source) |> table() ) + + expect_identical( + sort(unique(all_coverage$source)), + sort(eval(rlang::fn_fmls(get_vpts_coverage)$source)) + ) }) diff --git a/tests/testthat/test-get_vpts_coverage_birdcast.R b/tests/testthat/test-get_vpts_coverage_birdcast.R new file mode 100644 index 00000000..cba1559d --- /dev/null +++ b/tests/testthat/test-get_vpts_coverage_birdcast.R @@ -0,0 +1,30 @@ +test_that("get_vpts_coverage_birdcast() returns a tibble", { + skip_if_offline() + expect_s3_class( + get_vpts_coverage_birdcast(), + "tbl_df" + ) +}) + +test_that("get_vpts_coverage_birdcast() returns the expected columns", { + skip_if_offline() + + expect_named( + get_vpts_coverage_birdcast(), + c("directory", "file_count", "source", "radar", "date") + ) +}) + +test_that("get_vpts_coverage_birdcast() returns expected NEXRAD values", { + skip_if_offline() + + coverage <- get_vpts_coverage_birdcast() + + expect_all_true(coverage$source == "birdcast") + expect_s3_class(coverage$date, "Date") + expect_true(all(grepl("^[A-Z0-9]{4}$", coverage$radar))) + expect_true(all(grepl( + "^nexrad/daily/[A-Z0-9]{4}/[0-9]{4}/[0-9]{2}/[0-9]{2}$", + coverage$directory + ))) +}) diff --git a/vignettes/articles/vpts_coverage.Rmd b/vignettes/articles/vpts_coverage.Rmd index 400aa569..0c215d90 100644 --- a/vignettes/articles/vpts_coverage.Rmd +++ b/vignettes/articles/vpts_coverage.Rmd @@ -23,12 +23,91 @@ library(htmltools) ``` ```{r data} -cvr <- get_vpts_coverage(source = "all") -wr <- get_weather_radars("opera") |> +cvr <- get_vpts_coverage("all") +wr <- get_weather_radars("all") |> group_by(radar) |> arrange(status) |> slice_tail(n = 1) ``` +```{r} +# there is a with issue in the svg, here is a temporary solution: https://github.com/r-spatial/leafpop/issues/25 +assignInNamespace("popupSVGraph",function(graphs, #dsn = tempdir(), + width = 300, height = 300, ...) { + lapply(1:length(graphs), function(i) { + #nm = paste0("tmp_", i, ".svg") + #fls = file.path(dsn, nm) + + inch_wdth = width / 96 + inch_hght = height / 96 + + #svg(filename = fls, width = inch_wdth, height = inch_hght, ...) + #print(graphs[[i]]) + #dev.off() + lns <- svglite::svgstring( + width = inch_wdth, + height = inch_hght, + standalone = FALSE + ) + print(graphs[[i]]) + dev.off() + + svg_str <- lns() + + # this is a temporary solution to work around svglite + # non-specific CSS styles + # perhaps we should separate out into its own function/utility + # also adds uuid dependency + svg_id <- paste0("x",uuid::UUIDgenerate()) + svg_str <- gsub( + x = svg_str, + pattern = " + # %s + # + # " , + # width, + # height, + # svg_str + # ) + # ) + pop = sprintf( + "
%s
", + width, + height, + svg_str + ) + + popTemplate = system.file("templates/popup-graph.brew", package = "leafpop") + myCon = textConnection("outputObj", open = "w") + brew::brew(popTemplate, output = myCon) + outputObj = outputObj + close(myCon) + + return(paste(outputObj, collapse = ' ')) + + }) +} +,"leafpop") +``` ```{r} @@ -48,20 +127,21 @@ for (i in unique(cvr$source)) { years <- seq(min(cvrsub$year), max(cvrsub$year), 1) cvrsub |> group_by(radar) |> - summarize(grph = list(ggplot(data = pick(everything())) + - geom_tile(aes(x = month, y = year, fill = (n / n_max) * 100)) + - scale_fill_viridis_c("Coverage", limits = c(0, 100), breaks = (0:5) * 20, labels = paste0((0:5) * 20, " [%]"), direction = -1) + + summarize(grph = list(ggplot(data = bind_rows(expand.grid(year=years, month=month.name, n=NA, n_max=NA), pick(everything())))+ + scale_x_discrete("Month", breaks = month.name, labels = month.name, limits = month.name) + + geom_raster(aes(x = month, y = year, fill = (n / n_max) * 100)) + + scale_fill_viridis_c("Coverage", limits = c(0, 100), breaks = (0:5) * 20, labels = paste0((0:5) * 20, " [%]"), direction = -1, na.value = "#FFF0") + theme_minimal() + - scale_y_continuous("Year", breaks = years, limits = range(years) + c(-.51, .51)) + + scale_y_continuous("Year", breaks=if(length(years)<6){ years}else{pretty(years)} , limits = range(years) + c(-.51, .51)) + theme( axis.text.x = element_text(angle = -90, vjust = 0.5, hjust = 0), plot.title = element_text(hjust = 0.5), - panel.grid = element_blank() + panel.grid = element_blank(), + legend.ticks = element_blank() ) + - ggtitle(radar) + - scale_x_discrete("Month", breaks = month.name, labels = month.name, limits = month.name))) -> res - res$grph[[1]] - suppressWarnings(res |> left_join(wr, by = join_by(radar))) -> res + ggtitle(radar) )) -> res +# res$grph[[1]] + suppressWarnings(res |> left_join(wr |> select(radar, longitude, latitude), by = join_by(radar))) -> res ll <- NULL if (any(is.na(res$longitude))) { ll <- p(glue::glue("The following radars were omitted from the map because they lack location information in OPERA: {glue::glue_collapse(res$radar[is.na(res$longitude)], ', ', last = ' and ' )}.")) @@ -74,7 +154,7 @@ for (i in unique(cvr$source)) { lat = res$latitude, label = res$radar, clusterOptions = markerClusterOptions(maxClusterRadius = 30), - popup = popupGraph(res$grph) + popup = popupGraph(res$grph, type = "svg") ) html <- c(html, list(h3(i), lft, ll)) }