Merge pull request #341 from bcgov/dbplyr-2.5-fixes

Fixes for dbplyr 2.5.0 and handling of failing GetCapabilities requests

NEWS.md

@@ -1,5 +1,9 @@
 # bcdata (development version)
 
+* Make functions more robust to non-functioning WMS/WFS GetCapabilities requests (#339, #341)
+* dbplyr 2.5.0 has made the requirement for using `!!` or 
+ `local()` for local functions more restrictive; updated tests
+ and examples (#341).
 * Deprecate the `bcdata.single_download_limit` option, as it was mostly redundant with `bcdata.chunk_limit`, and should always be set by the server. Please set the page size limit for paginated requests via the `bcdata.chunk_limit` option (#332)
 
 # bcdata 0.4.1

R/bcdc_options.R

@@ -140,7 +140,7 @@ bcdc_get_capabilities <- function() {
 bcdc_get_wfs_records <- function() {
  doc <- bcdc_get_capabilities()
 
- if (is.null(doc)) stop("Unable to access wfs record listing", call. = FALSE)
+ if (is.null(doc)) stop("Unable to access wfs listing from server. Please open an issue. ", call. = FALSE)
 
  # d1 is the default xml namespace (see xml2::xml_ns(doc))
  features <- xml2::xml_find_all(doc, "./d1:FeatureTypeList/d1:FeatureType")
@@ -156,7 +156,7 @@ bcdc_single_download_limit <- function() {
  doc <- bcdc_get_capabilities()
 
  if (is.null(doc)) {
- message("Unable to access wfs record listing, using default download limit of 10000")
+ message("Unable to access server to determine single download limit; using default download limit of 10000")
  return(10000L)
  }
 

tests/testthat/helper-bcdata.R

@@ -16,3 +16,10 @@ skip_if_net_down <- function() {
  }
  testthat::skip("no internet")
 }
+
+skip_if_no_capabilities <- function() {
+ if (!is.null(bcdc_get_capabilities())) {
+ return()
+ }
+ testthat::skip("GetCapabilities request is broken")
+}

tests/testthat/test-describe-feature.R

@@ -43,6 +43,7 @@ test_that("bcdc_describe_feature accepts a bcdc_record object", {
 test_that("bcdc_describe_feature accepts BCGW name",{
  skip_on_cran()
  skip_if_net_down()
+ skip_if_no_capabilities()
  airport_feature <- bcdc_describe_feature("WHSE_IMAGERY_AND_BASE_MAPS.GSR_AIRPORTS_SVW")
  expect_identical(names(airport_feature), c("col_name", "sticky", "remote_col_type","local_col_type", "column_comments"))
 })
@@ -57,13 +58,15 @@ test_that("bcdc_describe_feature fails on unsupported classes", {
 test_that("bcdc_describe_feature fails with non-wfs record", {
  skip_if_net_down()
  skip_on_cran()
+ skip_if_no_capabilities()
  expect_error(bcdc_describe_feature("dba6c78a-1bc1-4d4f-b75c-96b5b0e7fd30"),
  "No WFS resource available for this data set")
 })
 
 test_that("bcdc_get_wfs_records works", {
  skip_if_net_down()
  skip_on_cran()
+ skip_if_no_capabilities()
 
  wfs_records <- bcdc_get_wfs_records()
 

tests/testthat/test-geom-operators.R

@@ -16,7 +16,7 @@ if (has_internet() && identical(Sys.getenv("NOT_CRAN"), "true")) {
  collect()
 }
 
-test_that("bcdc_check_geom_size outputs message with low threshold",{
+test_that("bcdc_check_geom_size outputs message with low threshold", {
  skip_on_cran()
  skip_if_net_down()
 
@@ -25,7 +25,7 @@ test_that("bcdc_check_geom_size outputs message with low threshold",{
  expect_false(bcdc_check_geom_size(local))
 })
 
-test_that("bcdc_check_geom_size is silent with high threshold",{
+test_that("bcdc_check_geom_size is silent with high threshold", {
  skip_on_cran()
  skip_if_net_down()
 
@@ -34,7 +34,7 @@ test_that("bcdc_check_geom_size is silent with high threshold",{
 })
 
 
-test_that("WITHIN works",{
+test_that("WITHIN works", {
  skip_on_cran()
  skip_if_net_down()
 
@@ -49,7 +49,7 @@ test_that("WITHIN works",{
 })
 
 
-test_that("INTERSECTS works",{
+test_that("INTERSECTS works", {
  skip_on_cran()
  skip_if_net_down()
 
@@ -61,7 +61,6 @@ test_that("INTERSECTS works",{
 
  expect_s3_class(remote, "sf")
  expect_equal(attr(remote, "sf_column"), "geometry")
-
 })
 
 test_that("RELATE works", {
@@ -115,7 +114,7 @@ test_that("BBOX works with an sf bbox", {
 
  remote <- suppressWarnings(
  bcdc_query_geodata("bc-parks-ecological-reserves-and-protected-areas") %>%
- filter(FEATURE_LENGTH_M <= 1000, BBOX(sf::st_bbox(local))) %>%
+ filter(FEATURE_LENGTH_M <= 1000, BBOX(!!sf::st_bbox(local))) %>%
  collect()
  )
 
@@ -144,7 +143,7 @@ test_that("Other predicates work with an sf bbox", {
 
  remote <- suppressWarnings(
  bcdc_query_geodata("bc-parks-ecological-reserves-and-protected-areas") %>%
- filter(FEATURE_LENGTH_M <= 1000, INTERSECTS(sf::st_bbox(local))) %>%
+ filter(FEATURE_LENGTH_M <= 1000, INTERSECTS(!!sf::st_bbox(local))) %>%
  collect()
  )
 

tests/testthat/test-options.R

@@ -25,7 +25,7 @@ test_that("bcdata.chunk_limit",{
  expect_error(check_chunk_limit())
  })
  withr::with_options(list(bcdata.chunk_limit = 10), {
- expect_silent(check_chunk_limit())
+ expect_true(is.numeric(check_chunk_limit()))
  expect_equal(check_chunk_limit(), 10)
  })
 })
@@ -36,8 +36,9 @@ test_that("bcdata.single_download_limit is deprecated but works", {
  skip_on_cran()
  withr::local_options(list(bcdata.single_download_limit = 1))
  withr::local_envvar(list(BCDC_KEY = NULL)) # so snapshot not affected by message
- expect_snapshot(
- bcdc_query_geodata(record = '76b1b7a3-2112-4444-857a-afccf7b20da8')
+ expect_s3_class(
+ bcdc_query_geodata(record = '76b1b7a3-2112-4444-857a-afccf7b20da8'), 
+ "bcdc_promise"
  )
 })
 

tests/testthat/test-query-geodata-filter.R

@@ -231,9 +231,9 @@ test_that("a BCGW name works with filter", {
  xmax = 1696644.998, ymax = 1589145.873),
  crs = 3005))
 
- expect_silent(ret <- bcdc_query_geodata("WHSE_IMAGERY_AND_BASE_MAPS.GSR_AIRPORTS_SVW") %>%
+ ret <- bcdc_query_geodata("WHSE_IMAGERY_AND_BASE_MAPS.GSR_AIRPORTS_SVW") %>%
  filter(WITHIN(little_box)) %>%
- collect())
+ collect()
  expect_equal(nrow(ret), 367)
 })
 
@@ -274,7 +274,7 @@ test_that("Nesting functions inside a CQL geometry predicate works (#146)", {
  bcdc_query_geodata("local-and-regional-greenspaces") %>%
  filter(DWITHIN(st_buffer(the_geom, 10000, nQuadSegs = 2), 100, "meters"))
  ),
- "Unable to process query")
+ "Cannot translate")
 })
 
 test_that("works with dates", {

tests/testthat/test-query-geodata-select.R

@@ -51,9 +51,9 @@ test_that("select reduces the number of columns when a sticky ",{
 test_that("select works with BCGW name", {
  skip_on_cran()
  skip_if_net_down()
- expect_silent(ret <- bcdc_query_geodata(bcgw_point_record) %>%
+ expect_s3_class(bcdc_query_geodata(bcgw_point_record) %>%
  select(AIRPORT_NAME, DESCRIPTION) %>%
- collect())
+ collect(), "sf")
 })
 
 

tests/testthat/test-utils.R

@@ -58,6 +58,7 @@ test_that("is_whse_object_name works", {
 test_that("bcdc_get_capabilities works", {
  skip_on_cran()
  skip_if_net_down()
+ skip_if_no_capabilities()
 
  old_get_caps <- ._bcdataenv_$get_capabilities_xml