Merge pull request #26 from pepijn-devries/work-in-progress

Work in progress

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: CopernicusMarine
 Type: Package
 Title: Search Download and Handle Data from Copernicus Marine Service Information
-Version: 0.1.3
-Date: 2023-11-09
+Version: 0.2.0
+Date: 2024-01-01
 Authors@R: c(person("Pepijn", "de Vries", role = c("aut", "cre", "dtc"),
     email = "[email protected]",
     comment = c(ORCID = "0000-0002-7961-6646")))
@@ -22,13 +22,16 @@ Imports:
     leaflet,
     purrr,
     readr,
+    rlang,
     rvest,
     sf,
     stringr,
+    tidyr,
     utils,
     xml2
 Suggests:
     lifecycle,
+    ncmeta,
     stars,
     testthat (>= 3.0.0)
 URL: https://github.com/pepijn-devries/CopernicusMarine
@@ -39,3 +42,26 @@ LazyData: true
 RoxygenNote: 7.2.3
 Config/testthat/edition: 3
 Roxygen: list(markdown = TRUE)
+Collate: 
+    'CopernicusMarine-package.r'
+    'cms_cite_product.r'
+    'cms_download_stac.r'
+    'cms_login.r'
+    'cms_download_subset.r'
+    'cms_list_stac_files.r'
+    'cms_product_details.r'
+    'cms_product_metadata.r'
+    'cms_product_services.r'
+    'cms_products_list.r'
+    'cms_stac_properties.r'
+    'cms_wmts.r'
+    'copernicus_cite_product.r'
+    'copernicus_download_motu.r'
+    'copernicus_login.r'
+    'copernicus_product_details.r'
+    'copernicus_product_metadata.r'
+    'copernicus_products_list.r'
+    'ftp.r'
+    'generics.r'
+    'import.r'
+    'wms.r'

NAMESPACE

@@ -1,6 +1,19 @@
 # Generated by roxygen2: do not edit by hand
 
+export(addCmsWMTSTiles)
 export(addCopernicusWMSTiles)
+export(cms_cite_product)
+export(cms_download_stac)
+export(cms_download_subset)
+export(cms_list_stac_files)
+export(cms_login)
+export(cms_product_details)
+export(cms_product_metadata)
+export(cms_product_services)
+export(cms_products_list)
+export(cms_stac_properties)
+export(cms_wmts_details)
+export(cms_wmts_get_capabilities)
 export(copernicus_cite_product)
 export(copernicus_download_motu)
 export(copernicus_ftp_get)
@@ -12,3 +25,5 @@ export(copernicus_product_services)
 export(copernicus_products_list)
 export(copernicus_wms2geotiff)
 export(copernicus_wms_details)
+importFrom(rlang,.data)
+importFrom(rlang,`:=`)

NEWS.md

@@ -1,6 +1,9 @@
-CopernicusMarine v0.1.3 (Release date: 2023-12-24)
+CopernicusMarine v0.2.0 (Release date: 2024-01-01)
 -------------
 
+ * Added functions for new services (subset, STAC and WMTS)
+ * Added warnings to functions interacting with
+   deprecated Copernicus Marine services.
  * Added login function
  * Switched from `httr` to `httr2` dependency
  * Switch from `magrittr`'s pipe to R's native pipe operator

R/cms_cite_product.r

@@ -0,0 +1,28 @@
+#' How to cite a Copernicus marine product
+#'
+#' `r lifecycle::badge('stable')` Get details for properly citing a Copernicus product.
+#'
+#' @inheritParams cms_download_subset
+#' @returns Returns a vector of character strings. The first element is always the product title, id and doi.
+#' Remaining elements are other associated references. Note that the remaining references are returned as
+#' listed at Copernicus. Note that the citing formatting does not appear to be standardised.
+#' @rdname cms_cite_product
+#' @name cms_cite_product
+#' @family product-functions
+#' @examples
+#' \donttest{
+#' cms_cite_product("SST_MED_PHY_SUBSKIN_L4_NRT_010_036")
+#' }
+#' @author Pepijn de Vries
+#' @export
+cms_cite_product <- function(product) {
+  product_details <- cms_product_details(product)
+  if (is.null(product_details)) return(NULL)
+  result <- product_details$refs
+  result <- c(
+    doi = with(
+      product_details,
+      sprintf("E.U. Copernicus Marine Service Information; %s - %s (%s). DOI:%s",
+              title, id, creationDate, doi)), result)
+  return(result)
+}

R/cms_download_stac.r

@@ -0,0 +1,71 @@
+#' List and get STAC files for a Copernicus marine product
+#'
+#' `r lifecycle::badge('stable')` Full marine data sets can be downloaded using the
+#' SpatioTemporal Asset Catalogs (STAC). Use these functions to list download locations and get
+#' the files.
+#' @inheritParams cms_download_subset
+#' @param file_tibble A [`dplyr::tibble()`] with in each row the files to be downloaded.
+#' Should be created with [`cms_list_stac_files()`].
+#' @param destination A `character` string representing the path location where the downloaded
+#' files should be stored.
+#' @param show_progress A `logical` value. When `TRUE` (default) the download progress will be shown.
+#' This can be useful for large files.
+#' @returns In case of `cms_stac_properties` a [`dplyr::tibble()`] is returned with some
+#' product properties, It is used as precursor for `cms_list_stac_files`.
+#' In case of `cms_list_stac_files` a [`dplyr::tibble()`] is returned containing
+#' available URLs (for the specified `product` and `layer`) and some meta information is returned.
+#' In case of `cms_download_stac` an invisible `logical` value is returned, indicating whether
+#' all requested files are successfully stored at the `destination` path. A `list` of responses
+#' (of class [`httr2::response()`]) for all requested download links is included as attribute
+#' to the result.
+#' @rdname cms_stac
+#' @name cms_download_stac
+#' @examples
+#' \dontrun{
+#' ## List some STAC properties for a specific product and layer
+#' cms_stac_properties(
+#'   product       = "GLOBAL_ANALYSISFORECAST_PHY_001_024",
+#'   layer         = "cmems_mod_glo_phy-cur_anfc_0.083deg_P1D-m"
+#' )
+#' 
+#' ## Get the available files for a specific product and layer:
+#' file_tibble <-
+#'   cms_list_stac_files("GLOBAL_ANALYSISFORECAST_PHY_001_024",
+#'                       "cmems_mod_glo_phy-cur_anfc_0.083deg_P1D-m")
+#'
+#' dest <- tempdir()
+#'
+#' ## download the first file from the file_tibble to 'dest'
+#' cms_download_stac(file_tibble[1,, drop = FALSE], dest)
+#' }
+#' @family stac-functions download-functions
+#' @author Pepijn de Vries
+#' @export
+cms_download_stac <- function(file_tibble, destination, show_progress = TRUE, overwrite = FALSE) {
+  if (!dir.exists(destination))
+    stop(sprintf("The path '%s' is not an existing directory", destination))
+  result <- TRUE
+  responses <- lapply(seq_len(nrow(file_tibble)), function(i) {
+    dest <- file.path(destination, basename(file_tibble$current_path[[i]]))
+    if (!overwrite && file.exists(dest))
+      stop(sprintf("File '%s' already exists! Use `overwrite=TRUE` to proceed", dest))
+    resp <- .try_online({
+      req <-
+        paste(
+          "https:/",
+          file_tibble$home[[i]],
+          file_tibble$native[[i]],
+          file_tibble$current_path[[i]],
+          sep = "/"
+        ) |>
+        httr2::request()
+      if (show_progress) req <- req |> httr2::req_progress()
+      req |>
+        httr2::req_perform(path = dest)
+    }, "stac-download")
+    if (is.null(resp)) result <- FALSE
+    resp
+  })
+  attr(result, "responses") <- responses
+  return(invisible(result))
+}

R/cms_download_subset.r

@@ -0,0 +1,144 @@
+#' Subset and download a specific marine product from Copernicus
+#'
+#' `r lifecycle::badge('stable')` Subset and download a specific marine product from Copernicus.
+#' You need to register an account
+#' at <https://data.marine.copernicus.eu> before you can use this function.
+#'
+#' @include cms_login.r
+#' @inheritParams cms_login
+#' @param destination File or path where the requested file will be downloaded to.
+#' @param product An identifier (type `character`) of the desired Copernicus marine product.
+#' Can be obtained with [`cms_products_list`].
+#' @param layer The name of a desired layer within a product (type `character`). Can be obtained with [`cms_product_details`].
+#' @param variable The name of a desired variable in a specific layer of a product (type `character`).
+#' Can be obtained with [`copernicus_product_details`].
+#' @param region Specification of the bounding box as a `vector` of `numeric`s WGS84 lat and lon coordinates.
+#' Should be in the order of: xmin, ymin, xmax, ymax.
+#' @param timerange A `vector` with two elements (lower and upper value)
+#' for a requested time range. The `vector` should be coercible to `POSIXct`.
+#' @param verticalrange A `vector` with two elements (minimum and maximum)
+#' numerical values for the depth of the vertical layers (if any).
+#' @param overwrite A `logical` value. When `FALSE` (default), files at the `destination` won't be
+#' overwritten when the exist. Instead an error will be thrown if this is the case. When set to
+#' `TRUE`, existing files will be overwritten.
+#' @returns Returns a `logical` value invisibly indicating whether the requested file was
+#' successfully stored at the `destination`.
+#' @rdname cms_download_subset
+#' @name cms_download_subset
+#' @examples
+#' \dontrun{
+#' destination <- tempfile("copernicus", fileext = ".nc")
+#'
+#' ## Assuming that Copernicus account details are provided as `options`
+#' cms_download_subset(
+#'   destination   = destination,
+#'   product       = "GLOBAL_ANALYSISFORECAST_PHY_001_024",
+#'   layer         = "cmems_mod_glo_phy-cur_anfc_0.083deg_P1D-m",
+#'   variable      = "sea_water_velocity",
+#'   region        = c(-1, 50, 10, 55),
+#'   timerange     = c("2021-01-01 UTC", "2021-01-02 UTC"),
+#'   verticalrange = c(0, 2)
+#' )
+#' 
+#' mydata <- stars::read_stars(destination)
+#' 
+#' plot(mydata["vo"])
+#' }
+#' @author Pepijn de Vries
+#' @export
+cms_download_subset <- function(
+    username = getOption("CopernicusMarine_uid", ""),
+    password = getOption("CopernicusMarine_pwd", ""),
+    destination,
+    product,
+    layer,
+    variable,
+    region,
+    timerange,
+    verticalrange,
+    overwrite = FALSE) {
+
+  if (!overwrite & file.exists(destination))
+    stop("Destination file already exists. Set 'overwrite' to TRUE to proceed.")
+
+  base_url <- "https://data-be-prd.marine.copernicus.eu/api/download/"
+
+  message(crayon::white("Preparing job..."))
+
+  details <- cms_product_details(product, layer, variant = "detailed-v2")
+
+  var_check1 <- names(details) %in% paste0(layer, "/", variable)
+  var_check2 <- !(paste0(layer, "/", variable) %in% names(details))
+  variable <- c(
+    lapply(details[var_check1], `[[`, "subsetVariableIds") |> unlist() |> unname(),
+    variable[var_check2]
+  ) |> unique()
+
+  payload <- c("lonMin", "latMin", "lonMax", "latMax", "timeMin", "timeMax",
+               "elevationMin", "elevationMax", "extraVariableIds")
+  payload <- list(
+    datasetId    = product,
+    subdatasetId = layer,
+    variableIds  = variable,
+    subsetValues = structure(purrr::map(seq_along(payload),
+                                        ~structure(list(), names = character(0))),
+                             names = payload))
+  payload[["subsetValues"]][["extraVariableIds"]] <- variable
+
+  if (!missing(region)) {
+    payload[["subsetValues"]][["lonMin"]] <- region[[1]]
+    payload[["subsetValues"]][["latMin"]] <- region[[2]]
+    payload[["subsetValues"]][["lonMax"]] <- region[[3]]
+    payload[["subsetValues"]][["latMax"]] <- region[[4]]
+  }
+  if (!missing(timerange)) {
+    timerange <- timerange |>
+      as.POSIXct(tz = "UTC") |>
+      as.numeric(origin = "1970-01-01 UTC")*1000
+    payload[["subsetValues"]][["timeMin"]] <- timerange[[1]]
+    payload[["subsetValues"]][["timeMax"]] <- timerange[[2]]
+  }
+  if (!missing(verticalrange)) {
+    payload[["subsetValues"]][["elevationMin"]] <- verticalrange[[1]]
+    payload[["subsetValues"]][["elevationMax"]] <- verticalrange[[2]]
+  }
+
+  job <-
+    .try_online({
+      base_url |>
+        httr2::request() |>
+        httr2::req_auth_basic(username, password) |>
+        httr2::req_body_json(payload) |>
+        httr2::req_perform()
+    }, "subset-job")
+  if (is.null(job)) return(invisible(FALSE))
+  job <- httr2::resp_body_json(job)
+
+  message(crayon::white("Waiting for job to finish..."))
+  repeat {
+    job_check <-
+      .try_online({
+        base_url |>
+          paste0(job$jobId) |>
+          httr2::request() |>
+          httr2::req_perform()
+      }, "job-check")
+    if (is.null(job_check)) return(invisible(FALSE))
+    job_check <- httr2::resp_body_json(job_check)
+
+    if (job_check$finished) break
+    Sys.sleep(0.5)
+  }
+
+  message(crayon::white("Downloading file..."))
+  download <-
+    .try_online({
+      job_check$url |>
+        httr2::request() |>
+        httr2::req_perform(destination)
+    }, "subset-download")
+  if (is.null(download)) return(invisible(FALSE))
+
+  message(crayon::green("Done"))
+  return(invisible(TRUE))
+}