Add full XML get capabilities into pkg env to access object description

R/bcdc_options.R

@@ -18,7 +18,7 @@
 #' failed calls to the data catalogue. Options in R are reset every time R is re-started. See examples for
 #' addition ways to restore your initial state.
 #'
-#' `bcdata.max_geom_pred_size` is the maximum size of an object used for a geometric operation. Objects
+#' `bcdata.max_geom_pred_size` is the maximum size in bytes of an object used for a geometric operation. Objects
 #' that are bigger than this value will have a bounding box drawn and apply the geometric operation
 #' on that simpler polygon. Users can try to increase the maximum geometric predicate size and see
 #' if the bcdata catalogue accepts their request.
@@ -74,22 +74,21 @@ bcdc_options <- function() {
     "bcdata.chunk_limit", null_to_na(getOption("bcdata.chunk_limit")), 1000,
     "bcdata.single_download_limit",
     null_to_na(getOption("bcdata.single_download_limit",
-                         default = ._bcdataenv_$bcdata_dl_limit)), 10000
+                         default = bcdc_single_download_limit())), 10000
   )
 }
 
 
 check_chunk_limit <- function(){
   chunk_value <- getOption("bcdata.chunk_limit")
-  chunk_limit <- getOption("bcdata.single_download_limit", default = ._bcdataenv_$bcdata_dl_limit)
+  chunk_limit <- getOption("bcdata.single_download_limit", default = bcdc_single_download_limit())
 
   if(!is.null(chunk_value) && chunk_value >= chunk_limit){
     stop(glue::glue("Your chunk value of {chunk_value} exceed the BC Data Catalogue chunk limit of {chunk_limit}"), call. = FALSE)
   }
 }
 
-
-bcdc_single_download_limit <- function() {
+bcdc_get_capabilities_xml <- function() {
   if (has_internet()) {
     url <- "http://openmaps.gov.bc.ca/geo/pub/ows?service=WFS&version=2.0.0&request=Getcapabilities"
     cli <- bcdata:::bcdc_http_client(url, auth = FALSE)
@@ -101,8 +100,31 @@ bcdc_single_download_limit <- function() {
     ))
 
     res <- cc$parse("UTF-8")
-    doc <- xml2::read_xml(res)
+    xml2::read_xml(res)
+
+  } else {
+    message("No access to internet")
+    invisible(FALSE)
+  }
+}
+
+bcdc_get_capabilities <- function() {
+  doc <- ._bcdataenv_$get_capabilities_xml
+
+  features <- xml2::xml_child(doc, 4)
+  feature_list <- xml2::as_list(features)
+  purrr::map_dfr(feature_list, ~ {
+    list(whse_name = .x$Name[[1]] %||% NA_character_,
+         title = .x$Title[[1]] %||% NA_character_,
+         cat_url = attr(.x$MetadataURL, "href") %||% NA_character_)
+  })
+}
+
+
+bcdc_single_download_limit <- function() {
+  doc <- ._bcdataenv_$get_capabilities_xml
 
+  if (inherits(doc, "xml_document")) {
     constraints <- xml2::xml_find_all(doc, ".//ows:Constraint")
     count_defaults <- constraints[which(xml2::xml_attrs(constraints) %in% "CountDefault")]
     xml2::xml_double(count_defaults)

R/describe-feature.R

@@ -22,6 +22,7 @@
 #'   - sticky: whether a column can be separated from the record in a Web Service call via the `dplyr::select` method
 #'   - remote_col_type: class of what is return by the web feature service
 #'   - local_col_type: the column class in R
+#'   - column_comments: additional metadata specific to that column
 #'
 #' @inheritParams bcdc_query_geodata
 #' @export
@@ -53,7 +54,16 @@ bcdc_describe_feature.default <- function(record) {
 bcdc_describe_feature.character <- function(record){
 
   if (is_whse_object_name(record)) {
-    return(feature_helper(record))
+    bgc <- bcdc_get_capabilities()
+    cat_record <- bcdc_get_record(bgc$cat_url[grepl(record, bgc$whse_name)])
+
+    return(
+      dplyr::left_join(
+        feature_helper(record),
+         cat_record$details[,c("column_comments", "column_name")],
+         by = c("col_name" = "column_name")
+       )
+      )
   }
 
   bcdc_describe_feature(bcdc_get_record(record))
@@ -69,7 +79,13 @@ bcdc_describe_feature.bcdc_record <- function(record){
     )
   }
 
-  feature_helper(record$layer_name)
+  dplyr::left_join(
+    feature_helper(record$layer_name),
+    record$details[,c("column_comments", "column_name")],
+    by = c("col_name" = "column_name")
+  )
+
+
 }
 
 parse_raw_feature_tbl <- function(query_list){
@@ -110,15 +126,11 @@ feature_helper <- function(whse_name){
   xml_df <- parse_raw_feature_tbl(query_list)
   geom_type <- attr(xml_df, "geom_type")
 
-  ## Identify geometry column and move to last
-  # xml_df[xml_df$type == geom_type, "name"] <- "geometry"
-  # xml_df <- dplyr::bind_rows(xml_df[xml_df$name != "geometry",],
-  #                            xml_df[xml_df$name == "geometry",])
 
   ## Fix logicals
   xml_df$nillable = ifelse(xml_df$nillable == "true", TRUE, FALSE)
-
   xml_df <- xml_df[, c("name", "nillable", "type")]
+
   ## Add the id_row back into the front
   xml_df <- dplyr::bind_rows(id_row, xml_df)
   colnames(xml_df) <- c("col_name", "sticky", "remote_col_type")

R/utils-classes.R

@@ -379,7 +379,7 @@ collect.bcdc_promise <- function(x, ...){
   ## Determine total number of records for pagination purposes
   number_of_records <- bcdc_number_wfs_records(query_list, cli)
 
-  if (number_of_records < getOption("bcdata.single_download_limit", default = ._bcdataenv_$bcdata_dl_limit)) {
+  if (number_of_records < getOption("bcdata.single_download_limit", default = bcdc_single_download_limit())) {
     cc <- tryCatch(cli$post(body = query_list, encode = "form"),
                    error = function(e) {
                      stop("There was an issue processing this request.

R/zzz.R

@@ -14,7 +14,7 @@
 
 .onLoad <- function(...) {
   ._bcdataenv_$named_get_record_warned <- FALSE # nocov
-  ._bcdataenv_$bcdata_dl_limit <- bcdc_single_download_limit() # nocov
+  ._bcdataenv_$get_capabilities_xml <- bcdc_get_capabilities_xml() # nocov
 
 }
 

tests/testthat/test-describe-feature.R

@@ -16,7 +16,7 @@ test_that("Test that bcdc_describe feature returns the correct columns",{
   skip_on_cran()
   skip_if_net_down()
   airport_feature <- bcdc_describe_feature("bc-airports")
-  expect_identical(names(airport_feature), c("col_name", "sticky", "remote_col_type","local_col_type"))
+  expect_identical(names(airport_feature), c("col_name", "sticky", "remote_col_type","local_col_type", "column_comments"))
 })
 
 
@@ -39,14 +39,14 @@ test_that("bcdc_describe_feature accepts a bcdc_record object", {
   skip_if_net_down()
   airports <- bcdc_get_record('76b1b7a3-2112-4444-857a-afccf7b20da8')
   airport_feature <- bcdc_describe_feature(airports)
-  expect_identical(names(airport_feature), c("col_name", "sticky", "remote_col_type","local_col_type"))
+  expect_identical(names(airport_feature), c("col_name", "sticky", "remote_col_type","local_col_type", "column_comments"))
 })
 
 test_that("bcdc_describe_feature accepts BCGW name",{
   skip_on_cran()
   skip_if_net_down()
   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"))
+  expect_identical(names(airport_feature), c("col_name", "sticky", "remote_col_type","local_col_type", "column_comments"))
 })
 
 test_that("bcdc_describe_feature fails on unsupported classes", {