Merge pull request #154 from bcgov/fix-cql-parsing

Fix cql parsing. Fixes #146

NAMESPACE

@@ -30,7 +30,6 @@ S3method(sql_escape_string,DummyCQL)
 S3method(sql_translate_env,DummyCQL)
 export("%>%")
 export(BBOX)
-export(BEYOND)
 export(CONTAINS)
 export(CQL)
 export(CROSSES)
@@ -39,7 +38,6 @@ export(DWITHIN)
 export(EQUALS)
 export(INTERSECTS)
 export(OVERLAPS)
-export(RELATE)
 export(TOUCHES)
 export(WITHIN)
 export(bcdc_browse)
@@ -79,4 +77,5 @@ importFrom(readr,read_csv)
 importFrom(readr,read_tsv)
 importFrom(readxl,read_xls)
 importFrom(readxl,read_xlsx)
+importFrom(rlang,":=")
 importFrom(sf,read_sf)

NEWS.md

@@ -4,6 +4,10 @@
 
 * Add `bcdc_tidy_resources` for retrieving a data frame containing the metadata for all resources from a single B.C. Data Catalogue record (PR#149, #147)
 * Add a more decorative record print method  (#73)
+* Remove `BEYOND()` and `RELATE()` geometry predicates as they are currently
+not fully supported by geoserver
+* Fixed a bug where functions nested inside geometry predicates were not evaluated (#146, #154)
+* Fixed a bug where `DWITHIN` wasn't working because `units` needed to be unqoted (#154)
 
 # bcdata 0.1.1.9999
 

R/cql-geom-predicates.R

@@ -22,8 +22,8 @@
 #' @param x object of class sf, sfc or sfg
 #' @param geometry_predicates Geometry predicates that allow for spatial filtering.
 #' bcbdc_cql_string accepts the following geometric predicates: EQUALS,
-#' DISJOINT, INTERSECTS, TOUCHES, CROSSES,  WITHIN, CONTAINS, OVERLAPS, RELATE,
-#' DWITHIN, BEYOND, BBOX.
+#' DISJOINT, INTERSECTS, TOUCHES, CROSSES,  WITHIN, CONTAINS, OVERLAPS,
+#' DWITHIN, BBOX.
 #'
 #' @seealso sql_geom_predicates
 #'
@@ -63,9 +63,9 @@ bcdc_cql_string <- function(x, geometry_predicates, pattern = NULL,
         if (!is.null(crs)) paste0(", '", crs, "'")
       )
     } else if (geometry_predicates %in% c("DWITHIN", "BEYOND")) {
-      paste0(x, ", ", distance, ", '", units, "'")
+      paste0(x, ", ", distance, ", ", units, "")
     } else if (geometry_predicates == "RELATE") {
-      paste0(x, ", '", pattern, "'")
+      paste0(x, ", ", pattern)
     } else {
       x
     }
@@ -172,7 +172,7 @@ OVERLAPS <- function(geom) {
 #' @param pattern spatial relationship specified by a DE-9IM matrix pattern.
 #' A DE-9IM pattern is a string of length 9 specified using the characters
 #' `*TF012`. Example: `'1*T***T**'`
-#' @export
+#' @noRd
 RELATE <- function(geom, pattern) {
   if (!is.character(pattern) ||
       length(pattern) != 1L ||
@@ -216,7 +216,8 @@ DWITHIN <- function(geom, distance,
 }
 
 #' @rdname cql_geom_predicates
-#' @export
+#' @noRd
+# https://osgeo-org.atlassian.net/browse/GEOS-8922
 BEYOND <- function(geom, distance,
                    units = c("meters", "feet", "statute miles", "nautical miles", "kilometers")) {
   if (!is.numeric(distance)) {

R/cql-translator.R

@@ -10,6 +10,8 @@
 # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 # See the License for the specific language governing permissions and limitations under the License.
 
+#' @importFrom rlang :=
+
 # Function to translate R code to CQL
 cql_translate <- function(...) {
   ## convert dots to list of quosures
@@ -22,11 +24,28 @@ cql_translate <- function(...) {
   ## predicates and CQL() expressions are evaluated into valid CQL code
   ## so they can be combined with the rest of the query
   dots <- lapply(dots, function(x) {
-    rlang::new_quosure(
-      dbplyr::partial_eval(rlang::get_expr(x), env = rlang::get_env(x)),
-                rlang::get_env(x))
+
+    # make sure all arguments are named in the call so can be modified
+    x <- rlang::call_standardise(x, env = rlang::get_env(x))
+
+    # if an argument to a predicate is a function call, need to tell it to evaluate
+    # locally, as by default all functions are treated as remote and thus
+    # not evaluated. Do this by using `rlang::call2` to wrap the function call in
+    # local()
+    # See ?rlang::partial_eval and https://github.com/bcgov/bcdata/issues/146
+    for (call_arg in rlang::call_args_names(x)) {
+      if (is.call(rlang::call_args(x)[[call_arg]])) {
+        x <- rlang::call_modify(
+          x, !!call_arg := rlang::call2("local", rlang::call_args(x)[[call_arg]])
+        )
+      }
+    }
+
+    rlang::new_quosure(dbplyr::partial_eval(x), rlang::get_env(x))
   })
+
   sql_where <- dbplyr::translate_sql_(dots, con = cql_dummy_con, window = FALSE)
+
   build_where(sql_where)
 }
 

scratch/multipoint.R

@@ -0,0 +1,13 @@
+
+format_multipoint <- function(x) {
+  x <- gsub("(\\(\\d+(\\.)?\\d*)", "(\\1", x)
+  x <- gsub("(\\d+),\\s*", "\\1), (", x)
+  gsub("(\\))$", "\\1)", x)
+}
+
+format_wkt("MULTIPOINT (1164434 368738.7, 1203024 412959)")
+format_wkt("POINT (1164434 368738.7)")
+format_wkt("MULTIPOINT (1164434 368738.7, 1203024 412959, 1203025 412960)")
+format_wkt("MULTIPOINT (1164434 368738.7 20, 1203024 412959 50, 1203025 412960 100)")
+
+st_as_text(st_as_sfc("MULTIPOINT ((10 10), (20 20))"))

tests/testthat/test-cql-string.R

@@ -41,19 +41,19 @@ test_that("All cql geom predicate functions work", {
   }
   expect_equal(
     DWITHIN(the_geom, 1), #default units meters
-    CQL("DWITHIN({geom_name}, POINT (1 1), 1, 'meters')")
+    CQL("DWITHIN({geom_name}, POINT (1 1), 1, meters)")
   )
   expect_equal(
     DWITHIN(the_geom, 1, "meters"),
-    CQL("DWITHIN({geom_name}, POINT (1 1), 1, 'meters')")
+    CQL("DWITHIN({geom_name}, POINT (1 1), 1, meters)")
   )
   expect_equal(
     BEYOND(the_geom, 1, "feet"),
-    CQL("BEYOND({geom_name}, POINT (1 1), 1, 'feet')")
+    CQL("BEYOND({geom_name}, POINT (1 1), 1, feet)")
   )
   expect_equal(
     RELATE(the_geom, "*********"),
-    CQL("RELATE({geom_name}, POINT (1 1), '*********')")
+    CQL("RELATE({geom_name}, POINT (1 1), *********)")
   )
   expect_equal(
     BBOX(c(1,2,1,2)),

tests/testthat/test-geom-operators.R

@@ -12,12 +12,15 @@
 
 context("Geometric operators work with appropriate data")
 
-test_that("WITHIN works",{
-  skip_on_cran()
-  skip_if_net_down()
+if (has_internet() && identical(Sys.getenv("NOT_CRAN"), "true")) {
   local <- bcdc_query_geodata("regional-districts-legally-defined-administrative-areas-of-bc") %>%
     filter(ADMIN_AREA_NAME == "Cariboo Regional District") %>%
     collect()
+}
+
+test_that("WITHIN works",{
+  skip_on_cran()
+  skip_if_net_down()
 
   remote <- suppressWarnings(
     bcdc_query_geodata("bc-airports") %>%
@@ -27,16 +30,12 @@ test_that("WITHIN works",{
 
   expect_is(remote, "sf")
   expect_equal(attr(remote, "sf_column"), "geometry")
-
 })
 
 
 test_that("INTERSECT works",{
   skip_on_cran()
   skip_if_net_down()
-  local <- bcdc_query_geodata("regional-districts-legally-defined-administrative-areas-of-bc") %>%
-    filter(ADMIN_AREA_NAME == "Cariboo Regional District") %>%
-    collect()
 
   remote <- suppressWarnings(
     bcdc_query_geodata("bc-parks-ecological-reserves-and-protected-areas") %>%
@@ -49,4 +48,47 @@ test_that("INTERSECT works",{
 
 })
 
+test_that("RELATE works", {
+  skip("RELATE not supported. https://github.com/bcgov/bcdata/pull/154")
+  skip_on_cran()
+  skip_if_net_down()
+
+  remote <- suppressWarnings(
+    bcdc_query_geodata("bc-parks-ecological-reserves-and-protected-areas") %>%
+      filter(RELATE(local, "*********")) %>%
+      collect()
+  )
 
+  expect_is(remote, "sf")
+  expect_equal(attr(remote, "sf_column"), "geometry")
+})
+
+test_that("DWITHIN works", {
+  skip_on_cran()
+  skip_if_net_down()
+
+  remote <- suppressWarnings(
+    bcdc_query_geodata("bc-parks-ecological-reserves-and-protected-areas") %>%
+      filter(DWITHIN(local, 100, "meters")) %>%
+      collect()
+  )
+
+  expect_is(remote, "sf")
+  expect_equal(attr(remote, "sf_column"), "geometry")
+})
+
+test_that("BEYOND works", {
+  skip("BEYOND currently not supported")
+  # https://osgeo-org.atlassian.net/browse/GEOS-8922
+  skip_on_cran()
+  skip_if_net_down()
+
+  remote <- suppressWarnings(
+    bcdc_query_geodata("bc-parks-ecological-reserves-and-protected-areas") %>%
+      filter(BEYOND(local, 100, "meters")) %>%
+      collect()
+  )
+
+  expect_is(remote, "sf")
+  expect_equal(attr(remote, "sf_column"), "geometry")
+})

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

@@ -230,10 +230,34 @@ test_that("a BCGW name works with filter", {
 })
 
 test_that("Using BBOX works", {
+  skip_on_cran()
+  skip_if_net_down()
   query <- bcdc_query_geodata("WHSE_FOREST_VEGETATION.BEC_BIOGEOCLIMATIC_POLY", crs = 4326) %>%
     filter(BBOX(c(1639473.0,528785.2,1665979.9,541201.0), crs = "EPSG:3005")) %>%
     show_query()
   expect_equal(query$query_list$CQL_FILTER,
                structure("(BBOX(GEOMETRY, 1639473, 528785.2, 1665979.9, 541201, 'EPSG:3005'))",
                          class = c("sql", "character")))
 })
+
+test_that("Nesting functions inside a CQL geometry predicate works (#146)", {
+  skip_on_cran()
+  skip_if_net_down()
+  the_geom <- st_sfc(st_point(c(1164434, 368738)),
+                     st_point(c(1203023, 412959)),
+                     crs = 3005)
+
+  qry <- bcdc_query_geodata("local-and-regional-greenspaces") %>%
+    filter(BBOX(st_bbox(the_geom), crs = paste0("EPSG:", st_crs(the_geom)$epsg))) %>%
+    show_query()
+
+  expect_equal(as.character(qry$query_list$CQL_FILTER),
+               "(BBOX(SHAPE, 1164434, 368738, 1203023, 412959, 'EPSG:3005'))")
+
+  qry2 <- bcdc_query_geodata("local-and-regional-greenspaces") %>%
+    filter(DWITHIN(st_buffer(the_geom, 10000, nQuadSegs = 2), 100, "meters")) %>%
+    show_query()
+
+  expect_equal(as.character(qry2$query_list$CQL_FILTER),
+               "(DWITHIN(SHAPE, MULTIPOLYGON (((1174434 368738, 1171505 361666.9, 1164434 358738, 1157363 361666.9, 1154434 368738, 1157363 375809.1, 1164434 378738, 1171505 375809.1, 1174434 368738)), ((1213023 412959, 1210094 405887.9, 1203023 402959, 1195952 405887.9, 1193023 412959, 1195952 420030.1, 1203023 422959, 1210094 420030.1, 1213023 412959))), 100, meters))")
+})