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

Work in progress

.Rbuildignore

@@ -2,3 +2,4 @@
 ^\.Rproj\.user$
 ^README\.Rmd$
 ^LICENSE\.md$
+man-roxygen

CopernicusMarine.Rproj

@@ -15,4 +15,5 @@ LaTeX: pdfLaTeX
 BuildType: Package
 PackageUseDevtools: Yes
 PackageInstallArgs: --no-multiarch --with-keep.source
+PackageCheckArgs: --as-cran
 PackageRoxygenize: rd,collate,namespace

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: CopernicusMarine
 Type: Package
 Title: Search Download and Handle Data from Copernicus Marine Service Information
-Version: 0.0.3
-Date: 2023-01-17
+Version: 0.0.6
+Date: 2023-01-23
 Authors@R: c(person("Pepijn", "de Vries", role = c("aut", "cre", "dtc"),
     email = "[email protected]",
     comment = c(ORCID = "0000-0002-7961-6646")))

NEWS.md

@@ -1,4 +1,14 @@
-CopernicusMarine v0.02 (Release date: 2023-01-16)
+CopernicusMarine v0.0.6 (Release date: 2023-01-23)
+-------------
+
+  * Fix in tests in order to comply with CRAN
+    policy
+  * Catch and handle errors and warnings when connecting
+    with internet resources and return gracefully
+  * Update documentation on GDAL utils dependency
+    in WMS functions
+
+CopernicusMarine v0.0.3 (Release date: 2023-01-16)
 -------------
 
   * Initial implementation features data imports via:

R/copernicus_cite_product.r

@@ -3,7 +3,7 @@
 #' `r lifecycle::badge('stable')` Get details for properly citing a Copernicus product.
 #'
 #' @inheritParams copernicus_download_motu
-#' @return Returns a list of character strings. The first element is always the product title, id and doi.
+#' @return 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 copernicus_cite_product
@@ -17,6 +17,7 @@
 #' @export
 copernicus_cite_product <- function(product) {
   product_details <- copernicus_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)

R/copernicus_download_motu.r

@@ -25,7 +25,8 @@
 #' @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.
-#' @return Returns `NULL` invisibly but saves the requested file at the `destination` when successful.
+#' @return Returns a `logical` value invisibly indicating whether the requested file was
+#' successfully stored at the `destination`.
 #' @rdname copernicus_download_motu
 #' @name copernicus_download_motu
 #' @examples
@@ -58,9 +59,11 @@ copernicus_download_motu <- function(
 
   # Go to motu login page end get form id (lt)
   login_form <-
-    "https://cmems-cas.cls.fr/cas/login" %>%
-    httr::GET()
-
+    .try_online({
+      httr::GET("https://cmems-cas.cls.fr/cas/login")
+    }, "log-in page")
+  if (is.null(login_form)) return(invisible(FALSE))
+
   ## Check if you are already logged in:
   success <-
     login_form %>%
@@ -81,9 +84,12 @@ copernicus_download_motu <- function(
     message(crayon::white("Logging in onto MOTU server..."))
 
     login_result <-
-      sprintf("https://cmems-cas.cls.fr/cas/login?username=%s&password=%s&lt=%s&execution=e1s1&_eventId=submit",
-              username, password, lt) %>%
-      httr::GET()
+      .try_online({
+        sprintf("https://cmems-cas.cls.fr/cas/login?username=%s&password=%s&lt=%s&execution=e1s1&_eventId=submit",
+                username, password, lt) %>%
+          httr::GET()
+      }, "log-in page")
+    if (is.null(login_result)) return(invisible(FALSE))
 
     success <-
       login_result %>% httr::content() %>% rvest::html_element(xpath = "//div[@id='msg']") %>% rvest::html_attr("class")
@@ -95,8 +101,7 @@ copernicus_download_motu <- function(
 
   product_services <- copernicus_product_services(product) %>% dplyr::filter(layer == {{layer}}) %>% dplyr::pull("motu")
 
-  if (is.na(product_services))
-    stop("There is no subsetting MOTU server available for the requested data")
+  if (is.null(product_services) || is.na(product_services)) return(invisible(FALSE))
 
   if (missing(timerange)) timerange <- NULL else timerange <- format(as.POSIXct(timerange), "%Y-%m-%d+%H%%3A%M%%3A%S")
   prepare_url <-
@@ -112,22 +117,27 @@ copernicus_download_motu <- function(
     paste0(collapse = "&")
 
   result <-
-    prepare_url %>%
-    httr::GET(
-      ## Make sure to pass on cookies obtained earlier with account details:
-      do.call(
-        httr::set_cookies,
-        as.list(structure(login_result$cookies$value, names = login_result$cookies$name))
-      )
-  )
+    .try_online({
+      prepare_url %>%
+        httr::GET(
+          ## Make sure to pass on cookies obtained earlier with account details:
+          do.call(
+            httr::set_cookies,
+            as.list(structure(login_result$cookies$value, names = login_result$cookies$name))
+          )
+        )}, "Copernicus")
+  if (is.null(result)) return(invisible(FALSE))
 
   if (result$headers$`content-type` %>% startsWith("text/html")) {
     errors <-
       result %>%
       httr::content() %>%
       rvest::html_element(xpath = "//p[@class='error']") %>%
       rvest::html_text()
-    if (!is.na(errors)) stop(errors)
+    if (!is.na(errors)) {
+      message(errors)
+      return(invisible(FALSE))
+    }
 
     message(crayon::white("Downloading file..."))
 
@@ -138,17 +148,21 @@ copernicus_download_motu <- function(
       rvest::html_attr("action")
     if (dir.exists(destination))
       destination <- file.path(destination, basename(download_url))
-    download_url %>%
-      httr::GET(
-        httr::write_disk(destination, overwrite = overwrite),
-        ## Make sure to pass on cookies obtained earlier with account details:
-        do.call(
-          httr::set_cookies,
-          as.list(structure(login_result$cookies$value, names = login_result$cookies$name))
+    download_result <- .try_online({
+      download_url %>%
+        httr::GET(
+          httr::write_disk(destination, overwrite = overwrite),
+          ## Make sure to pass on cookies obtained earlier with account details:
+          do.call(
+            httr::set_cookies,
+            as.list(structure(login_result$cookies$value, names = login_result$cookies$name))
+          )
         )
-      )
+      }, "Copernicus")
+
+    if (is.null(download_result)) return(invisible(FALSE))
     message(crayon::green("Done"))
-    return(invisible(NULL))
+    return(invisible(TRUE))
 
   } else {
     stop("Retrieved unexpected content...")

R/copernicus_product_details.r

@@ -22,8 +22,15 @@
 #' @export
 copernicus_product_details <- function(product, layer, variable) {
   if (missing(layer) && !missing(variable)) stop("Variable specified without layer.")
-  result <- sprintf("https://cmems-be.lobelia.earth/api/dataset/%s?variant=detailed-v2", product) %>%
-    httr::GET() %>%
+  if (missing(product)) product <- ""
+  result <- .try_online({
+    sprintf("https://cmems-be.lobelia.earth/api/dataset/%s?variant=detailed-v2", product) %>%
+      httr::GET()
+  }, "Copernicus") 
+  if (is.null(result)) return(NULL)
+
+  result <-
+    result %>%
     httr::content("text") %>%
     jsonlite::fromJSON()
   if (!missing(layer)) {

R/copernicus_product_metadata.r

@@ -4,7 +4,8 @@
 #' for specific Copernicus marine products
 #'
 #' @inheritParams copernicus_download_motu
-#' @return Returns a named `list` with info about the requested `product`.
+#' @return Returns a named `list` with info about the requested `product`. Returns `NULL`
+#' when contacting Copernicus fails.
 #' @rdname copernicus_product_metadata
 #' @name copernicus_product_metadata
 #' @family product-functions
@@ -16,8 +17,13 @@
 #' @export
 copernicus_product_metadata <- function(product) {
   meta_data <-
-    sprintf("https://cmems-be.lobelia.earth/api/metadata/%s", product) %>%
-    httr::GET() %>%
+    .try_online({
+      sprintf("https://cmems-be.lobelia.earth/api/metadata/%s", product) %>%
+        httr::GET()
+    }, "Copernicus")
+  if (is.null(meta_data)) return(NULL)
+  meta_data <-
+    meta_data %>%
     httr::content() %>%
     xml2::as_list()
   return(meta_data)

R/copernicus_products_list.r

@@ -8,7 +8,8 @@
 #' @param info_type One of `"list"` (default) or `"meta"`. `"list"` returns the actual list
 #' whereas `"meta"` returns meta information for the executed query (e.g. number of hits).
 #' @return Returns a `tibble` of products available from <https://data.marine.copernicus.eu> or
-#' a named `list` when `info_type = "meta"`.
+#' a named `list` when `info_type = "meta"`. Returns `NULL` in case on-line services are
+#' unavailable.
 #' @rdname copernicus_products_list
 #' @name copernicus_products_list
 #' @family product-functions
@@ -26,12 +27,15 @@ copernicus_products_list <- function(..., info_type = c("list", "meta")) {
   payload     <- .payload_data_list
   payload_mod <- list(...)
   payload[names(payload_mod)] <- payload_mod
-  result <-
+  result <- .try_online({
     httr::POST(
       "https://cmems-be.lobelia.earth/api/datasets",
       body   = payload,
-      encode = "json"
-    ) %>%
+      encode = "json")
+  }, "Copernicus")
+  if (is.null(result)) return(NULL)
+  result <-
+    result %>%
     httr::content("text") %>%
     jsonlite::fromJSON()
   switch(

R/ftp.r

@@ -14,8 +14,8 @@
 #' @inheritParams copernicus_download_motu
 #' @return In case of `copernicus_ftp_list` a `tibble` is returned containing available URLs
 #' (for the specified product and layer) and some meta information is returned.
-#' In case of `copernicus_ftp_get` an invisible `NULL` is returned, but the
-#' requested file is stored at the `destination` path.
+#' In case of `copernicus_ftp_get` an invisible `logical` value is returned, indicating whether
+#' the requested file is successfully stored at the `destination` path.
 #' @rdname copernicus_ftp
 #' @name copernicus_ftp_list
 #' @examples
@@ -36,10 +36,16 @@ copernicus_ftp_list <- function(
   name <- NULL # workaround for 'no visible binding global for global variable'
   dirlist <- function(url){
     dir_result <-
-      httr::GET(
-        url,
-        httr::authenticate(user = getOption("CopernicusMarine_uid", ""), password = getOption("CopernicusMarine_pwd", "")),
-        dirlistonly = TRUE) %>%
+      .try_online({
+        httr::GET(
+          url,
+          httr::authenticate(user = getOption("CopernicusMarine_uid", ""), password = getOption("CopernicusMarine_pwd", "")),
+          dirlistonly = TRUE)
+      }, "Copernicus")
+    if (is.null(dir_result)) return(NULL)
+
+    dir_result <-
+      dir_result %>%
       `[[`("content") %>%
       rawToChar() %>%
       readr::read_fwf(
@@ -64,6 +70,7 @@ copernicus_ftp_list <- function(
   }
 
   base_url <- copernicus_product_services(product)
+  if (length(base_url) == 0) return(NULL)
 
   if (missing(layer)) {
     base_url <- dirname(base_url$ftp)[[1]]
@@ -85,12 +92,14 @@ copernicus_ftp_get <- function(
   if (!dir.exists(destination)) stop("'destination' either doesn't exist or is not a directory!")
   destination <- file.path(destination, basename(url))
 
-  result <- httr::GET(
-    url, httr::write_disk(destination, overwrite = overwrite),
-    if (show_progress) httr::progress() else NULL,
-    httr::authenticate(user = getOption("CopernicusMarine_uid", ""),
-                       password = getOption("CopernicusMarine_pwd", ""))
-  )
+  result <-
+    .try_online({
+      httr::GET(
+        url, httr::write_disk(destination, overwrite = overwrite),
+        if (show_progress) httr::progress() else NULL,
+        httr::authenticate(user = getOption("CopernicusMarine_uid", ""),
+                           password = getOption("CopernicusMarine_pwd", ""))
+      )}, "Copernicus")
 
-  return(invisible(NULL))
+  return(invisible(!is.null(result)))
 }

R/generics.r

@@ -0,0 +1,36 @@
+.http_status_ok <- function(x) {
+  if (dplyr::between(x$status_code, 100, 199)) {
+    message(sprintf("Unexpected informational response from Copernicus (status %i).", x$status_code))
+    return(FALSE)
+  }
+  if (dplyr::between(x$status_code, 300, 399)) {
+    message(sprintf("Unexpected redirection from Copernicus (status %i).", x$status_code))
+    return(FALSE)
+  }
+  if (dplyr::between(x$status_code, 400, 499)) {
+    message(sprintf(paste("Copernicus reported a client error (status %i).",
+                          "You may have requested information that is not available,",
+                          "please check your input.",
+                          sep = "\n"), x$status_code))
+    return(FALSE)
+  }
+  if (dplyr::between(x$status_code, 500, 599)) {
+    message(sprintf("Copernicus reported a server error (status %i).\nPlease try again later.", x$status_code))
+    return(FALSE)
+  }
+  if (x$status_code < 100 || x$status_code >= 600) {
+    message(sprintf("Copernicus responded with unknown status (status %i).", x$status_code))
+    return(FALSE)
+  }
+  return(TRUE)
+}
+
+.try_online <- function(expr, resource) {
+  result <- tryCatch(expr, error = function(e) {
+    message(sprintf("Failed to collect information from %s.\n%s", resource, e$message))
+    return(NULL)
+    })
+  if (is.null(result)) return(NULL)
+  if (!.http_status_ok(result)) return(NULL)
+  return(result)
+}