Merge pull request #180 from elipousson/R-ArcGIS-main

Add support for alias parameter per #169

NAMESPACE

@@ -34,6 +34,7 @@ export(match_spatial_rel)
 export(prepare_spatial_filter)
 export(publish_item)
 export(publish_layer)
+export(pull_field_aliases)
 export(refresh_layer)
 export(truncate_layer)
 export(update_features)

NEWS.md

@@ -1,3 +1,9 @@
+# arcgislayers (development)
+
+- Add `alias` argument to `arc_read()` allowing replacement or labelling of field names with alias values (#169)
+- Add `pull_field_aliases()` utility function
+- `arc_select()` now uses `arcgisutils::rbind_results()` for faster row-binding if `{collapse}`, `{data.table}`, `{vctrs}` are installed (#175)
+
 # arcgislayers 0.2.0
 
 - initial CRAN release

R/arc-read.R

@@ -1,35 +1,53 @@
 #' Read an ArcGIS FeatureLayer, Table, or ImageServer
 #'
 #' [arc_read()] combines the functionality of [arc_open()] with [arc_select()]
-#' or [arc_raster()] to read an ArcGIS `FeatureLayer`, `Table`, or `ImageServer` to an
-#' `sf` or `SpatRaster` object. Optionally, set, check, or modify
-#' names for the returned data frame or sf object using the `col_names` and
-#' `name_repair` parameters.
+#' or [arc_raster()] to read an ArcGIS `FeatureLayer`, `Table`, or `ImageServer`
+#' to an `sf` or `SpatRaster` object. Optionally, set, check, or modify names
+#' for the returned data frame or sf object using the `col_names` and
+#' `name_repair` parameters. For ease of use and convenience, [arc_read()]
+#' allows users to access and query a FeatureLayer, Table, or ImageServer with a
+#' single function call instead of combining [arc_open()] and [arc_select()].
+#' The conventions of `col_select` are based on functions for reading tabular
+#' data in the `{readr}` package.
 #'
 #' `r lifecycle::badge("experimental")`
 #'
 #' @inheritParams arc_open
-#' @param col_names Default `TRUE`. If `TRUE`, use the default column names for
-#'   the feature. If `col_names` is a character vector with the same length as
-#'   the number of columns in the layer, the default names are replaced with the
-#'   new names. If `col_names` has one fewer name than the default column names,
-#'   the existing sf column name is retained. If `col_names` is the string
-#'   `"alias"`, names are set to match the alias names for the layer, if available.
+#' @param col_names Default `TRUE`. Column names or name handling rule.
+#'   `col_names` can be `TRUE`, `FALSE`, `NULL`, or a character vector:
+#'
+#'  - If `TRUE`, use existing default column names for the layer or table.
+#'  If `FALSE` or `NULL`, column names will be generated automatically: X1, X2,
+#'  X3 etc.
+#'  - If `col_names` is a character vector, values replace the existing column
+#'  names. `col_names` can't be length 0 or longer than the number of fields in
+#'  the returned layer.
 #' @param col_select Default `NULL`. A character vector of the field names to be
 #'   returned. By default, all fields are returned.
-#' @param n_max Defaults to 10000 or an option set with
+#' @param n_max Defaults to `Inf` or an option set with
 #'   `options("arcgislayers.n_max" = <max records>)`. Maximum number of records
 #'   to return.
+#' @param alias Use of field alias values. Default `c("drop", "label",
+#'   "replace"),`. There are three options:
+#'
+#'  - `"drop"`, field alias values are ignored.
+#'  - `"label"`: field alias values are assigned as a label attribute for each field.
+#'  - `"replace"`: field alias values replace existing column names. `col_names`
+#'  must `TRUE` for this option to be applied.
+#' @param fields Default `NULL`. a character vector of the field names to
+#'   returned. By default all fields are returned. Ignored if `col_names` is
+#'   supplied.
 #' @inheritParams arc_select
 #' @inheritParams arc_raster
 #' @param name_repair Default `"unique"`. See [vctrs::vec_as_names()] for
 #'   details. If `name_repair = NULL`, names are set directly.
 #' @param ... Additional arguments passed to [arc_select()] if URL is a
 #'   `FeatureLayer` or `Table` or [arc_raster()] if URL is an `ImageLayer`.
 #' @returns An sf object, a `data.frame`, or an object of class `SpatRaster`.
+#' @seealso [arc_select()]; [arc_raster()]
 #' @examples
 #' \dontrun{
-#'   furl <- "https://sampleserver6.arcgisonline.com/arcgis/rest/services/Census#' /MapServer/3"
+#'   furl <- "https://sampleserver6.arcgisonline.com/arcgis/rest/services/Census/MapServer/3"
 #'
 #'   # read entire service
 #'   arc_read(furl)
@@ -63,114 +81,208 @@ arc_read <- function(
     url,
     col_names = TRUE,
     col_select = NULL,
-    n_max = getOption("arcgislayers.n_max", default = 10000),
+    n_max = Inf,
     name_repair = "unique",
     crs = NULL,
     ...,
     fields = NULL,
-    token = arc_token()
-) {
-  service <- arc_open(url = url, token = token)
+    alias = c("drop", "label", "replace"),
+    token = arc_token()) {
+  x <- arc_open(url = url, token = token)
 
-  crs <- crs %||% sf::st_crs(service)
+  # Default crs must be NULL since crs can't be taken from x at execution
+  crs <- crs %||% sf::st_crs(x)
 
-  # if the server is an ImageServer we use arc_raster
-  if (inherits(service, "ImageServer")) {
+  # if the server is an ImageServer use arc_raster
+  if (inherits(x, "ImageServer")) {
     layer <- arc_raster(
-      x = service,
+      x = x,
       ...,
       crs = crs,
       token = token
     )
 
     return(layer)
-
-  } else if (!obj_is_layer(service)) {
+  } else if (!obj_is_layer(x)) {
     # if it is not a layer we abort
     # implicitly checks for Layer type and permits continuing
     cli::cli_abort(
       c(
         "{.arg url} is not a supported type:
       {.val FeatureLayer}, {.val Table}, or {.val ImageServer}",
-        "i" = "found {.val {class(service)}}"
+        "i" = "found {.val {class(x)}}"
       )
     )
   }
 
+  # TODO: Should this pattern be implemented for arc_select?
+  if (is.infinite(n_max) && is.numeric(getOption("arcgislayers.n_max"))) {
+    n_max <- getOption("arcgislayers.n_max")
+  }
+
   layer <- arc_select(
-    x = service,
+    x = x,
     fields = col_select %||% fields,
     crs = crs,
     n_max = n_max,
     token = token,
     ...
   )
 
-  set_layer_names(
+  set_layer_col_names(
     layer,
     col_names = col_names,
     name_repair = name_repair,
-    alias = service[["fields"]][["alias"]]
+    alias = alias,
+    x = x
   )
 }
 
 #' Set names for layer or table
-#'
 #' @noRd
-set_layer_names <- function(
-    x,
-    col_names = NULL,
+set_layer_col_names <- function(
+    layer,
+    col_names = TRUE,
     name_repair = NULL,
-    alias = NULL,
-    call = rlang::caller_env()
-) {
-  layer_nm <- names(x)
+    alias = c("drop", "label", "replace"),
+    x = NULL,
+    call = rlang::caller_env()) {
+  # check col_names input
+  if (!is.null(col_names) && !rlang::is_logical(col_names) && !is.character(col_names)) {
+    cli::cli_abort(
+      "{.arg col_names} must be `TRUE`, `FALSE`, `NULL`, or a character vector.",
+      call = call
+    )
+  }
+
+  alias <- rlang::arg_match(alias, error_call = call)
+
+  # skip col_names and alias handling if possible
+  if (rlang::is_true(col_names) && alias == "drop") {
+    return(repair_layer_names(layer, name_repair = name_repair, call = call))
+  }
+
+  existing_nm <- names(layer)
+  n_col <- ncol(layer)
+  sf_column <- attr(layer, "sf_column")
 
   # Use existing names by default
-  nm <- layer_nm
-  sf_column_nm <- attr(x, "sf_column")
+  replace_nm <- existing_nm
+
+  if (alias != "drop" || identical(col_names, "alias")) {
+    # get alias values and drop names
+    alias_val <- pull_field_aliases(x)[setdiff(existing_nm, sf_column)]
+    alias_val <- as.character(alias_val)
+
+    if (alias == "replace") {
+      # NOTE: alias values may not be valid names
+      replace_nm <- alias_val
+    }
+  }
 
   if (is.character(col_names)) {
-    # Assign alias values as name if col_names = "alias"
+    col_names_len <- length(col_names)
+
+    # Check col_names length
+    if ((col_names_len > n_col) || col_names_len == 0) {
+      cli::cli_abort(
+        "{.arg col_names} must be length {n_col}{? or shorter}, not {col_names_len}.",
+        call = call
+      )
+    }
+
     if (identical(col_names, "alias")) {
-      col_names <- alias
+      # Assign alias values as name if col_names = "alias"
+      col_names <- alias_val
+      lifecycle::signal_stage(
+        "superseded",
+        what = "arc_read(col_names = \"can't be alias\")",
+        with = "arc_read(alias = \"replace\")",
+      )
     }
 
-    nm <- col_names
+    replace_nm <- col_names
   }
 
-  nm_len <- length(nm)
-
-  if (rlang::is_false(col_names)) {
+  if (rlang::is_false(col_names) || is.null(col_names)) {
     # Use X1, X2, etc. as names if col_names is FALSE
-    nm <- paste0("X", seq(to = nm_len))
+    replace_nm <- paste0("X", seq_along(existing_nm))
   }
 
-  # If x is a sf object and sf column is not in names, check to ensure names
-  # work with geometry column
-  if (inherits(x, "sf") && sf_column_nm != nm[[nm_len]]) {
-    layer_nm_len <- length(layer_nm)
-    if (length(nm) == layer_nm_len) {
-      # If same number of names as layer columns, use last name for geometry
-      x <- sf::st_set_geometry(x, nm[[length(layer_nm)]])
-    } else if (length(nm) == (layer_nm_len - 1)) {
-      # If same number of names as layer columns, use existing geometry name
-      nm <- c(nm, sf_column_nm)
+  replace_nm_len <- length(replace_nm)
+
+  if (replace_nm_len < n_col) {
+    # fill missing field names using pattern, X1, X2, etc.
+    replace_nm <- c(replace_nm, paste0("X", seq(replace_nm_len + 1, n_col)))
+
+    # But keep the default sf column name
+    if (inherits(layer, "sf")) {
+      replace_nm[[n_col]] <- sf_column
     }
   }
 
+  layer <- repair_layer_names(
+    layer,
+    names = replace_nm,
+    name_repair = name_repair,
+    call = call
+  )
+
+  if (alias != "label") {
+    return(layer)
+  }
+
+  # Name alias values with layer names
+  alias_val <- rlang::set_names(
+    alias_val,
+    nm = setdiff(replace_nm, sf_column)
+  )
+
+  label_layer_fields(layer, values = alias_val)
+}
+
+#' Repair layer names using `vctrs::vec_as_names` and `rlang::set_names`
+#' @noRd
+repair_layer_names <- function(
+    layer,
+    names = NULL,
+    name_repair = "unique",
+    call = rlang::caller_env()) {
+  names <- names %||% colnames(layer)
+
   if (!is.null(name_repair)) {
     rlang::check_installed("vctrs", call = call)
-    nm <- vctrs::vec_as_names(
-      names = nm,
+
+    names <- vctrs::vec_as_names(
+      names = names,
       repair = name_repair,
       repair_arg = "name_repair",
       call = call
     )
   }
 
-  rlang::set_names(
-    x,
-    nm = nm
-  )
+  rlang::set_names(layer, nm = names)
+}
+
+#' Apply a label attribute value to each column of layer
+#' @noRd
+label_layer_fields <- function(
+    layer,
+    values) {
+  nm <- intersect(names(values), colnames(layer))
+
+  for (v in nm) {
+    label_attr(layer[[v]]) <- values[[v]]
+  }
+
+  layer
+}
+
+#' Set label attribute
+#' @seealso [labelled::set_label_attribute()]
+#' @source <https://github.com/cran/labelled/blob/master/R/var_label.R>
+#' @noRd
+`label_attr<-` <- function(x, value) {
+  attr(x, "label") <- value
+  x
 }