Add set_layer_coded_values() and export set_layer_col_names()

NAMESPACE

@@ -39,6 +39,8 @@ export(publish_layer)
 export(pull_field_aliases)
 export(query_layer_attachments)
 export(refresh_layer)
+export(set_layer_coded_values)
+export(set_layer_col_names)
 export(truncate_layer)
 export(update_features)
 export(update_params)

NEWS.md

@@ -4,6 +4,8 @@
 ## New features
 
 - Improve handling of `filter_geom` by `arc_select()` by warning if applying `sf::st_union()` to the filter does not generate a length 1 sfc, or if `filter_geom` is supplied when accessing a Table, or if `filter_geom` is empty (@elipousson, #166)
+- Export `set_layer_col_names()` (previously used internally by `arc_read()`) to allow use of alias values with data returned by `arc_select()` (#169).
+- Add new `set_layer_coded_values()` function to support replacement or labelling of values with coded value domains (#134).
 
 ## Bug fixes
 

R/arc-read.R

@@ -13,34 +13,17 @@
 #' `r lifecycle::badge("experimental")`
 #'
 #' @inheritParams arc_open
-#' @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 `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.
+#' @inheritParams set_layer_col_names
 #' @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`.
@@ -62,7 +45,7 @@
 #'   )
 #'
 #'  # use field aliases as column names
-#'  arc_read(furl, col_names = "alias")
+#'  arc_read(furl, alias = "replace")
 #'
 #'  # read an ImageServer directly
 #'  img_url <- "https://landsat2.arcgis.com/arcgis/rest/services/Landsat/MS/ImageServer"
@@ -130,22 +113,49 @@ arc_read <- function(
   )
 
   set_layer_col_names(
-    layer,
+    .data = layer,
+    .layer = x,
     col_names = col_names,
     name_repair = name_repair,
-    alias = alias,
-    x = x
+    alias = alias
   )
 }
 
-#' Set names for layer or table
-#' @noRd
+#' Set and repair column names for FeatureLayer or Table data frame
+#'
+#' [set_layer_col_names()] can replace or label column names based on the the
+#' field aliases from a corresponding `Table` or `FeatureLayer` object created
+#' with `arc_open()`. Optionally repair names using [vctrs::vec_as_names()].
+#'
+#' @param .data A data frame returned by `arc_select() `or `arc_read()`.
+#' @param .layer A Table or FeatureLayer object. Required if `alias` is `"label"` or
+#'   `"replace"`.
+#' @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 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 name_repair Default `"unique"`. See [vctrs::vec_as_names()] for
+#'   details. If `name_repair = NULL`, names are set directly.
+#' @inheritParams rlang::args_error_context
+#' @export
 set_layer_col_names <- function(
-    layer,
+    .data,
+    .layer = NULL,
     col_names = TRUE,
     name_repair = NULL,
     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)) {
@@ -159,19 +169,19 @@ set_layer_col_names <- function(
 
   # 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))
+    return(repair_layer_names(.data, name_repair = name_repair, call = call))
   }
 
-  existing_nm <- names(layer)
-  n_col <- ncol(layer)
-  sf_column <- attr(layer, "sf_column")
+  existing_nm <- names(.data)
+  n_col <- ncol(.data)
+  sf_column <- attr(.data, "sf_column")
 
   # Use existing names by default
   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 <- pull_field_aliases(.layer)[setdiff(existing_nm, sf_column)]
     alias_val <- as.character(alias_val)
 
     if (alias == "replace") {
@@ -216,20 +226,20 @@ set_layer_col_names <- function(
     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")) {
+    if (inherits(.data, "sf")) {
       replace_nm[[n_col]] <- sf_column
     }
   }
 
-  layer <- repair_layer_names(
-    layer,
+  .data <- repair_layer_names(
+    .data,
     names = replace_nm,
     name_repair = name_repair,
     call = call
   )
 
   if (alias != "label") {
-    return(layer)
+    return(.data)
   }
 
   # Name alias values with layer names
@@ -238,7 +248,7 @@ set_layer_col_names <- function(
     nm = setdiff(replace_nm, sf_column)
   )
 
-  label_layer_fields(layer, values = alias_val)
+  label_layer_fields(.data, values = alias_val)
 }
 
 #' Repair layer names using `vctrs::vec_as_names` and `rlang::set_names`
@@ -286,3 +296,88 @@ label_layer_fields <- function(
   attr(x, "label") <- value
   x
 }
+
+
+#' Set coded values for FeatureLayer or Table data frame
+#'
+#' [set_layer_coded_values()] can replace column values based on `codedValue`
+#' type field domains from a corresponding `Table` or `FeatureLayer` object
+#' created with `arc_open()`.
+#'
+#' @param .data A data frame returned by `arc_select()` or `arc_read()`.
+#' @param .layer A Table or FeatureLayer object. Required.
+#' @param field Default `NULL`. Field or fields to replace. Fields that are do
+#'   not have coded values domains are ignored.
+#' @param codes Use of field alias values. Default `c("replace"),`.
+#' There are two options:
+#'
+#'  - `"replace"`: coded values replace existing column values.
+#'  - `"label"`: coded values are applied as value labels.
+#' @inheritParams rlang::args_error_context
+#' @export
+set_layer_coded_values <- function(
+    .data,
+    .layer,
+    field = NULL,
+    codes = c("replace", "label"),
+    call = rlang::caller_env()) {
+  values <- pull_coded_values(.layer, field = field)
+
+  # Check if coded values is an empty list
+  if (rlang::is_empty(values)) {
+    if (is.null(field)) {
+      cli::cli_warn(
+        "{.arg layer} does not contain any coded values."
+      )
+    } else {
+      cli::cli_warn(
+        "{.arg field} does not specific any coded value fields."
+      )
+    }
+
+    return(.data)
+  }
+
+  codes <- rlang::arg_match(codes, error_call = call)
+
+  if (codes == "replace") {
+    # Replace column values by default
+    for (col in names(values)) {
+      .data[[col]] <- values[[col]][.data[[col]]]
+    }
+  } else {
+    # Label column values using new_labelled_col helper
+    for (col in names(values)) {
+      .data[[col]] <- new_labelled_col(
+        .data[[col]],
+        labels = rlang::set_names(
+          names(values[[col]]),
+          values[[col]]
+        ),
+        call = call
+      )
+    }
+  }
+
+  .data
+}
+
+#' Set value labels compatible w/ `haven::labelled` package
+#' @noRd
+new_labelled_col <- function(x,
+                             labels = NULL,
+                             label = NULL,
+                             ...,
+                             class = character(),
+                             call = rlang::caller_env()) {
+  rlang::check_installed("vctrs", call = call)
+
+  vctrs::new_vctr(
+    x,
+    labels = rlang::set_names(labels, names(labels)),
+    label = label,
+    ...,
+    class = c(class, "haven_labelled"),
+    inherit_base_type = TRUE
+  )
+}

R/utils.R

@@ -263,3 +263,41 @@ parse_url_query <- function(url, keep_default = FALSE) {
   url_elements[["query"]]
 }
 
+#' @noRd
+list_field_domains <- function(x, field = NULL, keep_null = FALSE) {
+  fields <- list_fields(x)
+  nm <- fields[["name"]]
+
+  domains <- rlang::set_names(fields[["domain"]], nm)
+
+  if (!is.null(field)) {
+    field <- rlang::arg_match(nm, multiple = TRUE)
+    domains <- domains[nm %in% field]
+  }
+
+  if (keep_null) {
+    return(domains)
+  }
+
+  domains[!vapply(domains, is.null, logical(1))]
+}
+
+#' @noRd
+pull_coded_values <- function(x, field = NULL) {
+  domains <- list_field_domains(x, field = field, keep_null = FALSE)
+
+  domains <- lapply(
+    domains,
+    \(x)  {
+      if (x[["type"]] != "codedValue") {
+        return(NULL)
+      }
+
+      values <- x[["codedValues"]]
+
+      rlang::set_names(values[["name"]], values[["code"]])
+    }
+  )
+
+  domains
+}

_pkgdown.yml

@@ -45,4 +45,4 @@ reference:
   - prepare_spatial_filter
   - match_spatial_rel
   - update_params
-
+  - starts_with("set_layer")