diff --git a/NAMESPACE b/NAMESPACE index 8fdc421..5560c0b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -57,6 +57,7 @@ importFrom(dplyr,ungroup) importFrom(httr,POST) importFrom(httr,config) importFrom(httr,content) +importFrom(httr,http_status) importFrom(httr,stop_for_status) importFrom(lifecycle,badge) importFrom(lifecycle,deprecated) @@ -69,6 +70,7 @@ importFrom(purrr,map_chr) importFrom(purrr,map_dfr) importFrom(readr,col_character) importFrom(readr,cols) +importFrom(readr,read_csv) importFrom(rlang,.data) importFrom(rlang,.env) importFrom(rlang,`!!!`) diff --git a/R/fetch_database.R b/R/fetch_database.R index f7896da..a7016ca 100644 --- a/R/fetch_database.R +++ b/R/fetch_database.R @@ -59,6 +59,7 @@ fetch_database <- function(conn, records_omit = NULL, id_field = TRUE, rm_empty = TRUE, + rm_empty_omit_calc = FALSE, value_labs = TRUE, value_labs_fetch_raw = FALSE, header_labs = FALSE, @@ -113,6 +114,7 @@ fetch_database <- function(conn, fields = NULL, id_field = id_field, rm_empty = rm_empty, + rm_empty_omit_calc = rm_empty_omit_calc, value_labs = value_labs, value_labs_fetch_raw = value_labs_fetch_raw, header_labs = header_labs, diff --git a/R/fetch_records.R b/R/fetch_records.R index 3ba73c4..3579c8e 100644 --- a/R/fetch_records.R +++ b/R/fetch_records.R @@ -33,6 +33,11 @@ #' @param rm_empty Logical indicating whether to remove rows for which all #' fields from the relevant form(s) are missing. See section __Removing empty #' rows__. Defaults to `TRUE`. +#' @param rm_empty_omit_calc Logical indicating whether to exclude calculated +#' fields from assessment of empty rows. Defaults to FALSE. In some cases +#' calculated fields can be autopopulated for certain records even when the +#' relevant form is truly empty, which would otherwise lead to "empty" forms +#' being returned even when `rm_empty` is `TRUE`. Defaults to `FALSE`. #' @param value_labs Logical indicating whether to return value labels (`TRUE`) #' or raw values (`FALSE`) for categorical REDCap variables (radio, dropdown, #' yesno, checkbox). Defaults to `TRUE` to return labels. @@ -154,6 +159,7 @@ fetch_records <- function(conn, fields = NULL, id_field = TRUE, rm_empty = TRUE, + rm_empty_omit_calc = FALSE, value_labs = TRUE, value_labs_fetch_raw = FALSE, header_labs = FALSE, @@ -197,6 +203,7 @@ fetch_records <- function(conn, fields = fields, id_field = id_field, rm_empty = rm_empty, + rm_empty_omit_calc, value_labs = value_labs, value_labs_fetch_raw = value_labs_fetch_raw, header_labs = header_labs, @@ -240,6 +247,7 @@ fetch_records_ <- function(conn, fields, id_field, rm_empty, + rm_empty_omit_calc, value_labs, value_labs_fetch_raw, header_labs, @@ -374,6 +382,22 @@ fetch_records_ <- function(conn, on_error = "fail" ) + # scripts often failing when 1 batch isn't a data.frame, causes error in + # bind_rows below. testing temp fix, when batch doesn't return df, pause + # and try again, and print class of non-df object + if (!"data.frame" %in% class(out_batch[[i]])) { + + Sys.sleep(batch_delay * 3) + + out_batch[[i]] <- post_wrapper( + conn, + body = body_batch, + content = NULL, + na = na, + on_error = "fail" + ) + } + if (i < max(batch)) Sys.sleep(batch_delay) } @@ -528,7 +552,8 @@ fetch_records_ <- function(conn, forms = forms, value_labs = value_labs, header_labs = header_labs, - checkbox_labs = checkbox_labs + checkbox_labs = checkbox_labs, + rm_empty_omit_calc = rm_empty_omit_calc ) out <- out[!rows_missing, , drop = FALSE] @@ -584,12 +609,14 @@ all_fields_missing <- function(x, value_labs, header_labs, checkbox_labs, + rm_empty_omit_calc, drop_first_row = TRUE) { col_field <- ifelse(header_labs, "field_label", "field_name") if (drop_first_row) dict <- dict[-1, , drop = FALSE] dict_form <- dict[dict$form_name %in% forms, , drop = FALSE] + if (rm_empty_omit_calc) dict_form <- dict_form[!dict_form$field_type %in% "calc", , drop = FALSE] # if value_labs = TRUE # - checkbox_labs = TRUE, empty checkbox fields will be diff --git a/R/utils.R b/R/utils.R index 5024797..5351b89 100644 --- a/R/utils.R +++ b/R/utils.R @@ -204,8 +204,8 @@ valid_datetime_arg <- function(x) { #' @noRd -#' @importFrom httr POST content stop_for_status -#' @importFrom readr cols col_character +#' @importFrom httr POST content stop_for_status http_status +#' @importFrom readr read_csv cols col_character post_wrapper <- function(conn, body = NULL, content = NULL, @@ -234,24 +234,39 @@ post_wrapper <- function(conn, encode = "form" ) - if (response$status_code != 200L) { - if (on_error == "fail") { - httr::stop_for_status(response) - } else { - out <- NULL - } - } else { - suppressWarnings( - out <- httr::content( - response, + response_raw <- httr::content( + x = response, + as = "text", + encoding = "UTF-8", + type = "text/csv" + ) + + response_message <- httr::http_status(response)[["message"]] + is_success <- response$status_code == 200L + + if (is_success) { + + out <- try( + readr::read_csv( + file = I(response_raw), col_types = readr::cols(.default = readr::col_character()), na = na, progress = FALSE - ) + ), + silent = TRUE ) - if (is.null(out)) { - stop("Response from REDCap API has status 200 but is empty") + if ("try-error" %in% class(out) | !inherits(out, "data.frame")) { + is_success <- FALSE + response_message <- paste("API request had status 200 but no data returned\nRaw text:", response_raw) + } + } + + if (!is_success) { + if (on_error == "fail") { + stop(response_message) + } else { + out <- NULL } } diff --git a/man/fetch_database.Rd b/man/fetch_database.Rd index 63e9eec..1453fd0 100644 --- a/man/fetch_database.Rd +++ b/man/fetch_database.Rd @@ -13,6 +13,7 @@ fetch_database( records_omit = NULL, id_field = TRUE, rm_empty = TRUE, + rm_empty_omit_calc = FALSE, value_labs = TRUE, value_labs_fetch_raw = FALSE, header_labs = FALSE, @@ -69,6 +70,12 @@ request the record ID field.} fields from the relevant form(s) are missing. See section \strong{Removing empty rows}. Defaults to \code{TRUE}.} +\item{rm_empty_omit_calc}{Logical indicating whether to exclude calculated +fields from assessment of empty rows. Defaults to FALSE. In some cases +calculated fields can be autopopulated for certain records even when the +relevant form is truly empty, which would otherwise lead to "empty" forms +being returned even when \code{rm_empty} is \code{TRUE}. Defaults to \code{FALSE}.} + \item{value_labs}{Logical indicating whether to return value labels (\code{TRUE}) or raw values (\code{FALSE}) for categorical REDCap variables (radio, dropdown, yesno, checkbox). Defaults to \code{TRUE} to return labels.} diff --git a/man/fetch_records.Rd b/man/fetch_records.Rd index 1063d1d..1afbe71 100644 --- a/man/fetch_records.Rd +++ b/man/fetch_records.Rd @@ -13,6 +13,7 @@ fetch_records( fields = NULL, id_field = TRUE, rm_empty = TRUE, + rm_empty_omit_calc = FALSE, value_labs = TRUE, value_labs_fetch_raw = FALSE, header_labs = FALSE, @@ -71,6 +72,12 @@ request the record ID field.} fields from the relevant form(s) are missing. See section \strong{Removing empty rows}. Defaults to \code{TRUE}.} +\item{rm_empty_omit_calc}{Logical indicating whether to exclude calculated +fields from assessment of empty rows. Defaults to FALSE. In some cases +calculated fields can be autopopulated for certain records even when the +relevant form is truly empty, which would otherwise lead to "empty" forms +being returned even when \code{rm_empty} is \code{TRUE}. Defaults to \code{FALSE}.} + \item{value_labs}{Logical indicating whether to return value labels (\code{TRUE}) or raw values (\code{FALSE}) for categorical REDCap variables (radio, dropdown, yesno, checkbox). Defaults to \code{TRUE} to return labels.}