Merge pull request #123 from R-ArcGIS/grouplayers

Add `GroupLayer` support per #120

NAMESPACE

@@ -1,9 +1,16 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(get_all_layers,GroupLayer)
+S3method(get_all_layers,default)
+S3method(get_layer,GroupLayer)
+S3method(get_layer,default)
+S3method(get_layers,GroupLayer)
+S3method(get_layers,default)
 S3method(head,FeatureLayer)
 S3method(head,Table)
 S3method(print,FeatureLayer)
 S3method(print,FeatureServer)
+S3method(print,GroupLayer)
 S3method(print,ImageServer)
 S3method(print,MapServer)
 S3method(print,Table)

NEWS.md

@@ -1,5 +1,6 @@
 # arcgislayers 0.1.0 (unreleased)
 
+- Add support for `GroupLayer`s
 - Add `arc_read()` with support for `name_repair` argument using `{vctrs}` (#108)
 - Add `get_layer_estimates()` to retrieve estimate info such as the number of features and the extent of the layer
 - Add `truncate_layer()` to support truncate and append workflow

R/arc-open.R

@@ -101,7 +101,9 @@ arc_open <- function(url, token = Sys.getenv("ARCGIS_TOKEN")) {
  meta, class = layer_class
  ),
  "ImageServer" = structure(meta, class = layer_class),
- "MapServer" = structure(meta, class = layer_class)
+ "MapServer" = structure(meta, class = layer_class),
+ "GroupLayer" = structure(meta, class = layer_class),
+ cli::cli_abort("Unsupported service")
  )
 
  res

R/print-methods.R

@@ -220,6 +220,46 @@ print.ImageServer <- function(x, ...) {
 
 }
 
+
+# GroupLayer --------------------------------------------------------------
+#' @export
+print.GroupLayer <- function(x, ...) {
+
+ n_layers <- length(x[["subLayers"]])
+
+ header <- cli::cli_fmt(
+ cli::cli_text(
+ "<{class(x)} <{n_layers} layer{?s}>>"
+ )
+ )
+
+ to_print <- compact(list(
+ "Name" = x[["name"]],
+ "Description" = {
+ desc <- substr(x[["description"]], 1, options('width')$width %||% 80 - 14)
+ if (!nzchar(desc)) {
+ NULL
+ } else {
+ desc
+ }
+ },
+ "CRS" = x[["extent"]][["spatialReference"]][["latestWkid"]],
+ "Capabilities" = x[["capabilities"]]
+ ))
+
+ # extract sub layers
+ lyrs <- x[["subLayers"]]
+
+ # format the layer body
+ body_layers <- paste0(" ", lyrs[["id"]], ": ", lyrs[["name"]])
+
+ # format the body
+ body <- paste0(names(to_print), ": ", to_print)
+
+ # cat out
+ cat(header, body, body_layers, sep = "\n")
+}
+
 # Utils -------------------------------------------------------------------
 
 #' function to make printing easier

R/utils-feature-server.R

@@ -37,7 +37,6 @@
 #' get_all_layers(fserv)
 #' }
 get_layer <- function(x, id = NULL, name = NULL, token = Sys.getenv("ARCGIS_TOKEN")) {
-
  # check for mutual exclusivity between id and name
  if (is.null(id) && is.null(name)) {
  cli::cli_abort("{.arg id} or {.arg name} must be provided.")
@@ -52,6 +51,12 @@ get_layer <- function(x, id = NULL, name = NULL, token = Sys.getenv("ARCGIS_TOKE
  cli::cli_abort("{.arg id} and {.arg name} must be of length 1.")
  }
 
+ UseMethod("get_layer")
+}
+
+#' @export
+get_layer.default <- function(x, id = NULL, name = NULL, token = Sys.getenv("ARCGIS_TOKEN")) {
+
  if (!is.null(name)) {
 
  # grab both table and layer names to check agains
@@ -63,7 +68,7 @@ get_layer <- function(x, id = NULL, name = NULL, token = Sys.getenv("ARCGIS_TOKE
  is_table_name <- name %in% table_names
 
  # error if not found
- if (all(!is_layer, !is_table)) {
+ if (all(!is_layer_name, !is_table_name)) {
  cli::cli_abort("{.arg name} not available in {.code {c(layer_names, table_names)}}")
  }
 
@@ -94,10 +99,61 @@ get_layer <- function(x, id = NULL, name = NULL, token = Sys.getenv("ARCGIS_TOKE
 
 }
 
+#' @export
+get_layer.GroupLayer <- function(
+ x,
+ id = NULL,
+ name = NULL,
+ token = Sys.getenv("ARCGIS_TOKEN")
+) {
+ if (!is.null(name)) {
+
+ layer_names <- x[["subLayers"]][["name"]]
+
+ # check if name is present as a table or layer
+ is_layer_name <- name %in% layer_names
+
+ # error if not found
+ if (!is_layer_name) {
+ cli::cli_abort("{.arg name} not available in {.code {layer_names}}")
+ }
+
+ # grab layer ids
+ layer_ids <- x[["subLayers"]][["id"]]
+
+ # match item id
+ item_id <- layer_ids[which(layer_names == name)]
+
+ # the new item_url
+ item_url <- sub("\\d+$", item_id, x[["url"]])
+
+ } else if (!is.null(id)) {
+ layer_ids <- x[["subLayers"]][["id"]]
+
+ # find matching index
+ is_layer <- id %in% layer_ids
+
+ if (!is_layer) {
+ cli::cli_abort(
+ paste0("{.arg id} ", id, " not in available IDs (", toString(unlist(layer_ids)), ")")
+ )
+ }
+
+ item_url <- sub("\\d+$", id, x[["url"]])
+ }
+
+ arc_open(item_url, token = token)
+}
+
 
 #' @rdname get_layer
 #' @export
 get_all_layers <- function(x, token = Sys.getenv("ARCGIS_TOKEN")) {
+ UseMethod("get_all_layers")
+}
+
+#' @export
+get_all_layers.default <- function(x, token = Sys.getenv("ARCGIS_TOKEN")) {
  layer_ids <- x[["layers"]][["id"]]
  table_ids <- x[["tables"]][["id"]]
  layers <- lapply(file.path(x[["url"]], layer_ids), arc_open, token = token)
@@ -111,10 +167,28 @@ get_all_layers <- function(x, token = Sys.getenv("ARCGIS_TOKEN")) {
  )
 }
 
+#' @export
+get_all_layers.GroupLayer <- function(x, token = Sys.getenv("ARCGIS_TOKEN")) {
+ all_layer_ids <- x[["subLayers"]][["id"]]
+
+ all_layer_paths <- vapply(
+ all_layer_ids,
+ function(.x) sub("\\d+$", .x, x[["url"]]),
+ character(1)
+ )
+
+ lapply(all_layer_paths, arc_open)
+}
+
 
 #' @export
 #' @rdname get_layer
-get_layers <- function(x, id = NULL, name = NULL, token = Sys.getenv("ARCGIS_TOKEN")) {
+get_layers <- function(
+ x,
+ id = NULL,
+ name = NULL,
+ token = Sys.getenv("ARCGIS_TOKEN")
+) {
  if (is.null(id) && is.null(name)) {
  cli::cli_abort("{.arg id} or {.arg name} must be provided.")
  } else if (!is.null(id) && !is.null(name)) {
@@ -126,6 +200,12 @@ get_layers <- function(x, id = NULL, name = NULL, token = Sys.getenv("ARCGIS_TOK
  )
  }
 
+ UseMethod("get_layers")
+}
+
+#' @export
+get_layers.default <- function(x, id = NULL, name = NULL, token = Sys.getenv("ARCGIS_TOKEN")) {
+
  if (!is.null(id)) {
  # cast as integer
  id <- as.integer(id)
@@ -149,7 +229,7 @@ get_layers <- function(x, id = NULL, name = NULL, token = Sys.getenv("ARCGIS_TOK
  in_names <- name %in% valid_names
  baddies <- name[!in_names]
 
- if (length(baddies > 1)) {
+ if (length(baddies) > 1) {
  cli::cli_warn("Invalid item names{?s}: {.val {baddies}}")
  }
 
@@ -173,3 +253,69 @@ get_layers <- function(x, id = NULL, name = NULL, token = Sys.getenv("ARCGIS_TOK
 
  lapply(item_urls, arc_open)
 }
+
+
+#' @export
+get_layers.GroupLayer <- function(
+ x,
+ id = NULL,
+ name = NULL,
+ token = Sys.getenv("ARCGIS_TOKEN")
+) {
+ if (!is.null(id)) {
+ # cast as integer
+ id <- as.integer(id)
+
+ # ensure that all elements of `id` are in the layers
+ in_ids <- id %in% x[["subLayers"]][["id"]]
+
+ # if not report and remove
+ baddies <- id[!in_ids]
+
+ if (length(baddies) > 1) {
+ cli::cli_warn("Invalid ID{?s}: {.val {as.character(baddies)}}")
+ }
+
+ all_layer_ids <- id[in_ids]
+
+ item_urls <- vapply(
+ all_layer_ids,
+ function(.x) sub("\\d+$", .x, x[["url"]]),
+ character(1)
+ )
+
+ } else if (!is.null(name)) {
+ valid_names <- x[["subLayers"]][["name"]]
+
+ # validate names
+ in_names <- name %in% valid_names
+ baddies <- name[!in_names]
+
+ if (length(baddies) > 1) {
+ cli::cli_warn("Invalid item names{?s}: {.val {baddies}}")
+ }
+
+ # create lookup table for fetching ids
+ lu <- stats::setNames(x[["subLayers"]][["id"]], valid_names)
+
+ all_layer_ids <- unname(lu[name[in_names]])
+
+ item_urls <- vapply(
+ all_layer_ids,
+ function(.x) sub("\\d+$", .x, x[["url"]]),
+ character(1)
+ )
+
+ }
+
+ if (length(item_urls) < 1) {
+ cli::cli_abort(
+ c(
+ "No valid items to return.",
+ i = "Ensure 1 or more valid {.arg id} or {.arg name} value is provided."
+ )
+ )
+ }
+
+ lapply(item_urls, arc_open)
+}

tests/testthat.R

@@ -5,7 +5,6 @@
 # Learn more about the roles of various files in:
 # * https://r-pkgs.org/tests.html
 # * https://testthat.r-lib.org/reference/test_package.html#special-files
-
 # library(testthat)
 # library(arcgislayers)
 #

tests/testthat/_snaps/get-all-layers.md

@@ -0,0 +1,85 @@
+# get_all_layers(): FeatureServer
+
+ Code
+  get_all_layers(fsrv)
+ Output
+  $layers
+  $layers$`0`
+  <FeatureLayer>
+  Name: states_hex
+  Geometry Type: esriGeometryPolygon
+  CRS: 4326
+  Capabilities: Query
+  
+  $layers$`1`
+  <FeatureLayer>
+  Name: states_con
+  Geometry Type: esriGeometryPolygon
+  CRS: 4326
+  Capabilities: Query
+  
+  $layers$`2`
+  <FeatureLayer>
+  Name: hexagons
+  Geometry Type: esriGeometryPolygon
+  CRS: 4326
+  Capabilities: Query
+  
+  
+
+# get_all_layers(): MapLayer
+
+ Code
+  get_all_layers(msrv)
+ Output
+  $layers
+  $layers$`0`
+  <FeatureLayer>
+  Name: Census Block Points
+  Geometry Type: esriGeometryPoint
+  CRS: 4269
+  Capabilities: Map,Query,Data
+  
+  $layers$`1`
+  <FeatureLayer>
+  Name: Census Block Group
+  Geometry Type: esriGeometryPolygon
+  CRS: 4269
+  Capabilities: Map,Query,Data
+  
+  $layers$`2`
+  <FeatureLayer>
+  Name: Detailed Counties
+  Geometry Type: esriGeometryPolygon
+  CRS: 4269
+  Capabilities: Map,Query,Data
+  
+  $layers$`3`
+  <FeatureLayer>
+  Name: states
+  Geometry Type: esriGeometryPolygon
+  CRS: 4269
+  Capabilities: Map,Query,Data
+  
+  
+
+# get_all_layers(): GroupLayer
+
+ Code
+  get_all_layers(glyr)
+ Output
+  [[1]]
+  <FeatureLayer>
+  Name: Bus Stops
+  Geometry Type: esriGeometryPoint
+  CRS: 2248
+  Capabilities: Map,Query,Data
+  
+  [[2]]
+  <FeatureLayer>
+  Name: Bus Routes
+  Geometry Type: esriGeometryPolyline
+  CRS: 2248
+  Capabilities: Map,Query,Data
+  
+