From 29d0eb11e7c6745aa31ccd1a60f1bb4635a3272e Mon Sep 17 00:00:00 2001 From: Steven Mortimer Date: Sun, 26 Jul 2020 18:42:04 -0400 Subject: [PATCH] Put errors into list since there may be more than 1 Fixes #66 --- DESCRIPTION | 4 +- NAMESPACE | 5 +- R/utils-query.R | 85 ++++++++++++++++++++++---- man/unbox_list_elements.Rd | 25 ++++++++ man/unbox_list_elements_recursively.Rd | 25 ++++++++ tests/testthat/test-rest.R | 27 ++++++++ tests/testthat/test-soap.R | 27 ++++++++ 7 files changed, 181 insertions(+), 17 deletions(-) create mode 100644 man/unbox_list_elements.Rd create mode 100644 man/unbox_list_elements_recursively.Rd diff --git a/DESCRIPTION b/DESCRIPTION index e400967b..5df95f48 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: salesforcer Title: An Implementation of 'Salesforce' APIs Using Tidy Principles -Version: 0.2.0.9001 -Date: 2020-07-22 +Version: 0.2.0.9002 +Date: 2020-07-26 Description: Functions connecting to the 'Salesforce' Platform APIs (REST, SOAP, Bulk 1.0, Bulk 2.0, Metadata, Reports and Dashboards) . diff --git a/NAMESPACE b/NAMESPACE index b6a49885..0cccdefb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -250,6 +250,8 @@ export(sf_write_csv) export(simplify_report_metadata) export(stop_w_errors_listed) export(token_available) +export(unbox_list_elements) +export(unbox_list_elements_recursively) export(unnest_col) export(valid_metadata_list) export(validate_get_all_jobs_params) @@ -333,6 +335,7 @@ importFrom(mime,guess_type) importFrom(purrr,as_mapper) importFrom(purrr,compact) importFrom(purrr,discard) +importFrom(purrr,list_modify) importFrom(purrr,map) importFrom(purrr,map_chr) importFrom(purrr,map_depth) @@ -370,10 +373,8 @@ importFrom(xml2,url_escape) importFrom(xml2,xml_add_child) importFrom(xml2,xml_add_sibling) importFrom(xml2,xml_child) -importFrom(xml2,xml_children) importFrom(xml2,xml_find_all) importFrom(xml2,xml_find_first) -importFrom(xml2,xml_name) importFrom(xml2,xml_new_document) importFrom(xml2,xml_ns_strip) importFrom(xml2,xml_remove) diff --git a/R/utils-query.R b/R/utils-query.R index 0a6cef92..d9150a7e 100644 --- a/R/utils-query.R +++ b/R/utils-query.R @@ -5,6 +5,7 @@ #' each record represents a row in the data frame. #' #' @importFrom tibble as_tibble_row +#' @importFrom purrr list_modify pluck #' @importFrom rlist list.flatten #' @param x \code{list}; a list to be extracted into a \code{tbl_df}. #' @return \code{tbl_df} parsed from the flattened list. @@ -12,7 +13,17 @@ #' @keywords internal #' @export flatten_tbl_df <- function(x){ - x %>% list.flatten() %>% as_tibble_row() + errors <- x %>% pluck("errors") + x_tbl <- x %>% + list_modify("errors" = NULL) %>% + list.flatten() %>% + as_tibble_row() + + if(!is.null(errors)){ + x_tbl$errors <- list(errors) + } + + return(x_tbl) } #' Flatten list column @@ -122,6 +133,46 @@ set_null_elements_to_na_recursively <- function(x) { set_null_elements_to_na() } +#' Unlist all list elements of length 1 if they are not a list +#' +#' This function wraps a simple \code{\link[purrr:modify]{modify_if}} function +#' to "unbox" list elements. This is helpful when the \code{\link[xml2]{as_list}} +#' returns elements of XML and the element value is kept as a list of length 1, +#' even though it could be a single primitive data type (e.g. \code{logical}, +#' \code{character}, etc.). +#' +#' @importFrom purrr modify_if +#' @param x \code{list}; a list to be cleaned. +#' @return \code{list} containing \code{NA} in place of \code{NULL} element values. +#' @note This function is meant to be used internally. Only use when debugging. +#' @keywords internal +#' @export +unbox_list_elements <- function(x){ + x %>% + modify_if(~((length(.x) == 1) && (!is.list(.x[[1]]))), + .f = function(x){return(unlist(x))}) +} + +#' Recursively unlist all list elements of length 1 if they are not a list +#' +#' This function wraps a simple \code{\link[purrr:modify]{modify_if}} function +#' to recursively "unbox" list elements. This is helpful when the +#' \code{\link[xml2]{as_list}} returns elements of XML and the element value is +#' kept as a list of length 1, even though it could be a single primitive data +#' type (e.g. \code{logical}, \code{character}, etc.). +#' +#' @importFrom purrr map_if +#' @param x \code{list}; a list to be cleaned. +#' @return \code{list} containing "unboxed" list elements. +#' @note This function is meant to be used internally. Only use when debugging. +#' @keywords internal +#' @export +unbox_list_elements_recursively <- function(x) { + x %>% + map_if(is.list, unbox_list_elements_recursively) %>% + unbox_list_elements() +} + #' Remove Salesforce attributes data from list #' #' This function removes elements from Salesforce data parsed to a list where @@ -257,10 +308,10 @@ xml_drop_and_unlist_recursively <- function(x) { #' This function accepts an \code{xml_node} assuming it already represents one #' record and formats that node into a single row \code{tbl_df}. #' -#' @importFrom dplyr mutate_all as_tibble +#' @importFrom dplyr tibble #' @importFrom tibble as_tibble_row -#' @importFrom xml2 xml_find_all xml_text as_list xml_find_first xml_children xml_name xml_remove -#' @importFrom purrr modify_if map_df +#' @importFrom xml2 xml_find_all as_list xml_remove xml_find_first xml_text +#' @importFrom purrr map #' @param node \code{xml_node}; the node to have records extracted into one row \code{tbl_df}. #' @param object_name_append \code{logical}; whether to include the object type #' (e.g. Account or Contact) as part of the column names (e.g. Account.Name). @@ -277,15 +328,18 @@ extract_records_from_xml_node <- function(node, # TODO: Consider doing something with the duplicate match data because what is returned # in the duplicateResult element is very detailed. For now just remove it # if(length(xml_find_all(node, "//errors[@xsi:type='DuplicateError']")) > 0){ - if(length(xml_find_first(node, "//errors | //error")) > 0){ - children <- xml_find_first(node, "//errors | //error") %>% xml_children() - for(i in 1:length(children)){ - if(!(xml_name(children[[i]]) %in% c("message", "statusCode", - "errorMessage", "errorCode"))){ - node_to_remove <- children[[i]] - xml_remove(node_to_remove) - } - } + error_nodes <- xml_find_all(node, ".//errors | .//error") + if(length(error_nodes) > 0){ + errors_list <- error_nodes %>% + # convert to list + as_list() %>% + # "unbox" length 1 list elements + map(unbox_list_elements_recursively) %>% + # return as a length 1 list, which is what the row requires (a single element) + list() + xml_remove(error_nodes) + } else { + errors_list <- list() } if(object_name_append | object_name_as_col){ @@ -308,6 +362,11 @@ extract_records_from_xml_node <- function(node, } else { x <- tibble() } + + if(length(errors_list) == 1){ + x$errors <- errors_list + } + return(x) } diff --git a/man/unbox_list_elements.Rd b/man/unbox_list_elements.Rd new file mode 100644 index 00000000..8008edeb --- /dev/null +++ b/man/unbox_list_elements.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-query.R +\name{unbox_list_elements} +\alias{unbox_list_elements} +\title{Unlist all list elements of length 1 if they are not a list} +\usage{ +unbox_list_elements(x) +} +\arguments{ +\item{x}{\code{list}; a list to be cleaned.} +} +\value{ +\code{list} containing \code{NA} in place of \code{NULL} element values. +} +\description{ +This function wraps a simple \code{\link[purrr:modify]{modify_if}} function +to "unbox" list elements. This is helpful when the \code{\link[xml2]{as_list}} +returns elements of XML and the element value is kept as a list of length 1, +even though it could be a single primitive data type (e.g. \code{logical}, +\code{character}, etc.). +} +\note{ +This function is meant to be used internally. Only use when debugging. +} +\keyword{internal} diff --git a/man/unbox_list_elements_recursively.Rd b/man/unbox_list_elements_recursively.Rd new file mode 100644 index 00000000..7ed9a855 --- /dev/null +++ b/man/unbox_list_elements_recursively.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-query.R +\name{unbox_list_elements_recursively} +\alias{unbox_list_elements_recursively} +\title{Recursively unlist all list elements of length 1 if they are not a list} +\usage{ +unbox_list_elements_recursively(x) +} +\arguments{ +\item{x}{\code{list}; a list to be cleaned.} +} +\value{ +\code{list} containing "unboxed" list elements. +} +\description{ +This function wraps a simple \code{\link[purrr:modify]{modify_if}} function +to recursively "unbox" list elements. This is helpful when the +\code{\link[xml2]{as_list}} returns elements of XML and the element value is +kept as a list of length 1, even though it could be a single primitive data +type (e.g. \code{logical}, \code{character}, etc.). +} +\note{ +This function is meant to be used internally. Only use when debugging. +} +\keyword{internal} diff --git a/tests/testthat/test-rest.R b/tests/testthat/test-rest.R index 40786f62..b78bbb3c 100644 --- a/tests/testthat/test-rest.R +++ b/tests/testthat/test-rest.R @@ -15,6 +15,33 @@ test_that("testing REST API Functionality", { expect_equal(nrow(created_records), n) expect_is(created_records$success, "logical") + # sf_create error ------------------------------------------------------------ + new_campaign_members <- tibble(CampaignId = "", + ContactId = "0036A000002C6MbQAK") + created_records <- sf_create(new_campaign_members, + object_name = "CampaignMember", + api_type="REST") + expect_is(created_records, "tbl_df") + expect_equal(names(created_records), c("success", "errors")) + expect_equal(nrow(created_records), 1) + expect_is(created_records$errors, "list") + expect_equal(length(created_records$errors[1][[1]]), 2) + expect_equal(names(created_records$errors[1][[1]][[1]]), + c("statusCode", "message", "fields")) + + new_campaign_members <- tibble(CampaignId = "7013s000000j6n1AAA", + ContactId = "0036A000002C6MbQAK") + created_records <- sf_create(new_campaign_members, + object_name = "CampaignMember", + api_type="REST") + expect_is(created_records, "tbl_df") + expect_equal(names(created_records), c("success", "errors")) + expect_equal(nrow(created_records), 1) + expect_is(created_records$errors, "list") + expect_equal(length(created_records$errors[1][[1]]), 1) + expect_equal(names(created_records$errors[1][[1]][[1]]), + c("statusCode", "message", "fields")) + # sf_retrieve ---------------------------------------------------------------- retrieved_records <- sf_retrieve(ids = created_records$id, fields = c("FirstName", "LastName"), diff --git a/tests/testthat/test-soap.R b/tests/testthat/test-soap.R index f2c8b7dd..0b043bd5 100644 --- a/tests/testthat/test-soap.R +++ b/tests/testthat/test-soap.R @@ -15,6 +15,33 @@ test_that("testing SOAP API Functionality", { expect_equal(nrow(created_records), n) expect_is(created_records$success, "logical") + # sf_create error ------------------------------------------------------------ + new_campaign_members <- tibble(CampaignId = "", + ContactId = "0036A000002C6MbQAK") + created_records <- sf_create(new_campaign_members, + object_name = "CampaignMember", + api_type="SOAP") + expect_is(created_records, "tbl_df") + expect_equal(names(created_records), c("success", "errors")) + expect_equal(nrow(created_records), 1) + expect_is(created_records$errors, "list") + expect_equal(length(created_records$errors[1][[1]]), 2) + expect_equal(names(created_records$errors[1][[1]][[1]]), + c("message", "statusCode")) + + new_campaign_members <- tibble(CampaignId = "7013s000000j6n1AAA", + ContactId = "0036A000002C6MbQAK") + created_records <- sf_create(new_campaign_members, + object_name = "CampaignMember", + api_type="SOAP") + expect_is(created_records, "tbl_df") + expect_equal(names(created_records), c("success", "errors")) + expect_equal(nrow(created_records), 1) + expect_is(created_records$errors, "list") + expect_equal(length(created_records$errors[1][[1]]), 1) + expect_equal(names(created_records$errors[1][[1]][[1]]), + c("message", "statusCode")) + # sf_retrieve ---------------------------------------------------------------- retrieved_records <- sf_retrieve(ids = created_records$id, fields = c("FirstName", "LastName"),