feat: move from ows4R to our own WFS calls #17

.Rbuildignore

@@ -14,3 +14,4 @@
 ^test/testthat/*$
 ^vignettes/mregions2_cache$
 ^real-tests$
+^data-raw$

DESCRIPTION

@@ -31,7 +31,6 @@ Imports:
     cli,
     dplyr,
     lubridate,
-    ows4R (>= 0.3),
     purrr,
     xml2,
     wrapr,
@@ -42,6 +41,7 @@ URL: https://github.com/lifewatch/mregions2,
     https://lifewatch.github.io/mregions2/
 BugReports: https://github.com/lifewatch/mregions2/issues
 Suggests: 
+    ows4R (>= 0.3),
     httptest,
     httptest2,
     jsonlite,
@@ -55,3 +55,5 @@ Suggests:
     wk
 VignetteBuilder: knitr
 Roxygen: list(markdown = TRUE)
+Depends: 
+    R (>= 2.10)

NAMESPACE

@@ -38,8 +38,6 @@ export(mrp_col_distinct)
 export(mrp_col_unique)
 export(mrp_colnames)
 export(mrp_get)
-export(mrp_init_wfs_client)
-export(mrp_list)
 export(mrp_view)
 export(mrp_view_cds)
 export(mrp_view_eca_reg13_nox)

R/07_mrp_view.R

@@ -1,6 +1,6 @@
 #' Visualize a Marine Regions data product without downloading
 #'
-#' @param data_product (character) Identifier of the data product. See [mrp_list()]
+#' @param layer (character) Identifier of the data product. See [mrp_list]
 #' @param cql_filter (character) Contextual Query Language (CQL) filter. See details.
 #' @param filter (character) Standard OGC filter specification. See details.
 #' @param ... pass the `cql_filter` and `filter` parameters to [mrp_view()] when using one of the helpers
@@ -65,26 +65,20 @@
 #'   cql_filter = "doc_date AFTER 2000-01-01T00:00:00Z AND doc_date BEFORE 2009-12-31T00:00:00Z"
 #' )
 #'}
-mrp_view <- function(data_product, cql_filter = NULL, filter = NULL){
+mrp_view <- function(layer, cql_filter = NULL, filter = NULL){
 
   # Assertions
   assert_deps(c("leaflet", "leaflet.extras2"))
-  checkmate::assert_character(data_product, len = 1)
-  checkmate::assert_choice(data_product, mrp_list()$data_product)
-
-  both_filters_given <- methods::hasArg(cql_filter) & methods::hasArg(filter)
-  if(both_filters_given) stop("You must provide one of `cql_filter` or `filter`, not both.", call. = FALSE)
-
+  checkmate::assert_character(layer, len = 1)
+  checkmate::assert_choice(layer, mrp_list$layer)
+  assert_only_one_filter(cql_filter, filter)
   checkmate::assert_character(cql_filter, null.ok = TRUE, len = 1)
   checkmate::assert_character(filter, null.ok = TRUE, len = 1)
   assert_internet()
 
 
   # Config
-  layer <- subset(mrp_list()$id, mrp_list()$data_product == data_product)
-  layer <- strsplit(layer[[1]], ":", TRUE)[[1]]
-  namespace <- layer[1]
-  layer <- layer[2]
+  namespace <- subset(mrp_list$namespace, mrp_list$layer == layer)
   wms <- glue::glue("https://geo.vliz.be/geoserver/{namespace}/wms?")
 
   # Server check

R/08_mrp_get.R

@@ -60,77 +60,88 @@
 #' # You can also limit the number of features to be requested
 #' mrp_get("eez", count = 5)
 #' }
-mrp_get <- function(product_name, ...){
-  data_product <- . <- id <- Group.1 <- NULL
+mrp_get <- function(layer, cql_filter = NULL, filter = NULL, count = NULL){
 
-  checkmate::assert_character(product_name, len = 1)
-  checkmate::assert_choice(product_name, mrp_list()$data_product)
+  # Assertions
+  checkmate::assert_character(layer, len = 1)
+  checkmate::assert_choice(layer, mrp_list$layer)
+  checkmate::assert_character(cql_filter, null.ok = TRUE, len = 1)
+  checkmate::assert_character(filter, null.ok = TRUE, len = 1)
+  assert_only_one_filter(cql_filter, filter)
+  count <- checkmate::assert_integerish(count, lower = 1, len = 1, coerce = TRUE)
 
   # Config
-  info <- mrp_list() %>%
-    dplyr::filter(data_product == product_name)
-
-  # Perform request
-  ft <- mrp_init_wfs_client(silent = TRUE)$
-    getCapabilities()$
-    findFeatureTypeByName(info$id)
-
-  out <- ft$getFeatures(...)
-
-  # Fix Geometry type
-  # Geoserver often returns exotic geometries
-  # It is better to turn into MULTILINESTRING / MULTIPOLYGON
-  geometry_class <- class(sf::st_geometry(out))
-
-  if("sfc_MULTICURVE" %in% geometry_class){
-    try({
-      out <- out %>% sf::st_cast("MULTILINESTRING")
-    })
-  }
-
-  if("sfc_MULTISURFACE" %in% geometry_class){
-    try({
-      out <- out %>%
-        sf::st_cast("GEOMETRYCOLLECTION") %>%
-        dplyr::mutate(id = seq_len(nrow(.))) %>%
-        sf::st_collection_extract("POLYGON") %>%
-        aggregate_sf(list(.$id), dplyr::first, do_union = FALSE) %>%
-        dplyr::select(-id, -Group.1)
-    })
-  }
+  namespace <- subset(mrp_list$namespace, mrp_list$layer == layer)
+  url <- httr2::url_parse("https://geo.vliz.be/geoserver/ows")
+  url$query <- list(service = "wfs",
+                    version = "2.0.0",
+                    request = "GetFeature",
+                    typeName = glue::glue("{namespace}:{layer}"),
+                    cql_filter = cql_filter,
+                    filter = filter,
+                    count = count,
+                    outputFormat = "text/csv")
 
-  attr(out, "class") <- c("tbl_df", "tbl", "data.frame")
+  # Perform
+  request <- httr2::url_build(url) %>%
+    httr2::request() %>%
+    httr2::req_user_agent(mr_user_agent) %>%
+    httr2::req_perform(path = NULL)
 
-  out <- sf::st_as_sf(out)
+  resp <- request %>%
+    httr2::resp_body_string(encoding = "UTF-8") %>%
+    textConnection() %>%
+    read.csv(stringsAsFactors = FALSE, fileEncoding = "UTF-8")
 
-  out$gml_id <- NULL
+  attr(resp, "class") <- c("tbl_df", "tbl", "data.frame")
 
-  if (is.na(sf::st_crs(out))) {
-    sf::st_crs(out) <- ft$getDefaultCRS()
-  }
+  out <- sf::st_as_sf(resp, wkt = "the_geom", crs = 4326)
+  out$FID <- NULL
 
   out
 }
 
 
 
 
-.mrp_colnames <- function(product_name){
-  data_product <- name <- type <- NULL
+.mrp_colnames <- function(layer){
+  layer <- name <- type <- NULL
 
-  checkmate::assert_character(product_name, len = 1)
-  checkmate::assert_choice(product_name, mrp_list()$data_product)
+  checkmate::assert_character(layer, len = 1)
+  checkmate::assert_choice(layer, mrp_list$layer)
 
   # Config
-  info <- mrp_list() %>%
-    dplyr::filter(data_product == product_name)
+  namespace <- subset(mrp_list$namespace, mrp_list$layer == layer)
+  url <- httr2::url_parse("https://geo.vliz.be/geoserver/ows")
+  url$query <- list(service = "wfs",
+                    version = "2.0.0",
+                    request = "DescribeFeatureType",
+                    typeName = glue::glue("{namespace}:{layer}")
+                    )
 
   # Perform
-  mrp_init_wfs_client(silent = TRUE)$
-    getCapabilities()$
-    findFeatureTypeByName(info$id)$
-    getDescription(pretty = TRUE) %>%
-    dplyr::transmute(data_product = product_name, column_name = name, type)
+  request <- httr2::url_build(url) %>%
+    httr2::request() %>%
+    httr2::req_user_agent(mr_user_agent) %>%
+    httr2::req_perform()
+
+  resp <- request %>%
+    httr2::resp_body_xml() %>%
+    xml2::xml_find_all("//xsd:element")
+
+  out <- data.frame(
+    layer = layer,
+    colname = xml2::xml_attr(resp, "name"),
+    type = gsub("xsd:", "", xml2::xml_attr(resp, "type")),
+    stringsAsFactors = FALSE
+  )
+
+  out <- subset(out, out$colname != "the_geom")
+  out <- subset(out, out$colname != layer)
+
+  attr(out, "class") <- c("tbl_df", "tbl", "data.frame")
+
+  out
 
 }
 #' Get the names of the columns and data type of the data product
@@ -159,44 +170,42 @@ mrp_colnames <- memoise::memoise(.mrp_colnames)
 
 
 
+.mrp_col_unique <- function(layer, colname){
 
-.mrp_col_unique <- function(product_name, colname){
-  data_product <- NULL
-
-  checkmate::assert_character(product_name, len = 1)
-  checkmate::assert_choice(product_name, mrp_list()$data_product)
+  checkmate::assert_character(layer, len = 1)
+  checkmate::assert_choice(layer, mrp_list$layer)
 
   checkmate::assert_character(colname, len = 1)
-  colnames <- mrp_colnames(product_name)
+  colnames <- mrp_colnames(layer)
   checkmate::assert_choice(colname, colnames[, 2])
 
-  # Geometry column not allowed
-  datatype <- tolower(subset(colnames[, 3], colnames[, 2] == colname))
-  if(datatype == "geometry"){ stop("`colname` of type geometry are not accepted. See ?mrp_col_unique", call. = FALSE) }
 
   # Config
-  info <- mrp_list() %>%
-    dplyr::filter(data_product == product_name)
-
-  url <- glue::glue(
-    "https://geo.vliz.be/geoserver/wfs?service=wfs&version=2.0.0&request=GetPropertyValue&typeNames={info$id}&valueReference={colname}"
+  namespace <- subset(mrp_list$namespace, mrp_list$layer == layer)
+  url <- httr2::url_parse("https://geo.vliz.be/geoserver/ows")
+  url$query <- list(service = "wfs",
+                    version = "2.0.0",
+                    request = "GetPropertyValue",
+                    typeNames = glue::glue("{namespace}:{layer}"),
+                    valueReference = colname
   )
 
   # Perform
-  resp <- httr2::request(url) %>%
+  resp <- httr2::url_build(url) %>%
+    httr2::request() %>%
     httr2::req_user_agent(mr_user_agent) %>%
     httr2::req_perform() %>%
     httr2::resp_body_xml() %>%
     xml2::xml_find_all(glue::glue("//wfs:member")) %>%
     xml2::xml_text() %>%
     unique()
 
-
-  if(datatype %in% c("numeric", "integer", "double")) resp <- resp %>% as.numeric()
+  datatype <- tolower(subset(colnames[, 3], colnames[, 2] == colname))
+  if(datatype %in% c("numeric", "int", "double")) resp <- resp %>% as.numeric()
   if(datatype %in% c("date")) resp <- resp %>% lubridate::as_date()
   if(datatype %in% c("timestamp")) resp <- resp %>% lubridate::as_datetime()
 
-  resp
+  sort(resp)
 }
 #' Get all the possible values of a column of a Marine Regions data product
 #'