Merge pull request #16 from epicentre-msf/dev

Debugging, and add param to exclude calculated fields from assessment of missing rows

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,`!!!`)

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,

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 <NA>

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
     }
   }