From adf8d49de516029aec742301d33a183e1742cf96 Mon Sep 17 00:00:00 2001 From: your name Date: Tue, 9 Apr 2024 00:33:33 -0400 Subject: [PATCH 1/5] Fix #175 Also implement new rbind_results function added w/ https://github.com/R-ArcGIS/arcgisutils/issues/38 --- R/arc-select.R | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/R/arc-select.R b/R/arc-select.R index 5c9c217..efaa01e 100644 --- a/R/arc-select.R +++ b/R/arc-select.R @@ -291,18 +291,27 @@ collect_layer <- function( # all_resps[!has_error], function(x) { parse_esri_json( - httr2::resp_body_string(x) - ) + httr2::resp_body_string(x), + call = error_call + ) } ) - # combine - # TODO enhance this with suggested packages similar to arcpbf - res <- do.call(rbind, res) + # combine results + res <- rbind_results(res, call = error_call) + + out_fields <- query[["outFields"]] + + # Drop fields that aren't selected to avoid returning objectID + if (rlang::is_named(res) && !is.null(out_fields) && !identical(out_fields, "*")) { + out_fields <- c(out_fields, attr(res, "sf_column")) + res_nm <- names(res) + res <- res[ , tolower(res_nm) %in% tolower(out_fields), drop = FALSE] + } - if (is.null(res)) { + if (rlang::is_empty(res)) { cli::cli_alert_info("No features returned from query") - return(data.frame()) + return(res) } if (inherits(res, "sf") && is.na(sf::st_crs(res))) { From 1c8ed4150daffdc3b402335033a2eb300d9f0f40 Mon Sep 17 00:00:00 2001 From: your name Date: Tue, 9 Apr 2024 00:49:41 -0400 Subject: [PATCH 2/5] Avoid collapsing fields prematurely Also add match_fields helper --- R/arc-select.R | 58 +++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 45 insertions(+), 13 deletions(-) diff --git a/R/arc-select.R b/R/arc-select.R index efaa01e..2640035 100644 --- a/R/arc-select.R +++ b/R/arc-select.R @@ -107,7 +107,7 @@ arc_select <- function( } # handle fields and where clause if missing - fields <- fields %||% query[["outFields"]] %||% "*" + fields <- fields %||% query[["outFields"]] # if not missing fields collapse to scalar character if (length(fields) > 1) { @@ -122,14 +122,17 @@ arc_select <- function( "Field{?s} not in {.arg x}: {.var {fields[!nindex]}}" ) } - # collapse together - fields <- paste0(fields, collapse = ",") } + # handle fields and where clause if missing + fields <- match_fields( + fields = fields %||% query[["outFields"]], + values = x[["fields"]][["name"]] + ) + query[["outFields"]] <- fields - # if where is missing set to 1=1 - query[["where"]] <- where %||% query[["where"]] %||% "1=1" + query[["where"]] <- where %||% query[["where"]] # set returnGeometry depending on on geometry arg query[["returnGeometry"]] <- geometry @@ -215,6 +218,10 @@ collect_layer <- function( query[["outSR"]] <- jsonify::to_json(validate_crs(sf::st_crs(x))[[1]], unbox = TRUE) } + # retain outFields vector and create flag + out_fields <- query[["outFields"]] + has_out_fields <- !is.null(out_fields) && !identical(out_fields, "*") + # parameter validation ---------------------------------------------------- # get existing parameters query_params <- validate_params(query) @@ -300,10 +307,9 @@ collect_layer <- function( # combine results res <- rbind_results(res, call = error_call) - out_fields <- query[["outFields"]] - - # Drop fields that aren't selected to avoid returning objectID - if (rlang::is_named(res) && !is.null(out_fields) && !identical(out_fields, "*")) { + # Drop fields that aren't selected to avoid returning OBJECTID when not + # selected + if (rlang::is_named(res) && has_out_fields) { out_fields <- c(out_fields, attr(res, "sf_column")) res_nm <- names(res) res <- res[ , tolower(res_nm) %in% tolower(out_fields), drop = FALSE] @@ -435,12 +441,15 @@ add_offset <- function(.req, .offset, .page_size, .params) { #' @keywords internal #' @noRd validate_params <- function(params) { - - # if output fields are missing set to "*" - if (is.null(params[["outFields"]])) params[["outFields"]] <- "*" + if (!is.null(params[["outFields"]])) { + params[["outFields"]] <- paste0(params[["outFields"]], collapse = ",") + } else { + # if output fields are missing set to "*" + params[["outFields"]] <- "*" + } # if where is missing set it to 1=1 - if (is.null(params[["where"]])) params[["where"]] <- "1=1" + params[["where"]] <- params[["where"]] %||% "1=1" # set output type to geojson if we return geometry, json if not if (is.null(params[["returnGeometry"]]) || isTRUE(params[["returnGeometry"]])) { @@ -470,3 +479,26 @@ count_results <- function(req, query) { RcppSimdJson::fparse(resp)[["count"]] } +#' Validate fields +#' +#' [validate_fields()] ensures that fields passed to [arc_select()] match +#' permissible values. +#' +#' @keywords internal +#' @noRd +match_fields <- function(fields, values = NULL, multiple = TRUE, error_call = rlang::caller_env()) { + if (is.null(fields) || identical(fields, "*")) { + return(fields) + } + + if (all(tolower(fields) %in% tolower(values))) { + return(fields) + } + + rlang::arg_match( + fields, + values = values, + multiple = multiple, + error_call = error_call + ) +} From 10793c770af4d94fbe5ed57035d65d90f70da27b Mon Sep 17 00:00:00 2001 From: Eli Pousson Date: Tue, 9 Apr 2024 13:54:18 -0400 Subject: [PATCH 3/5] Reference to match_fields not validate_fields in docs Co-authored-by: Josiah Parry --- R/arc-select.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/arc-select.R b/R/arc-select.R index 2640035..8f7249b 100644 --- a/R/arc-select.R +++ b/R/arc-select.R @@ -479,9 +479,9 @@ count_results <- function(req, query) { RcppSimdJson::fparse(resp)[["count"]] } -#' Validate fields +#' Match fields #' -#' [validate_fields()] ensures that fields passed to [arc_select()] match +#' [match_fields()] ensures that fields passed to [arc_select()] match #' permissible values. #' #' @keywords internal From ae2cd8b15d5ef038e9216001e0f99d55369842ad Mon Sep 17 00:00:00 2001 From: your name Date: Tue, 9 Apr 2024 14:07:56 -0400 Subject: [PATCH 4/5] Remove duplicative check for fields Also expose error_arg parameter for match_fields --- R/arc-select.R | 25 +++++++------------------ 1 file changed, 7 insertions(+), 18 deletions(-) diff --git a/R/arc-select.R b/R/arc-select.R index 8f7249b..d5c63f8 100644 --- a/R/arc-select.R +++ b/R/arc-select.R @@ -109,24 +109,8 @@ arc_select <- function( # handle fields and where clause if missing fields <- fields %||% query[["outFields"]] - # if not missing fields collapse to scalar character - if (length(fields) > 1) { - # check if incorrect field names provided - x_fields <- x[["fields"]][["name"]] - nindex <- tolower(fields) %in% tolower(x_fields) - - # handle the case where a field is being selected that - # is not one of the available fields in the feature layer - if (any(!nindex)) { - cli::cli_abort( - "Field{?s} not in {.arg x}: {.var {fields[!nindex]}}" - ) - } - } - - # handle fields and where clause if missing fields <- match_fields( - fields = fields %||% query[["outFields"]], + fields = fields, values = x[["fields"]][["name"]] ) @@ -486,7 +470,11 @@ count_results <- function(req, query) { #' #' @keywords internal #' @noRd -match_fields <- function(fields, values = NULL, multiple = TRUE, error_call = rlang::caller_env()) { +match_fields <- function(fields, + values = NULL, + multiple = TRUE, + error_arg = rlang::caller_arg(fields), + error_call = rlang::caller_env()) { if (is.null(fields) || identical(fields, "*")) { return(fields) } @@ -499,6 +487,7 @@ match_fields <- function(fields, values = NULL, multiple = TRUE, error_call = rl fields, values = values, multiple = multiple, + error_arg = error_arg, error_call = error_call ) } From 4d17d79d5859a9995d874e90c19bf89f944f3025 Mon Sep 17 00:00:00 2001 From: Josiah Parry Date: Wed, 10 Apr 2024 07:36:59 -0400 Subject: [PATCH 5/5] add tests to arc_select() for returning the correct fields. Allows users to return no fields by providing an empty character string --- R/arc-select.R | 61 +++++++++---------- tests/testthat/test-returned-fields.R | 88 +++++++++++++++++++++++++++ 2 files changed, 116 insertions(+), 33 deletions(-) create mode 100644 tests/testthat/test-returned-fields.R diff --git a/R/arc-select.R b/R/arc-select.R index d5c63f8..2830697 100644 --- a/R/arc-select.R +++ b/R/arc-select.R @@ -42,24 +42,24 @@ #' @export #' @examples #' \dontrun{ -#' # define the feature layer url -#' furl <- paste0( -#' "https://services3.arcgis.com/ZvidGQkLaDJxRSJ2/arcgis/rest", -#' "/services/PLACES_LocalData_for_BetterHealth/FeatureServer/0" -#' ) +#' # define the feature layer url +#' furl <- paste0( +#' "https://services3.arcgis.com/ZvidGQkLaDJxRSJ2/arcgis/rest", +#' "/services/PLACES_LocalData_for_BetterHealth/FeatureServer/0" +#' ) #' -#' flayer <- arc_open(furl) +#' flayer <- arc_open(furl) #' -#' arc_select( -#' flayer, -#' fields = c("StateAbbr", "TotalPopulation") -#' ) +#' arc_select( +#' flayer, +#' fields = c("StateAbbr", "TotalPopulation") +#' ) #' -#' arc_select( -#' flayer, -#' fields = c("OBJECTID", "PlaceName"), -#' where = "TotalPopulation > 1000000" -#' ) +#' arc_select( +#' flayer, +#' fields = c("OBJECTID", "PlaceName"), +#' where = "TotalPopulation > 1000000" +#' ) #' } #' @returns An sf object, or a data.frame arc_select <- function( @@ -73,9 +73,7 @@ arc_select <- function( predicate = "intersects", n_max = Inf, page_size = NULL, - token = arc_token() -) { - + token = arc_token()) { # Developer note: # For this function we extract the query object and manipulate the elements # inside of the query object to modify our request. We then splice those @@ -111,7 +109,7 @@ arc_select <- function( fields <- match_fields( fields = fields, - values = x[["fields"]][["name"]] + values = c(x[["fields"]][["name"]], "") ) query[["outFields"]] <- fields @@ -157,9 +155,7 @@ collect_layer <- function( token = arc_token(), page_size = NULL, ..., - error_call = rlang::caller_env() -) { - + error_call = rlang::caller_env()) { if (length(page_size) > 1) { cli::cli_abort("{.arg page_size} must be length 1 not {length(page_size)}") } else if (!is.null(page_size) && page_size < 1) { @@ -178,8 +174,7 @@ collect_layer <- function( req <- arc_base_req(x[["url"]], token) # determine if the layer can query - can_query <- switch( - class(x), + can_query <- switch(class(x), "FeatureLayer" = grepl("query", x[["capabilities"]], ignore.case = TRUE), "Table" = grepl("query", x[["capabilities"]], ignore.case = TRUE), "ImageServer" = x[["supportsAdvancedQueries"]], @@ -245,7 +240,8 @@ collect_layer <- function( if (is.null(n_feats)) { cli::cli_abort( c("Can't determine the number of features for {.arg x}.", - "*" = "Check to make sure your {.arg where} statement is valid."), + "*" = "Check to make sure your {.arg where} statement is valid." + ), call = error_call ) } @@ -296,7 +292,7 @@ collect_layer <- function( if (rlang::is_named(res) && has_out_fields) { out_fields <- c(out_fields, attr(res, "sf_column")) res_nm <- names(res) - res <- res[ , tolower(res_nm) %in% tolower(out_fields), drop = FALSE] + res <- res[, tolower(res_nm) %in% tolower(out_fields), drop = FALSE] } if (rlang::is_empty(res)) { @@ -309,7 +305,6 @@ collect_layer <- function( } res - } @@ -378,13 +373,13 @@ check_inherits_any <- function(x, #' @export #' @examples #' \dontrun{ -#' furl <- paste0( -#' "https://services.arcgis.com/P3ePLMYs2RVChkJx/ArcGIS/rest/services/", -#' "USA_Major_Cities_/FeatureServer/0" -#' ) +#' furl <- paste0( +#' "https://services.arcgis.com/P3ePLMYs2RVChkJx/ArcGIS/rest/services/", +#' "USA_Major_Cities_/FeatureServer/0" +#' ) #' -#' flayer <- arc_open(furl) -#' update_params(flayer, outFields = "NAME") +#' flayer <- arc_open(furl) +#' update_params(flayer, outFields = "NAME") #' } #' @returns An object of the same class as `x` update_params <- function(x, ...) { diff --git a/tests/testthat/test-returned-fields.R b/tests/testthat/test-returned-fields.R new file mode 100644 index 0000000..e7c4397 --- /dev/null +++ b/tests/testthat/test-returned-fields.R @@ -0,0 +1,88 @@ +# Tests to ensure that the correct fields are return + +furl <- "https://services.arcgis.com/P3ePLMYs2RVChkJx/ArcGIS/rest/services/USA_Major_Cities_/FeatureServer/0" + +flayer <- arc_open(furl) +# https://github.com/R-ArcGIS/arcgislayers/pull/179 +test_that("arc_select(x, fields = \"\"): returns no fields", { + res <- arc_select(flayer, fields = "") + expect_identical(colnames(res), "geometry") +}) + +test_that('arc_select(x, fields = "", geometry = NULL): returns 0 columns all rows', { + expect_identical( + dim(arc_select(flayer, fields = "", geometry = FALSE)), + c(4186L, 0L) + ) +}) + + +test_that('arc_select(flayer, fields = "state_abbr") does not include OID', { + res <- arc_select(flayer, fields = "state_abbr", n_max = 10) + expect_identical( + colnames(res), + c("STATE_ABBR", "geometry") + ) +}) + +test_that("arc_select() doesnt remove OID with fields", { + res <- arc_select( + flayer, + fields = c("state_abbr", "objectid"), n_max = 10 + ) + expect_identical( + colnames(res), + c("STATE_ABBR", "OBJECTID", "geometry") + ) +}) + +test_that("arc_select() with fields works on tables", { + furl <- paste0( + "https://services.arcgis.com/P3ePLMYs2RVChkJx/arcgis/rest/services/", + "USA_Wetlands/FeatureServer/1" + ) + + flayer <- arc_open(furl) + expect_no_error(arc_select(flayer, fields = "", n_max = 100)) + + res <- arc_select(flayer, fields = "objectid", n_max = 100) + expect_identical(colnames(res), "OBJECTID") + + + res <- arc_select(flayer, n_max = 100) + expect_identical( + colnames(res), + list_fields(flayer)[["name"]] + ) +}) + +test_that("arc_select() works with ImageServers", { + landsat <- arc_open( + "https://landsat2.arcgis.com/arcgis/rest/services/Landsat/MS/ImageServer" + ) + + + res <- arc_select(landsat, fields = "Name", n_max = 10) + + expect_identical( + colnames(res), + c("Name", "geometry") + ) + + expect_identical( + colnames(arc_select(landsat, fields = "objectid", n_max = 1)), + c("OBJECTID", "geometry") + ) + + expect_identical( + colnames( + arc_select( + landsat, + fields = c("name", "objectid"), + n_max = 1, + geometry = FALSE + ) + ), + c("Name", "OBJECTID") + ) +})