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
+
+