Fix graceful failure in check_api()/check_query() and geoentities_overlap validation

NEWS.md

@@ -2,6 +2,12 @@
 
 * Typo in the documentation of GIFT_taxonomy()
 * Disclaimer added to the vignettes
+* check_api() and check_query() now return NULL with an informative message
+when the server cannot be reached, instead of raising an uncaught error;
+they also perform a single request instead of up to three
+* Fixed the validation of the geoentities_overlap argument in
+GIFT_no_overlap(): a malformed table is now rejected with the intended
+error message instead of failing later with an obscure one
 
 # GIFT 1.3.4
 * Fix in GIFT_env_meta_misc and GIFT_env_meta_raster

R/GIFT_no_overlap.R

@@ -87,15 +87,16 @@ GIFT_no_overlap <- function(
          kept.")
     }
 
-    if(!is.null(geoentities_overlap) && !is.data.frame(geoentities_overlap) &&
-       ncol(geoentities_overlap) != 7 &&
-       colnames(geoentities_overlap) != c("entity1", "entity2", "overlap12",
-                                          "overlap21", "area1", "area2",
-                                          "entity_class2")){
-      stop("'geoentities_overlap' is a table coming from GIFT indicating the
+    if(!is.null(geoentities_overlap)){
+      if(!is.data.frame(geoentities_overlap) ||
+         !(all(c("entity1", "entity2", "overlap12", "overlap21", "area1",
+                 "area2", "entity_class2") %in%
+               colnames(geoentities_overlap)))){
+        stop("'geoentities_overlap' is a table coming from GIFT indicating the
          overlap in km^2 between pairs of polygons. It is automatically
          retrieved when 'geoentities_overlap' = NULL (default value of the
          function).")
+      }
     }
 
     GIFT_version <- check_gift_version_simple(GIFT_version)

R/check_functions.R

@@ -30,26 +30,25 @@ check_api <- function(api) {
 
   # Second check: web API available
   req <- httr2::request(api)
-  resp <- httr2::req_error(req, is_error = function(resp) FALSE)
-  
+  req <- httr2::req_error(req, is_error = function(resp) FALSE)
+
   # test for non-existing APIs
-  tryCatch(expr = httr2::req_perform(resp),
-           error = function(expr) {
-             message(
-               "Either the API is wrongly specified or the server is down.")
-             return(NULL)
-           })
-  
+  resp <- tryCatch(expr = httr2::req_perform(req),
+                   error = function(expr) NULL)
+  if(is.null(resp)){
+    message("Either the API is wrongly specified or the server is down.")
+    return(NULL)
+  }
+
   # If the server was found, check for status
-  resp_status <- httr2::resp_status_desc(httr2::req_perform(resp))
+  resp_status <- httr2::resp_status_desc(resp)
   if(resp_status == "Unauthorized"){
     message("A password is needed for this restricted API.")
     return(NULL)
   } else if(resp_status != "OK"){
     message("Either the API is wrongly specified or the server is down.")
     return(NULL)
   } else{
-    resp <- httr2::req_perform(req)
     if(httr2::resp_body_string(resp) != "No query selected."){
       message("Either the API is wrongly specified or the server is down.")
       return(NULL)
@@ -500,18 +499,18 @@ check_query <- function(api) {
 
   # Second check: web API available
   req <- httr2::request(api)
-  resp <- httr2::req_error(req, is_error = function(resp) FALSE)
-  
+  req <- httr2::req_error(req, is_error = function(resp) FALSE)
+
   # test for non-existing APIs
-  tryCatch(expr = httr2::req_perform(resp),
-           error = function(expr) {
-             message(
-               "Either the API is wrongly specified or the server is down.")
-             return(NULL)
-           })
-  
+  resp <- tryCatch(expr = httr2::req_perform(req),
+                   error = function(expr) NULL)
+  if(is.null(resp)){
+    message("Either the API is wrongly specified or the server is down.")
+    return(NULL)
+  }
+
   # If the server was found, check for status
-  resp_status <- httr2::resp_status_desc(httr2::req_perform(resp))
+  resp_status <- httr2::resp_status_desc(resp)
   if(resp_status == "Unauthorized"){
     message("A password is needed for this restricted API.")
     return(NULL)

tests/testthat/test-GIFT_no_overlap.R

@@ -45,4 +45,12 @@ test_that("invalid inputs", {
 of GIFT you want to use. Available options are 'latest', 'beta' and the 
 different named stable versions of GIFT.",
     fixed = TRUE)
+
+  expect_error(
+    GIFT_no_overlap(entity_IDs = c(1, 2),
+                    geoentities_overlap = data.frame(foo = 1, bar = 2)),
+    "'geoentities_overlap' is a table coming from GIFT indicating the
+         overlap in km^2 between pairs of polygons. It is automatically
+         retrieved when 'geoentities_overlap' = NULL (default value of the
+         function).", fixed = TRUE)
 })

tests/testthat/test-check_functions.R

@@ -0,0 +1,13 @@
+# Tests for internal check functions ----
+
+test_that("check_api() fails gracefully when the server is unreachable", {
+  # 127.0.0.1:9 refuses the connection immediately; before the fix the
+  # graceful message was followed by an uncaught httr2 error
+  expect_null(suppressMessages(check_api("http://127.0.0.1:9/")))
+  expect_message(check_api("http://127.0.0.1:9/"))
+})
+
+test_that("check_query() fails gracefully when the server is unreachable", {
+  expect_null(suppressMessages(check_query("http://127.0.0.1:9/")))
+  expect_message(check_query("http://127.0.0.1:9/"))
+})