tests/testthat/test-get_vpts.R

In getRad: Download Radar Data for Biological Research

test_that("get_vpts() can return vpts data as a tibble or vpts object", {
  skip_if_offline()
  # Test that the function can return data as a vpts object
  ## Create vpts object to test on, but only if it doesn't exist. This way the
  ## tests can run in any order.
  returned_vpts_object <-
    get0(
      "returned_vpts_object",
      ifnotfound = get_vpts(
        radar = "depro",
        datetime = "2016-03-05",
        source = "uva",
        return_type = "vpts"
      )
    )

  returned_vpts_object_default <-
    get0(
      "returned_vpts_object_default",
      ifnotfound = get_vpts(
        radar = "depro",
        datetime = "2016-03-05",
        source = "uva"
      )
    )
  expect_s3_class(
    returned_vpts_object,
    "vpts"
  )
  expect_type(
    returned_vpts_object,
    "list"
  )
  expect_s3_class(
    returned_vpts_object_default,
    "vpts"
  )
  expect_type(
    returned_vpts_object_default,
    "list"
  )

  # Skip if the RMI can not be reached.
  skip_if_offline("opendata.meteo.be")
  returned_vpts_object_rmi <-
    get0(
      "returned_vpts_object",
      ifnotfound = get_vpts(
        radar = "bejab",
        datetime = "2020-01-19",
        source = "rmi",
        return_type = "vpts"
      )
    )

  expect_s3_class(
    returned_vpts_object_rmi,
    "vpts"
  )
  expect_type(
    returned_vpts_object_rmi,
    "list"
  )

  # Test that the function can return data as a tibble
  expect_s3_class(
    get_vpts(
      radar = "bejab",
      datetime = "2023-01-01",
      source = "baltrad",
      return_type = "tibble"
    ),
    "data.frame"
  )
})

test_that("get_vpts() returns a vpts object by default", {
  skip_if_offline()

  ## Create vpts object to test on, but only if it doesn't exist. This way the
  ## tests can run in any order.
  returned_vpts_object <-
    get0(
      "returned_vpts_object",
      ifnotfound = get_vpts(
        radar = "depro",
        datetime = "2016-03-05",
        source = "uva",
        return_type = "vpts"
      )
    )

  expect_identical(
    returned_vpts_object,
    get_vpts(
      radar = "depro",
      datetime = "2016-03-05",
      source = "uva"
    )
  )
})

test_that("get_vpts() can fetch vpts data for a single radar and time", {
  skip_if_offline()
  single_radar_single_day <-
    get_vpts(
      radar = "bejab",
      datetime = "2023-01-01",
      source = "baltrad",
      return_type = "tibble"
    )
  expect_s3_class(
    # A known radar and date combination that ALOFT has data for
    single_radar_single_day,
    "data.frame"
  )

  # Expect a known length so no rows have been accidentally filtered away
  expect_identical(
    nrow(single_radar_single_day),
    7125L
  )
})

test_that("get_vpts() can fetch vpts data for multiple radars", {
  skip_if_offline()
  multiple_radars <- get_vpts(
    radar = c("bejab", "bewid"),
    datetime = "2023-01-01",
    source = "baltrad",
    return_type = "tibble"
  )
  expect_s3_class(
    multiple_radars,
    "data.frame"
  )

  expect_contains(
    multiple_radars$radar,
    c("bejab", "bewid")
  )
})

test_that("get_vpts() can fetch data from a single radar source", {
  skip_if_offline()
  # Only data from UVA available for this radar day
  expect_identical(
    get_vpts(
      radar = "bejab",
      datetime = "2018-02-02",
      source = "uva",
      return_type = "tibble"
    )$source |>
      unique(),
    "uva"
  )
  # radar day has data both on UVA and BALTRAD
  expect_identical(
    get_vpts(
      radar = "bejab",
      datetime = "2018-05-18",
      source = "baltrad",
      return_type = "tibble"
    )$source |>
      unique(),
    "baltrad"
  )

  expect_identical(
    get_vpts(
      radar = "bejab",
      datetime = "2018-05-18",
      source = "uva",
      return_type = "tibble"
    )$source |>
      unique(),
    "uva"
  )
})

test_that("get_vpts() returns a single vpts object per radar", {
  expect_length(
    get_vpts(
      radar = c("bejab", "nldhl"),
      datetime = "2023-01-01",
      source = "baltrad"
    ),
    2L
  )
})

test_that("get_vpts() returns columns of the expected type and order", {
  skip_if_offline()

  # A helper in bioRad (validate_vpts()) that we call indirectly via
  # bioRad::as.vpts() currently doesn't support factors: bioRad v0.8.1
  expected_col_types <-
    list(
      source = "character",
      radar = "character",
      datetime = c("POSIXct", "POSIXt"),
      height = "integer",
      u = "numeric",
      v = "numeric",
      w = "numeric",
      ff = "numeric",
      dd = "numeric",
      sd_vvp = "numeric",
      gap = "logical",
      eta = "numeric",
      dens = "numeric",
      dbz = "numeric",
      dbz_all = "numeric",
      n = "integer",
      n_dbz = "integer",
      n_all = "integer",
      n_dbz_all = "integer",
      rcs = "numeric",
      sd_vvp_threshold = "numeric",
      vcp = "integer",
      radar_latitude = "numeric",
      radar_longitude = "numeric",
      radar_height = "integer",
      radar_wavelength = "numeric",
      source_file = "character"
    )

  expect_identical(
    get_vpts(
      radar = c("deflg"),
      datetime = lubridate::ymd("20171015"),
      source = "baltrad",
      return_type = "tibble"
    ) |>
      purrr::map(class),
    expected_col_types
  )

  # Specific radar causing trouble
  expect_identical(
    get_vpts(
      radar = c("dehnr"),
      datetime = lubridate::ymd("20171015"),
      source = "uva",
      return_type = "tibble"
    ) |>
      purrr::map(class),
    expected_col_types
  )
})

test_that("get_vpts() can fetch data from a specific source only", {
  skip_if_offline()

  # Data from only BALTRAD even if UVA is available for the same interval
  expect_identical(
    get_vpts(
      radar = "bejab",
      datetime = "2018-05-18",
      source = "baltrad",
      return_type = "tibble"
    ) |>
      dplyr::pull("source") |>
      unique(),
    "baltrad"
  )
})

test_that("get_vpts() can fetch vpts data for a date range", {
  skip_if_offline()

  radar_interval <- get_vpts(
    radar = "bejab",
    lubridate::interval(
      lubridate::ymd("2023-01-01"),
      lubridate::ymd("2023-01-02")
    ),
    source = "baltrad",
    return_type = "tibble"
  )
  expect_s3_class(
    radar_interval,
    "data.frame"
  )

  # Check that the requested dates are present in the output
  expect_in(
    unique(as.Date((radar_interval$datetime))),
    c(as.Date("2023-01-01"), as.Date("2023-01-02"))
  )
})

test_that("get_vpts() returns data for a whole day if datetime has no time", {
  skip_if_offline()
  single_radar_single_day <-
    get_vpts(
      radar = "bejab",
      datetime = "2023-01-01",
      source = "baltrad",
      return_type = "tibble"
    )

  days_returned <-
    dplyr::pull(single_radar_single_day, dplyr::all_of("datetime")) |>
    lubridate::floor_date(unit = "days") |>
    unique()

  expect_length(
    days_returned,
    1L
  )
})

test_that("get_vpts() returns data for the interval provided only", {
  skip_if_offline()
  ## Define an interval to fetch data for
  int_start <- lubridate::ymd_hms("2024-10-21 14:22:11")
  int_end <- lubridate::ymd_hms("2024-10-21 15:23:07")

  radar_interval_hhmmss <- get_vpts(
    radar = "seoer",
    lubridate::interval(int_start, int_end),
    source = "baltrad",
    return_type = "tibble"
  )

  ## The function should always round the timestamps down, this causes the least
  ## surprise
  ### get the measuring frequency (select the most common one)
  update_freq <-
    dplyr::distinct(radar_interval_hhmmss, datetime) |>
    dplyr::pull(dplyr::all_of("datetime")) |>
    diff() |>
    mean() |>
    as.numeric(units = "mins")

  expect_identical(
    min(radar_interval_hhmmss$datetime),
    lubridate::ceiling_date(int_start, unit = paste(update_freq, "minutes"))
  )

  expect_identical(
    max(radar_interval_hhmmss$datetime),
    lubridate::floor_date(int_end, unit = paste(update_freq, "minutes"))
  )
})

test_that("get_vpts() supports POSIXct dates", {
  skip_if_offline()

  radar_interval <- get_vpts(
    radar = "nlhrw",
    datetime = as.POSIXct("2025-05-07 14:53:37", tz = "Europe/Berlin"),
    return_type = "tibble"
  )

  expect_s3_class(
    radar_interval,
    "data.frame"
  )

  # Check that the requested dates are present in the output
  expect_in(
    unique(as.Date((radar_interval$datetime))),
    as.Date("2025-05-07")
  )
})

test_that("get_vpts() only returns the data for the requested day", {
  # Check bug where one extra day of data was returned due to rounding error

  radar_interval <- get_vpts(
    radar = "nlhrw",
    datetime = t <- as.POSIXct("2025-04-10 13:45:04", tz = "Europe/Berlin"),
    return_type = "tibble"
  )

  expect_equal(
    unique(radar_interval$datetime),
    lubridate::with_tz(t, "UTC")
  )
})

test_that("get_vpts() supports date intervals with hours and minutes", {
  skip_if_offline()

  hour_minute_interval <-
    get_vpts(
      radar = "bejab",
      lubridate::interval(
        lubridate::ymd_hms("2023-01-01 12:00:00"),
        lubridate::ymd_hms("2023-01-01 16:59:59")
      ),
      source = "baltrad",
      return_type = "tibble"
    )

  expect_s3_class(
    hour_minute_interval,
    "data.frame"
  )

  # The minimum returned date should be within the interval
  expect_gte(
    min(hour_minute_interval$datetime),
    lubridate::ymd_hms("2023-01-01 12:00:00")
  )
  # The maximum returned datetime should be within the interval
  expect_lte(
    max(hour_minute_interval$datetime),
    lubridate::ymd_hms("2023-01-01 16:59:59")
  )

  # The maximum should actually be rounded by a 15 minute interval
  expect_identical(
    max(hour_minute_interval$datetime),
    lubridate::ymd_hms("2023-01-01 16:45:00")
  )
})

test_that("get_vpts() can return data as a vpts object compatible with getRad", {
  skip_if_offline()
  skip_on_os("windows") # Does this test cause the Windows CI to timeout?

  ## Create vpts object to test on, but only if it doesn't exist. This way the
  ## tests can run in any order.
  returned_vpts_object <-
    get0(
      "returned_vpts_object",
      ifnotfound = get_vpts(
        radar = "depro",
        datetime = "2016-03-05",
        source = "uva",
        return_type = "vpts"
      )
    )

  # Array of combinations that exposed bugs in the past
  expect_identical(
    list(
      radar = list("bejab", "depro", "bejab", "bejab"),
      datetime = list(
        "2018-05-18",
        "2016-03-05",
        "2018-05-31",
        lubridate::interval("2018-05-31 18:00:00", "2018-06-01 02:00:00")
      ),
      source = list("baltrad", "uva", "baltrad", "baltrad")
    ) |>
      purrr::pmap(get_vpts) |>
      purrr::map_chr(class),
    c("vpts", "vpts", "vpts", "vpts")
  )

  # The returned object should be identical as if created via bioRad
  expect_identical(
    get_vpts(
      radar = "depro",
      datetime = "2016-03-05",
      source = "uva",
      return_type = "tibble"
    ) |>
      dplyr::select(-source) |>
      bioRad::as.vpts(),
    returned_vpts_object
  )
  # This also works when multiple radars are selected
  ## In this case a list of vpts objects should be returned
  expect_type(
    get_vpts(
      radar = c("depro", "bejab"),
      datetime = "2016-03-05",
      source = "uva"
    ),
    "list"
  )

  expect_identical(
    get_vpts(
      radar = c("depro", "bejab"),
      datetime = "2016-03-05",
      source = "uva"
    ) |>
      purrr::map_chr(class) |>
      unname(), # only test for class, names are tested elsewhere
    c("vpts", "vpts")
  )

  ## This list should be named the same as the requested radars
  requested_radars <- c("depro", "bejab")
  expect_named(
    get_vpts(
      radar = c("depro", "bejab"),
      datetime = "2016-03-05",
      source = "uva",
      return_type = "vpts"
    ),
    requested_radars
  )

  ## The named child objects should correspond to the correct vpts objects (bug)
  expect_identical(
    get_vpts(
      radar = c("depro", "bejab"),
      datetime = "2016-03-05",
      source = "uva",
      return_type = "vpts"
    ) |>
      purrr::chuck("bejab"),
    get_vpts(
      radar = "bejab",
      datetime = "2016-03-05",
      source = "uva",
      return_type = "vpts"
    )
  )

  # Radar day where vpts objects on aloft have 3 different values for the radar
  # column, script should have all convert them to the same odim value
  expect_identical(
    purrr::chuck(get_vpts("bejab", "2018-05-18", "baltrad"), "radar"),
    "bejab"
  )
  expect_identical(
    get_vpts("bejab", "2018-05-18", "baltrad", return_type = "tibble") |>
      dplyr::pull(.data$radar) |>
      unique(),
    "bejab"
  )
})

test_that("get_vpts() returns an error when multiple sources are provided", {
  skip_if_offline()

  expect_error(
    get_vpts(
      radar = "bejab",
      datetime = "2018-05-18",
      source = c("baltrad", "uva")
    ),
    class = "getRad_error_multiple_sources"
  )
})

test_that("get_vpts() returns an error when an invalid source is provided", {
  expect_error(
    get_vpts("bejab", "20241118", "not a source"),
    class = "getRad_error_source_invalid"
  )

  expect_error(
    get_vpts("bejab", "20241118", "baltradz"),
    class = "getRad_error_source_invalid"
  )
})

test_that("get_vpts() uses baltrad if no source is provided", {
  expect_identical(
    unique(get_vpts("bejab", "20180525", return_type = "tibble")$source),
    "baltrad"
  )
})

test_that("get_vpts() returns an error if NULL is passed as a source", {
  expect_error(
    get_vpts("bejab", "20180525", source = NULL),
    class = "getRad_error_source_missing"
  )
})

test_that("get_vpts() returns an error for a bad radar", {
  skip_if_offline()

  # Radar not found in ALOFT coverage
  expect_error(
    get_vpts(
      radar = "aaaaa",
      datetime = "2023-01-01",
      source = "uva"
    ),
    class = "getRad_error_aloft_radar_not_found"
  )

  # Radar is not a character vector
  expect_error(
    get_vpts(radar = 1:3, datetime = "2023-01-01", source = "uva"),
    class = "getRad_error_radar_not_character"
  )
})

test_that("get_vpts() returns an error for a bad time argument", {
  skip_if_offline()

  # Date not found in ALOFT coverage
  expect_error(
    get_vpts(radar = "bejab", datetime = "9000-01-02", source = "baltrad"),
    class = "getRad_error_date_not_found"
  )
  # Time is not parsable to a date or interval
  expect_error(
    get_vpts(radar = "bejab", datetime = 1:3, source = "baltrad"),
    class = "getRad_error_date_parsable"
  )
})
test_that("`get_vpts` is tz insensitive", {
  t <- as.POSIXct("2025-1-3 1:00:00", tz = "CET")
  tUtc <- lubridate::with_tz(t, "UTC")
  expect_identical(
    get_vpts("nlhrw", lubridate::as.interval(t, t + lubridate::minutes(30))),
    get_vpts("nlhrw", lubridate::as.interval(tUtc, tUtc + lubridate::minutes(30)))
  )
})

test_that("`get_vpts` for a single time gets closest nominal time", {
  t <- as.POSIXct("2025-1-3 1:00:00", tz = "CET")
  expect_identical(
    get_vpts("nlhrw", t),
    get_vpts("nlhrw", t + lubridate::seconds(123))
  )
  expect_identical(
    get_vpts("nlhrw", t + lubridate::seconds(4)),
    get_vpts("nlhrw", t + lubridate::seconds(123))
  )
})