Adds function to export available data access groups

NAMESPACE

@@ -10,6 +10,7 @@ export(create_batch_glossary)
 export(create_credential_local)
 export(redcap_arm_export)
 export(redcap_column_sanitize)
+export(redcap_dag_read)
 export(redcap_delete)
 export(redcap_download_file_oneshot)
 export(redcap_download_instrument)

NEWS.md

@@ -8,6 +8,7 @@ Upcoming Versions
 * `redcap_read()` and `redcap_read_oneshot()` accept a new `locale` parameter that specifies date, time, and number formats, like using a comma as the decimal separator.  It is a [`readr::locale`](https://readr.tidyverse.org/reference/locale.html) object.  (#377, suggested by @joundso)
 * New `redcap_instruments()` function exports a list of the data collection instruments for a project.  (#381, @vcastro)
 * New `redcap_event_instruments()` function exports the instrument-event mappings for a project (i.e., how the data collection instruments are designated for certain events in a longitudinal project)..  (#381, @vcastro)
+* New `redcap_dag_read()` function returns the Data Access Groups for a project (#382, @joundso)
 * New detection when REDCap has trouble with a large request and drops records. (#400 w/ @TimMonahan)
 
 ### Minor Enhancements
@@ -23,7 +24,7 @@ Upcoming Versions
 * For the testing server & projects, the http errors are a little different, so the testing code was adjusted (#396)
 * Set `httr::user_agent`, following the advice of httr's vignette (#397)
 
-### Test Suite 
+### Test Suite
 
 * Added two more dictionaries that are super wide -5k & 35k variables  (#335 & #360, @januz & @datalorax)
 * Read, modify, & read projects with DAGs (#353, daniela.wolkersdorfer, #353)
@@ -71,7 +72,7 @@ Version 0.11.0 (Released 2020-04-20)
 
 * [`reader::type_convert()`](https://readr.tidyverse.org/reference/type_convert.html) is used *after* all the batches are stacked on top of each other.  This way, batches cannot have incompatible data types as they're combined. (#257; thanks @isaactpetersen #245)  Consequently, the `guess_max` parameter in `redcap_read()` no longer serves a purpose, and has been soft-deprecated. (#267)
 
-* [`redcap_metadata_write()`](https://ouhscbbmc.github.io/REDCapR/reference/redcap_metadata_write.html) writes to the project's metadata. (#274, @felixetorres) 
+* [`redcap_metadata_write()`](https://ouhscbbmc.github.io/REDCapR/reference/redcap_metadata_write.html) writes to the project's metadata. (#274, @felixetorres)
 
 * [`redcap_survey_link_export_oneshot()`](https://ouhscbbmc.github.io/REDCapR/reference/redcap_survey_link_export_oneshot.html) retrieves the URL to a specific record's survey (*e.g.*, "https://bbmc.ouhsc.edu/redcap/surveys/?s=8KuzSLMHf6") (#293)
 

R/redcap-read-dag.R

@@ -0,0 +1,169 @@
+#' @title Read data access groups from a REDCap project
+#'
+#' @description This function reads all available data access groups from
+#'   REDCap an returns them as a [base::data.frame()].
+#'
+#' @param redcap_uri The URI (uniform resource identifier) of the REDCap
+#' project.  Required.
+#' @param token The user-specific string that serves as the password for a
+#' project.  Required.
+#' @param http_response_encoding  The encoding value passed to
+#' [httr::content()].  Defaults to 'UTF-8'.
+#' @param locale a [readr::locale()] object to specify preferences like
+#' number, date, and time formats.  This object is passed to
+#' [`readr::read_csv()`].  Defaults to [readr::default_locale()].
+#' @param verbose A boolean value indicating if `message`s should be printed
+#' to the R console during the operation.  The verbose output might contain
+#' sensitive information (*e.g.* PHI), so turn this off if the output might
+#' be visible somewhere public. Optional.
+#' @param config_options  A list of options to pass to `POST` method in the
+#' `httr` package.
+#'
+#' @return Currently, a list is returned with the following elements:
+#' * `data`: An R [base::data.frame()] of all data access groups of the project.
+#' * `success`: A boolean value indicating if the operation was apparently
+#' successful.
+#' * `status_codes`: A collection of
+#' [http status codes](https://en.wikipedia.org/wiki/List_of_HTTP_status_codes),
+#' separated by semicolons.  There is one code for each batch attempted.
+#' * `outcome_messages`: A collection of human readable strings indicating the
+#' operations' semicolons.  There is one code for each batch attempted.  In an
+#' unsuccessful operation, it should contain diagnostic information.
+#' * `elapsed_seconds`: The duration of the function.
+#'
+#'
+#' @author Jonathan M. Mang
+#' @references The official documentation can be found on the 'API Help Page'
+#' and 'API Examples' pages on the REDCap wiki (*i.e.*,
+#' https://community.projectredcap.org/articles/456/api-documentation.html
+#' and
+#' https://community.projectredcap.org/articles/462/api-examples.html).
+#' If you do not have an account for the wiki, please ask your campus REDCap
+#' administrator to send you the static material.
+#'
+#' @examples
+#' \dontrun{
+#' uri     <- "https://bbmc.ouhsc.edu/redcap/api/"
+#' token   <- "9A81268476645C4E5F03428B8AC3AA7B"
+#' REDCapR::redcap_dag_read(redcap_uri=uri, token=token)$data
+#' }
+
+#' @export
+redcap_dag_read <- function(
+  redcap_uri,
+  token,
+  http_response_encoding        = "UTF-8",
+  locale                        = readr::default_locale(),
+  verbose                       = TRUE,
+  config_options                = NULL
+) {
+  checkmate::assert_character(redcap_uri                , any.missing=FALSE,     len=1, pattern="^.{1,}$")
+  checkmate::assert_character(token                     , any.missing=FALSE,     len=1, pattern="^.{1,}$")
+  checkmate::assert_character(http_response_encoding    , any.missing=FALSE,     len=1)
+  checkmate::assert_class(    locale, "locale"          , null.ok = FALSE)
+
+  checkmate::assert_logical(  verbose                   , any.missing=FALSE,     len=1, null.ok=TRUE)
+  checkmate::assert_list(     config_options            , any.missing=TRUE ,            null.ok=TRUE)
+
+
+  token               <- sanitize_token(token)
+  verbose             <- verbose_prepare(verbose)
+
+  post_body <- list(
+    token                   = token,
+    content                 = "dag",
+    format                  = "csv"
+  )
+
+  # This is the important line that communicates with the REDCap server.
+  kernel <- kernel_api(
+    redcap_uri      = redcap_uri,
+    post_body       = post_body,
+    config_options  = config_options,
+    encoding        = http_response_encoding
+  )
+
+  if (kernel$success) {
+    try(
+      # Convert the raw text to a dataset.
+      ds <-
+        readr::read_csv(
+          file            = I(kernel$raw_text),
+          locale          = locale,
+          show_col_types  = FALSE
+        ) %>%
+        as.data.frame(),
+
+      # Don't print the warning in the try block.  Print it below,
+      #   where it's under the control of the caller.
+      silent = TRUE
+    )
+
+    if (exists("ds") & inherits(ds, "data.frame")) {
+      outcome_message <- sprintf(
+        "%s data access groups were read from REDCap in %0.1f seconds.  The http status code was %i.",
+        format(  nrow(ds), big.mark = ",", scientific = FALSE, trim = TRUE),
+        kernel$elapsed_seconds,
+        kernel$status_code
+      )
+
+      # ds <- dplyr::mutate_if(
+      #   ds,
+      #   is.character,
+      #   function(x) dplyr::coalesce(x, "") #Replace NAs with blanks
+      # )
+      #
+      # ds <- dplyr::mutate_if(
+      #   ds,
+      #   is.character,
+      #   function( x ) gsub("\r\n", "\n", x, perl=TRUE)
+      # )
+      # ds <- dplyr::mutate_if(
+      #   ds,
+      #   function( x) inherits(x, "Date"),
+      #   as.character
+      # )
+      #
+      # ds <- base::as.data.frame(ds)
+
+      # If an operation is successful, the `raw_text` is no longer returned to
+      #   save RAM.  The content is not really necessary with httr's status
+      #   message exposed.
+      kernel$raw_text   <- ""
+    } else { # ds doesn't exist as a data.frame.
+      # nocov start
+      # Override the 'success' determination from the http status code.
+      #   and return an empty data.frame.
+      kernel$success   <- FALSE
+      ds               <- data.frame()
+      outcome_message  <- sprintf(
+        "The REDCap read failed.  The http status code was %i.  The 'raw_text' returned was '%s'.",
+        kernel$status_code,
+        kernel$raw_text
+      )
+      # nocov end
+    }
+  } else { # kernel fails
+    ds              <- data.frame() #Return an empty data.frame
+    outcome_message <- if (any(grepl(kernel$regex_empty, kernel$raw_text))) {
+      "The REDCapR read/export operation was not successful.  The returned dataset was empty."  # nocov
+    } else {
+      sprintf(
+        "The REDCapR read/export operation was not successful.  The error message was:\n%s",
+        kernel$raw_text
+      )
+    }
+  }
+
+  if (verbose)
+    message(outcome_message)
+
+  list(
+    data               = ds,
+    success            = kernel$success,
+    status_code        = kernel$status_code,
+    outcome_message    = outcome_message,
+    elapsed_seconds    = kernel$elapsed_seconds,
+    raw_text           = kernel$raw_text
+  )
+}

tests/testthat/test-dag-read.R

@@ -0,0 +1,57 @@
+library(testthat)
+
+credential_1        <- retrieve_credential_testing()
+credential_no_dag   <- retrieve_credential_testing(2597L)
+
+
+test_that("smoke", {
+  testthat::skip_on_cran()
+  expect_message(
+    returned <- redcap_dag_read(
+      redcap_uri  = credential_1$redcap_uri,
+      token       = credential_1$token
+    )
+  )
+})
+
+test_that("dag-default", {
+  testthat::skip_on_cran()
+  expected_data <-
+    structure(list(data_access_group_name = c("dag_1", "dag_2"),
+      unique_group_name = c("dag_1", "dag_2")), row.names = c(NA,
+      -2L), class = "data.frame"
+    )
+  expect_message(
+    actual <- redcap_dag_read(
+      redcap_uri  = credential_1$redcap_uri,
+      token       = credential_1$token
+    )
+  )
+
+  expect_true( actual$success)
+  expect_equal(actual$status_code, 200L)
+  expect_equal(actual$data, expected_data)
+})
+
+test_that("dag-default", {
+  testthat::skip_on_cran()
+  expected_data <-
+    structure(list(data_access_group_name = character(0),
+      unique_group_name = character(0)), row.names = integer(0),
+      class = "data.frame"
+    )
+
+  expect_message(
+    actual <- redcap_dag_read(
+      redcap_uri  = credential_no_dag$redcap_uri,
+      token       = credential_no_dag$token
+    )
+  )
+
+  expect_true( actual$success)
+  expect_equal(actual$status_code, 200L)
+  expect_equal(actual$data, expected_data)
+})
+
+rm(credential_1)
+rm(credential_no_dag)