Add dark ecology support to read_vpts()

.Rbuildignore

@@ -13,3 +13,4 @@
 ^CRAN-SUBMISSION$
 ^[.]?air[.]toml$
 ^\.vscode$
+^inst/extdata/darkecology$

DESCRIPTION

@@ -49,6 +49,7 @@ Imports:
     xml2
 Suggests:
     askpass,
+    fs,
     htmltools,
     keyring,
     knitr,

NEWS.md

@@ -1,7 +1,8 @@
 # getRad (development version)
 
 * Implement download of `vpts` data from birdcast by Alexander Tedeschi. 
-* Implement reading `vpts` data from a local directory (#135).
+* Implement reading aloft `vpts` data from a local directory (#135).
+* Implement reading dark ecology `vpts` data from a local directory (#175).
 * Clarify HTTP 429 error for the Netherlands (#165).
 * Clarify error for Estonia and propagate call (#173).
 * Include the hochficht radar in Austria (#169).

R/get_vpts.R

@@ -7,10 +7,10 @@
 #' @details
 #' For more details on supported sources, see `vignette("supported_sources")`.
 #'
-#'   In that case data is read from the directory, file in the directory
+#'   In case data is read from a directory, file in the directory
 #'   should be structures like they are in the monthly folders of the aloft
 #'   repository. To specify an alternative structure the
-#'   `"getRad.vpts_local_path_format"` option can be used. This can, for
+#'   `"getRad.vpts_local_path_format_aloft"` option can be used. This can, for
 #'   example, be used to read daily data. Some example options for the glue
 #'   formatters are:
 #'
@@ -22,7 +22,13 @@
 #'  * `"{radar}/{year}/{radar}_vpts_{year}{month}{day}.csv"`: The format as daily
 #'  data is stored in aloft data
 #'
-#'  Besides the examples above there is a `date` object available for formatting.
+#'  A similar option (`"getRad.vpts_local_path_format_aloft"`) exist for reading
+#'  dark ecology data. The default value here is `"getRad.vpts_local_path_format_aloft"`.
+#'  Here the option does refer to the directories where the dark ecology files
+#'  should be searched.
+#'
+#'  Besides the examples above there is a `date` object available for formatting. Note
+#'  that `day` and `month` are zero padded character strings in the glue formating.
 #'
 #' @inheritParams get_pvol
 #' @inherit get_vpts_aloft details
@@ -35,12 +41,14 @@
 #'   downloaded.
 #'   - A [lubridate::interval()], between which all data files are downloaded.
 #' @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.
+#'   `"rmi"`, `"dark_ecology"` or `"birdcast"`. Only one source can be queried at a time. If not provided,
+#'   `"baltrad"` is used.
 #' @param return_type Type of object that should be returned. Either:
 #'   - `"vpts"`: vpts object(s) (default).
 #'   - `"tibble"`: a [dplyr::tibble()].
+#' @param ... Optional arguments, to [bioRad::read_cajun()] when reading `"dark_ecology"` data.
+#' @param path A local directory where data are read from. If specified the file structure
+#'  is taken from the `source` argument. See details for an explanation of the file format.
 #' @return Either a vpts object, a list of vpts objects or a tibble. See
 #'   [bioRad::summary.vpts] for details.
 #' @export
@@ -82,8 +90,10 @@
 get_vpts <- function(
   radar,
   datetime,
-  source = c("baltrad", "uva", "ecog-04003", "rmi", "birdcast"),
-  return_type = c("vpts", "tibble")
+  source = c("baltrad", "uva", "ecog-04003", "rmi", "birdcast", "dark_ecology"),
+  return_type = c("vpts", "tibble"),
+  ...,
+  path = NULL
 ) {
   # Input checks ----
   # Check source argument
@@ -119,11 +129,11 @@ get_vpts <- function(
   # Get the default value of the source arg, even if the user provided
   # a different value.
   supported_sources <- eval(formals()$source)
-  if (!(source %in% supported_sources | dir.exists(source))) {
+  if (!(source %in% supported_sources)) {
     cli::cli_abort(
       c(
         "{.arg source} {.val {source}} is invalid.",
-        "i" = "Supported sources: {.val {supported_sources}} or a local directory."
+        "i" = "Supported sources: {.val {supported_sources}}."
       ),
       class = "getRad_error_source_invalid"
     )
@@ -208,43 +218,76 @@ get_vpts <- function(
   # Directing to the correct get_vpts_* helper based on source.
   cl <- rlang::caller_env(0)
 
-  aloft_sources <- eval(formals("get_vpts_aloft")$source)
+  ## Split of local path (here we know there is a single valid source argument)
+  if (!missing(path)) {
+    fetched_vpts <- get_vpts_local(
+      radar = radar,
+      rounded_interval = rounded_interval,
+      source = source,
+      path = path,
+      ...
+    )
+  } else {
+    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"
-  )
+    source_type <- dplyr::case_when(
+      source == "rmi" ~ "rmi",
+      source == "birdcast" ~ "birdcast",
+      source %in% aloft_sources ~ "aloft"
+    )
 
-  fetched_vpts <-
-    switch(
-      source_type,
-      rmi = purrr::map(
-        radar,
-        ~ get_vpts_rmi(.x, rounded_interval),
-        .purrr_error_call = cl
-      ),
-      aloft = purrr::map(
-        radar,
-        ~ get_vpts_aloft(
-          .x,
-          rounded_interval = rounded_interval,
-          source = source
+    fetched_vpts <-
+      switch(
+        source_type,
+        rmi = purrr::map(
+          radar,
+          ~ get_vpts_rmi(.x, rounded_interval),
+          .purrr_error_call = cl
         ),
-        .purrr_error_call = cl
-      ),
-      birdcast = purrr::map(
-        radar,
-        ~ get_vpts_birdcast(
-          .x,
-          rounded_interval = rounded_interval
+        aloft = purrr::map(
+          radar,
+          ~ get_vpts_aloft(
+            .x,
+            rounded_interval = rounded_interval,
+            source = source
+          ),
+          .purrr_error_call = cl
         ),
-        .purrr_error_call = cl
-      ),
-      local = get_vpts_local(radar, rounded_interval, directory = source)
-    ) |>
-    radar_to_name()
+        birdcast = purrr::map(
+          radar,
+          ~ get_vpts_birdcast(
+            .x,
+            rounded_interval = rounded_interval
+          ),
+          .purrr_error_call = cl
+        )
+      ) |>
+      radar_to_name()
+  }
+  # Return the vpts data ----
+  ## By default, return drop the source column and convert to a vpts object for
+  ## usage in bioRad
+  return_type <- rlang::arg_match(return_type)
+
+  # dark ecology local now only returns vpts
+  if (any(purrr::map_lgl(fetched_vpts, inherits, "vpts"))) {
+    if (return_type != "vpts") {
+      cli::cli_abort(
+        "For the {.arg source} {.val {source}} the {.arg return_type} {.val {return_type}} is
+                           currently not supported. Only a {.cls vpts} can be returned.",
+        class = "getRad_error_vpts_not_supported_return_type"
+      )
+    }
+    fetched_vpts <- purrr::map(
+      fetched_vpts,
+      ~ .x[lubridate::`%within%`(.x$datetime, date_interval)]
+    )
+    if (length(fetched_vpts) != 1) {
+      return(fetched_vpts)
+    } else {
+      return(purrr::chuck(fetched_vpts, 1))
+    }
+  }
 
   # Drop any results outside the requested interval ----
   filtered_vpts <-
@@ -264,10 +307,6 @@ get_vpts <- function(
       },
       .purrr_error_call = cl
     )
-  # Return the vpts data ----
-  ## By default, return drop the source column and convert to a vpts object for
-  ## usage in bioRAD
-  return_type <- rlang::arg_match(return_type)
   ## Depending on the value of the `return_type` argument, do some final
   ## formatting or conversion
   return_object <-

R/get_vpts_local.R

@@ -1,73 +1,66 @@
+#' A function to split out calls to internal functions for
+#' reading data from local paths
+#' @noRd
 get_vpts_local <- function(
   radar,
   rounded_interval,
-  directory,
+  source,
+  path,
   ...,
   call = rlang::caller_env()
 ) {
-  dates <- as.Date(seq(
-    lubridate::int_start(rounded_interval),
-    lubridate::int_end(rounded_interval),
-    "day"
-  ))
-  file_paths_list <- radar |>
-    purrr::map(
-      ~ unique(glue::glue(
-        getOption(
-          "getRad.vpts_local_path_format",
-          default = "{radar}/{year}/{radar}_vpts_{year}{month}.csv.gz"
-        ),
-        radar = .x,
-        year = lubridate::year(dates),
-        month = sprintf("%02i", lubridate::month(dates)),
-        day = sprintf("%02i", lubridate::day(dates)),
-        date = dates
-      ))
-    ) |>
-    purrr::set_names(radar)
-  # `full_paths_list` is a list of file paths per radar, so that one vpts per radar is calculated
-  full_paths_list <- purrr::map(file_paths_list, ~ file.path(directory, .x))
-  full_paths_exist_list <- purrr::map(full_paths_list, file.exists)
-  if (all(!unlist(full_paths_exist_list))) {
+  # Allow only one directory to be provided
+  if (length(path) > 1) {
     cli::cli_abort(
-      c(
-        x = "None of the expected files are in the source directory ({.file {directory}}).",
-        i = "The following files were expected: {.file {unlist(full_paths_list)}}."
-      ),
-      class = "getRad_error_files_not_in_source_dir",
+      "Only one directory can be provided, but {length(path)} were given.",
+      class = "getRad_error_vpts_local_multiple_directories",
       call = call
     )
   }
-  if (any(!unlist(full_paths_exist_list))) {
-    missing_files <- unlist(purrr::map2(
-      full_paths_list,
-      full_paths_exist_list,
-      ~ .x[!.y]
-    ))
-    cli::cli_warn(
+  if (!rlang::is_character(path)) {
+    cli::cli_abort(
+      "The specified path should be a character.",
+      class = "getRad_error_vpts_local_not_character",
+      call = call
+    )
+  }
+  if (!dir.exists(path)) {
+    cli::cli_abort(
       c(
-        x = "Some of the expected files are in the source directory ({.file {directory}}).",
-        i = "The following files were expected but not found: {.file {missing_files}}.",
-        i = "These files are considered missing data and therefore omitted from the results."
+        x = "The provide path ({.file {path}}), is not a valid directory.",
+        i = "Please make sure the directory exist."
       ),
-      missing_files = missing_files,
-      class = "getRad_warning_some_files_not_in_source_dir",
+      class = "getRad_error_path_not_a_dir",
       call = call
     )
   }
-  any_file <- purrr::map_lgl(full_paths_exist_list, any)
-  purrr::map2(
-    full_paths_list[any_file],
-    full_paths_exist_list[any_file],
-    ~ vroom::vroom(
-      .x[.y],
-      col_types = getOption(
-        "getRad.vpts_col_types"
-      ),
-      show_col_types = NULL,
-      progress = FALSE
-    ) |>
-      tibble::add_column(source = directory) |>
-      dplyr::mutate(dplyr::across("radar", as.character))
+  # Check that the provided directory exists
+  if (!is_readable(path)) {
+    cli::cli_abort(
+      "The provided directory does is not readable: {path}",
+      class = "getRad_error_vpts_directory_not_readable",
+      call = call
+    )
+  }
+
+  fun <- (dplyr::case_when(
+    source %in% c(c("baltrad", "uva", "ecog-04003")) ~ "get_vpts_local_aloft",
+    source == "dark_ecology" ~ "get_vpts_local_dark_ecology",
+    .default = NA
+  ))
+  if (rlang::is_na(fun)) {
+    cli::cli_abort(
+      "No suitable function exist to read local data for this source ({.val {source}}).",
+      class = "getRad_error_no_function_for_reading_local_source",
+      call = call
+    )
+  }
+  rlang::exec(
+    fun,
+    radar = radar,
+    rounded_interval = rounded_interval,
+    path = path,
+    ...,
+    call = call
   )
 }