Merge pull request #732 from ldecicco-USGS/retryERROR

Retry error
DOI-USGS · Oct 21, 2024 · 2b7790d · 2b7790d
2 parents adfb21e + 743d5c9
commit 2b7790d
Show file tree

Hide file tree

Showing 6 changed files with 98 additions and 56 deletions.
diff --git a/R/getWebServiceData.R b/R/getWebServiceData.R
@@ -25,49 +25,43 @@ getWebServiceData <- function(obs_url, ...) {
 
   returnedList <- retryGetOrPost(obs_url, ...)
 
-  if (httr::status_code(returnedList) == 400) {
-    if (httr::has_content(returnedList)) {
-      response400 <- httr::content(returnedList, type = "text", encoding = "UTF-8")
-      statusReport <- xml2::xml_text(xml2::xml_child(xml2::read_xml(response400), 2)) # making assumption that - body is second node
-      statusMsg <- gsub(pattern = ", server=.*", replacement = "", x = statusReport)
-      message(statusMsg)
-    } else {
-      httr::message_for_status(returnedList)
-      warning_message <- httr::headers(returnedList)
-      if ("warning" %in% names(warning_message)) {
-        warning_message <- warning_message$warning
-        message(warning_message)
-      }
-    }
-    return(invisible(NULL))
-  } else if (httr::status_code(returnedList) != 200) {
-    message("For: ", obs_url, "\n")
-    httr::message_for_status(returnedList)
-    return(invisible(NULL))
-  } else {
+  good <- check_non_200s(returnedList)
+
+  return_readLines <- c("text/html", "text/html; charset=UTF-8")
+  return_raw <- c("application/zip",
+                  "application/zip;charset=UTF-8",
+                  "application/vnd.geo+json;charset=UTF-8")
+  return_content <- c("text/tab-separated-values;charset=UTF-8",
+                      "text/csv;charset=UTF-8",
+                      "text/plain")
+
+  if(good){
     headerInfo <- httr::headers(returnedList)
 
-    if (!"content-type" %in% names(headerInfo)) {
-      message("Unknown content, returning NULL")
-      return(invisible(NULL))
-    }
-
-    if (headerInfo$`content-type` %in% c(
-      "text/tab-separated-values;charset=UTF-8",
-      "text/csv;charset=UTF-8"
-    )) {
+    if (headerInfo$`content-type` %in% return_content) {
       returnedDoc <- httr::content(returnedList, type = "text", encoding = "UTF-8")
-    } else if (headerInfo$`content-type` %in%
-      c(
-        "application/zip",
-        "application/zip;charset=UTF-8",
-        "application/vnd.geo+json;charset=UTF-8"
-      )) {
+      trys <- 1
+      if (all(grepl("ERROR: INCOMPLETE DATA", returnedDoc))) {
+
+        while(trys <= 3){
+          message("Trying again!")
+          obs_url <- paste0(obs_url, "&try=", trys)
+          returnedList <- retryGetOrPost(obs_url)
+          good <- check_non_200s(returnedList)
+          if(good){
+            returnedDoc <- httr::content(returnedList, type = "text", encoding = "UTF-8")
+          }
+          if (all(grepl("ERROR: INCOMPLETE DATA", returnedDoc))) {
+            trys <- trys + 1
+          } else {
+            trys <- 100
+          }
+        } 
+      }
+
+    } else if (headerInfo$`content-type` %in% return_raw) {
       returnedDoc <- returnedList
-    } else if (headerInfo$`content-type` %in% c(
-      "text/html",
-      "text/html; charset=UTF-8"
-    )) {
+    } else if (headerInfo$`content-type` %in% return_readLines) {
       txt <- readLines(returnedList$content)
       message(txt)
       return(txt)
@@ -91,7 +85,44 @@ getWebServiceData <- function(obs_url, ...) {
     attr(returnedDoc, "headerInfo") <- headerInfo
 
     return(returnedDoc)
+  } else {
+    return(NULL)
+  }
+}
+
+check_non_200s <- function(returnedList){
+
+  status <- httr::status_code(returnedList)
+  if (status == 400) {
+    if (httr::has_content(returnedList)) {
+      response400 <- httr::content(returnedList, type = "text", encoding = "UTF-8")
+      statusReport <- xml2::xml_text(xml2::xml_child(xml2::read_xml(response400), 2)) # making assumption that - body is second node
+      statusMsg <- gsub(pattern = ", server=.*", replacement = "", x = statusReport)
+      message(statusMsg)
+    } else {
+      httr::message_for_status(returnedList)
+      warning_message <- httr::headers(returnedList)
+      if ("warning" %in% names(warning_message)) {
+        warning_message <- warning_message$warning
+        message(warning_message)
+      }
+    }
+    return(FALSE)
+  } else if (status != 200) {
+    httr::message_for_status(returnedList)
+    return(FALSE)
+
+  } else {
+    headerInfo <- httr::headers(returnedList)
+
+    if (!"content-type" %in% names(headerInfo)) {
+      message("Unknown content, returning NULL")
+      return(FALSE)
+    }
+    return(TRUE)
   }
+
+
 }
 
 #' Create user agent

diff --git a/R/readWQPdata.R b/R/readWQPdata.R
@@ -258,6 +258,10 @@ readWQPdata <- function(...,
       convertType = convertType
     )
 
+    if(is.null(retval)){
+      return(NULL)
+    }
+
     attr(retval, "legacy") <- legacy
 
     if(!legacy){

diff --git a/R/readWQPqw.R b/R/readWQPqw.R
@@ -81,6 +81,9 @@ readWQPqw <- function(siteNumbers,
   } else {
     retval <- importWQP(url, tz = tz, 
                         convertType = convertType)
+    if(is.null(retval)){
+      return(NULL)
+    }
     attr(retval, "legacy") <- legacy
 
     if(legacy){

diff --git a/tests/testthat/tests_general.R b/tests/testthat/tests_general.R
@@ -235,16 +235,18 @@ test_that("General WQP retrievals working", {
   expect_is(pHData$Activity_StartDateTime, "POSIXct")
 
   # testing lists:
-  startDate <- as.Date("2023-01-01")
-  secchi.names <- c(
-    "Depth, Secchi disk depth",
-    "Depth, Secchi disk depth (choice list)",
-    "Secchi Reading Condition (choice list)",
-    "Water transparency, Secchi disc"
-  )
+  startDate <- as.Date("2022-01-01")
+  secchi.names <- c("Depth, Secchi disk depth",
+  "Secchi depth",
+  "Water transparency, Secchi disc",
+  "Depth, Secchi disk depth (choice list)")
+  # "Transparency, Secchi tube with disk",
+  # "Secchi Reading Condition (choice list)",
+  # "Depth, Secchi disk visible at bottom (Y/N) (choice list)")
+
   args_2 <- list(
     "startDateLo" = startDate,
-    "startDateHi" = "2013-12-31",
+    "startDateHi" = "2024-01-01",
     statecode = "WI",
     characteristicName = secchi.names
   )
@@ -258,7 +260,8 @@ test_that("General WQP retrievals working", {
     statecode = "WI",
     characteristicName = secchi.names
   )
-
+  lakeData <- readWQPdata(args_2, ignore_attributes = TRUE)
+  expect_true(nrow(lakeData) > 0)
   lakeSites <- whatWQPsites(args_2)
   expect_type(lakeSites, "list")
 
@@ -499,6 +502,8 @@ test_that("internal functions", {
 })
 
 test_that("profiles", {
+
+  testthat::skip_on_cran()
   # Data profiles: "Organization Data"
   org_data <- readWQPdata(
     statecode = "WI",

diff --git a/tests/testthat/tests_nldi.R b/tests/testthat/tests_nldi.R
@@ -29,14 +29,7 @@ test_that("NLDI offerings...", {
 })
 
 
-xx <- findNLDI(
-  wqp = "TCEQMAIN-10016",
-  nav = "UM",
-  find = "nwissite",
-  distance_km = 2,
-  no_sf = FALSE,
-  warn = FALSE
-)
+
 
 
 test_that("NLDI starting sources...", {

diff --git a/tests/testthat/tests_userFriendly_fxns.R b/tests/testthat/tests_userFriendly_fxns.R
@@ -146,6 +146,12 @@ test_that("WQP qw tests", {
 
   INFO2 <- readWQPqw("WIDNR_WQX-10032762", nameToUse, startDate = "", endDate = "")
   expect_is(INFO2$Activity_StartDateTime, "POSIXct")
+
+  df <- readWQPqw("USGS-04193500", parameterCd = "00665")
+  expect_true(nrow(df) > 0)
+
+  df2 <- readWQPqw("USGS-05427718", parameterCd = "all")
+  expect_true(nrow(df2) > 0)
 })
 
 context("readNWISstat tests")