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

In bcgov/bcdc: Search and Retrieve Data from the BC Data Catalogue

# Copyright 2019 Province of British Columbia
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
# http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS,
# 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.
library(sf, quietly = TRUE)

test_that("bcdc_query_geodata accepts R expressions to refine data call", {
  skip_on_cran()
  skip_if_net_down()
  one_feature <- bcdc_query_geodata(point_record) %>%
    filter(SOURCE_DATA_ID == '455') %>%
    collect()
  expect_s3_class(one_feature, "sf")
  expect_equal(attr(one_feature, "sf_column"), "geometry")
  expect_equal(nrow(one_feature), 1)
})

test_that("bcdc_query_geodata accepts R expressions to refine data call", {
  skip_on_cran()
  skip_if_net_down()
  one_feature <- bcdc_query_geodata(point_record) %>%
    filter(SOURCE_DATA_ID == '455') %>%
    collect()
  expect_s3_class(one_feature, "sf")
  expect_equal(attr(one_feature, "sf_column"), "geometry")
  expect_equal(nrow(one_feature), 1)
})

test_that("operators work with different remote geom col names", {
  skip_on_cran()
  skip_if_net_down()

  ## LOCAL
  crd <- bcdc_query_geodata(polygon_record) %>%
    filter(ADMIN_AREA_NAME == "Capital Regional District") %>%
    collect()

  ## REMOTE "GEOMETRY"
  em_program <- bcdc_query_geodata(
    "employment-program-of-british-columbia-regional-boundaries"
  ) %>%
    filter(INTERSECTS(crd)) %>%
    collect()
  expect_s3_class(em_program, "sf")
  expect_equal(attr(em_program, "sf_column"), "geometry")

  ## REMOTE "SHAPE"
  crd_fires <- suppressWarnings(
    bcdc_query_geodata("22c7cb44-1463-48f7-8e47-88857f207702") %>%
      filter(FIRE_YEAR == 2000, FIRE_CAUSE == "Person", INTERSECTS(crd)) %>%
      collect()
  )
  expect_s3_class(crd_fires, "sf")
  expect_equal(attr(crd_fires, "sf_column"), "geometry")
})

test_that("Different combinations of predicates work", {
  the_bbox <- st_sfc(
    st_polygon(
      list(structure(
        c(
          1670288.515,
          1719022.009,
          1719022.009,
          1670288.515,
          1670288.515,
          667643.77,
          667643.77,
          745981.738,
          745981.738,
          667643.77
        ),
        .Dim = c(5L, 2L)
      ))
    ),
    crs = 3005
  )

  # with raw CQL
  expect_equal(
    as.character(cql_translate(
      CQL('"POP_2000" < 2000'),
      .colnames = "POP_2000"
    )),
    "(\"POP_2000\" < 2000)"
  )

  # just with spatial predicate
  expect_equal(
    as.character(cql_translate(WITHIN(the_bbox))),
    "(WITHIN({geom_name}, POLYGON ((1670289 667643.8, 1719022 667643.8, 1719022 745981.7, 1670289 745981.7, 1670289 667643.8))))"
  )

  # spatial predicate combined with regular comparison using comma
  and_statement <- "((WITHIN({geom_name}, POLYGON ((1670289 667643.8, 1719022 667643.8, 1719022 745981.7, 1670289 745981.7, 1670289 667643.8)))) AND (\"POP_2000\" < 2000))"
  expect_equal(
    as.character(cql_translate(
      WITHIN(the_bbox),
      POP_2000 < 2000L,
      .colnames = "POP_2000"
    )),
    and_statement
  )

  # spatial predicate combined with regular comparison as a named object using comma
  pop <- 2000L
  expect_equal(
    as.character(cql_translate(
      WITHIN(the_bbox),
      POP_2000 < pop,
      .colnames = "POP_2000"
    )),
    and_statement
  )

  and_with_logical <- "(WITHIN({geom_name}, POLYGON ((1670289 667643.8, 1719022 667643.8, 1719022 745981.7, 1670289 745981.7, 1670289 667643.8))) AND \"POP_2000\" < 2000)"
  # spatial predicate combined with regular comparison as a named object using
  # explicit &
  expect_equal(
    as.character(cql_translate(
      WITHIN(the_bbox) & POP_2000 < pop,
      .colnames = "POP_2000"
    )),
    and_with_logical
  )

  # spatial predicate combined with regular comparison as a named object using
  # explicit |
  or_statement <- "(WITHIN({geom_name}, POLYGON ((1670289 667643.8, 1719022 667643.8, 1719022 745981.7, 1670289 745981.7, 1670289 667643.8))) OR \"POP_2000\" < 2000)"
  expect_equal(
    as.character(cql_translate(
      WITHIN(the_bbox) | POP_2000 < pop,
      .colnames = "POP_2000"
    )),
    or_statement
  )

  # spatial predicate combined with CQL using comma
  expect_equal(
    as.character(cql_translate(
      WITHIN(the_bbox),
      CQL("\"POP_2000\" < 2000"),
      .colnames = "POP_2000"
    )),
    and_statement
  )

  # spatial predicate combined with CQL using explicit &
  expect_equal(
    as.character(cql_translate(
      WITHIN(the_bbox) &
        CQL("\"POP_2000\" < 2000"),
      .colnames = "POP_2000"
    )),
    and_with_logical
  )

  # spatial predicate combined with CQL using explicit &
  expect_equal(
    as.character(cql_translate(
      WITHIN(the_bbox) |
        CQL("\"POP_2000\" < 2000"),
      .colnames = "POP_2000"
    )),
    or_statement
  )
})

test_that("subsetting works locally", {
  x <- c("a", "b")
  y <- data.frame(id = x, stringsAsFactors = FALSE)
  expect_equal(
    as.character(cql_translate(foo == x[1], .colnames = "foo")),
    "(\"foo\" = 'a')"
  )
  expect_equal(
    as.character(cql_translate(foo %in% local(y$id), .colnames = "foo")),
    "(\"foo\" IN ('a', 'b'))"
  )
  expect_equal(
    as.character(cql_translate(foo %in% y[["id"]], .colnames = "foo")),
    "(\"foo\" IN ('a', 'b'))"
  )
  expect_equal(
    as.character(cql_translate(foo == local(y$id[2]), .colnames = "foo")),
    "(\"foo\" = 'b')"
  )
})

test_that("large vectors supplied to filter succeeds", {
  skip_on_cran()
  skip_if_net_down()
  pori <- bcdc_query_geodata(lines_record) %>%
    filter(WATERSHED_GROUP_CODE %in% "PORI") %>%
    collect()

  expect_s3_class(
    bcdc_query_geodata(lines_record) %>%
      filter(WATERSHED_KEY %in% pori$WATERSHED_KEY),
    "bcdc_promise"
  )
})

test_that("multiple filter statements are additive", {
  skip_on_cran()
  skip_if_net_down()
  airports <- bcdc_query_geodata(point_record)

  heliports_in_victoria <- airports %>%
    filter(PHYSICAL_ADDRESS == "Victoria, BC") %>%
    filter(DESCRIPTION == "heliport") %>%
    collect()

  ## this is additive only Victoria, BC should be a physical address
  expect_true(unique(heliports_in_victoria$PHYSICAL_ADDRESS) == "Victoria, BC")

  heliports_one_line <- airports %>%
    filter(PHYSICAL_ADDRESS == "Victoria, BC", DESCRIPTION == "heliport")
  heliports_two_line <- airports %>%
    filter(PHYSICAL_ADDRESS == "Victoria, BC") %>%
    filter(DESCRIPTION == "heliport")

  expect_identical(
    finalize_cql(heliports_one_line$query_list$CQL_FILTER),
    finalize_cql(heliports_two_line$query_list$CQL_FILTER)
  )
})

test_that("multiple filter statements are additive with geometric operators", {
  skip_on_cran()
  skip_if_net_down()
  ## LOCAL
  crd <- bcdc_query_geodata(polygon_record) %>%
    filter(ADMIN_AREA_NAME == "Cariboo Regional District") %>%
    collect() %>%
    st_bbox() %>%
    st_as_sfc()

  ## REMOTE "GEOMETRY"
  em_program <- bcdc_query_geodata(
    "employment-program-of-british-columbia-regional-boundaries"
  ) %>%
    filter(ELMSD_REGION_BOUNDARY_NAME == "Interior") %>%
    filter(INTERSECTS(crd))

  cql_query <- "((\"ELMSD_REGION_BOUNDARY_NAME\" = 'Interior') AND (INTERSECTS(GEOMETRY, POLYGON ((956376 653960.8, 1397042 653960.8, 1397042 949343.3, 956376 949343.3, 956376 653960.8)))))"

  expect_equal(
    as.character(finalize_cql(em_program$query_list$CQL_FILTER)),
    cql_query
  )
})


test_that("an intersect with an object greater than 5E5 bytes automatically gets turned into a bbox", {
  skip_on_cran()
  skip_if_net_down()

  regions <- bcdc_query_geodata(polygon_record) %>%
    filter(
      ADMIN_AREA_NAME %in%
        c(
          "Bulkley Nechako Regional District",
          "Cariboo Regional District",
          "Regional District of Fraser-Fort George"
        )
    ) %>%
    collect()

  expect_true(utils::object.size(regions) > 5E5)

  expect_message(
    parks <- bcdc_query_geodata(
      record = "6a2fea1b-0cc4-4fc2-8017-eaf755d516da"
    ) %>%
      filter(WITHIN(regions)) %>%
      collect()
  )
})


test_that("an intersect with an object less than 5E5 proceeds", {
  skip_on_cran()
  skip_if_net_down()
  small_districts <- bcdc_query_geodata(
    "78ec5279-4534-49a1-97e8-9d315936f08b"
  ) %>%
    filter(SCHOOL_DISTRICT_NAME %in% c("Prince George")) %>%
    collect() %>%
    st_bbox() %>%
    st_as_sfc()

  expect_s3_class(
    parks <- bcdc_query_geodata(
      record = "6a2fea1b-0cc4-4fc2-8017-eaf755d516da"
    ) %>%
      filter(WITHIN(small_districts)) %>%
      collect(),
    "bcdc_sf"
  )
})

test_that("a BCGW name works with filter", {
  skip_on_cran()
  skip_if_net_down()
  little_box <- st_as_sfc(st_bbox(
    c(
      xmin = 506543.662,
      ymin = 467957.582,
      xmax = 1696644.998,
      ymax = 1589145.873
    ),
    crs = 3005
  ))

  ret <- bcdc_query_geodata("WHSE_IMAGERY_AND_BASE_MAPS.GSR_AIRPORTS_SVW") %>%
    filter(WITHIN(little_box)) %>%
    collect()
  expect_equal(nrow(ret), 367)
})

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(local(st_bbox(the_geom, crs = st_crs(the_geom))))) %>%
    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(
      local(st_buffer(the_geom, 10000, nQuadSegs = 2)),
      100,
      "meters"
    )) %>%
    show_query()

  expect_match(
    as.character(qry2$query_list$CQL_FILTER),
    "\\(DWITHIN\\(SHAPE, MULTIPOLYGON \\(\\(\\([0-9. ,()]+\\)\\)\\), 100, meters\\)\\)"
  )

  # Informative error when omit local:
  expect_error(
    suppressWarnings(
      bcdc_query_geodata("local-and-regional-greenspaces") %>%
        filter(DWITHIN(
          st_buffer(the_geom, 10000, nQuadSegs = 2),
          100,
          "meters"
        ))
    ),
    "Cannot translate"
  )
})

test_that("works with dates", {
  skip_if_net_down()
  skip_on_cran()
  expect_s3_class(
    bcdc_query_geodata('historical-orders-and-alerts') %>%
      filter(EVENT_START_DATE < "2017-05-01") %>%
      collect(),
    "bcdc_sf"
  )
  expect_s3_class(
    bcdc_query_geodata('historical-orders-and-alerts') %>%
      filter(EVENT_START_DATE < as.Date("2017-05-01")) %>%
      collect(),
    "bcdc_sf"
  )
  expect_s3_class(
    bcdc_query_geodata('historical-orders-and-alerts') %>%
      filter(EVENT_START_DATE < as.POSIXct("2017-05-01")) %>%
      collect(),
    "bcdc_sf"
  )
  dt <- as.Date("2017-05-01")
  expect_s3_class(
    bcdc_query_geodata('historical-orders-and-alerts') %>%
      filter(EVENT_START_DATE < dt) %>%
      collect(),
    "bcdc_sf"
  )
  pt <- as.Date("2017-05-01")
  expect_s3_class(
    bcdc_query_geodata('historical-orders-and-alerts') %>%
      filter(EVENT_START_DATE < pt) %>%
      collect(),
    "bcdc_sf"
  )
})

test_that("works with various as.x functions", {
  skip_if_net_down()
  skip_on_cran()
  expect_s3_class(
    bcdc_query_geodata(point_record) %>%
      filter(NUMBER_OF_RUNWAYS == as.numeric("3")) %>%
      collect(),
    "bcdc_sf"
  )
  expect_s3_class(
    bcdc_query_geodata(point_record) %>%
      filter(DESCRIPTION == as.character("seaplane anchorage")) %>%
      collect(),
    "bcdc_sf"
  )
})