export arms

closes #375

NAMESPACE

@@ -8,6 +8,7 @@ export(constant_to_form_completion)
 export(constant_to_form_rights)
 export(create_batch_glossary)
 export(create_credential_local)
+export(redcap_arm_export)
 export(redcap_column_sanitize)
 export(redcap_delete)
 export(redcap_download_file_oneshot)

NEWS.md

@@ -4,6 +4,7 @@ Upcoming Versions
 ### New Features
 
 * `redcap_delete()` deletes a vector of records.  (Thanks @joundso, #372, #373)
+* `redcap_arm_export()` retrieves a list of REDCap project arms.  (#375)
 
 ### Minor Enhancements
 

R/redcap-arm-export.R

@@ -0,0 +1,169 @@
+#' @title Export Arms
+#'
+#' @description Export Arms of a REDCap project
+#'
+#' @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 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.  See the details in [redcap_read_oneshot()]. Optional.
+#'
+#' @return Currently, a list is returned with the following elements:
+#' * `has_arms`: a `logical` value indicating if the REDCap project has
+#' arms (*i.e.*, "TRUE") or is a classic non-longitudinal project
+#' (*i.e.*, "FALSE").
+#' * `data`: a [`tibble`] with one row per arm.  The columns are
+#' `arm_number` (an integer) and `arm_name` (a human-friendly string).
+#' * `success`: A boolean value indicating if the operation was apparently
+#' successful.
+#' * `status_code`: The
+#' [http status code](https://en.wikipedia.org/wiki/List_of_HTTP_status_codes)
+#' of the operation.
+#' * `outcome_message`: A human readable string indicating the operation's
+#' outcome.
+#' * `elapsed_seconds`: The duration of the function.
+#' * `raw_text`: If an operation is NOT successful, the text returned by
+#' REDCap.  If an operation is successful, the `raw_text` is returned as an
+#' empty string to save RAM.
+#'
+#' @author Will Beasley
+#'
+#' @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/"
+#'
+#' # Query a classic project with 3 arms
+#' token_1  <- "CDF9F3767E413FDBAA31D92E9F36730A"
+#' result_1 <- REDCapR::redcap_arm_export(redcap_uri=uri, token=token_1)
+#' result_1$has_arms
+#' result_1$data
+#'
+#' # Query a classic project without arms
+#' token_2  <- "D70F9ACD1EDD6F151C6EA78683944E98"
+#' result_2 <- REDCapR::redcap_arm_export(redcap_uri=uri, token=token_2)
+#' result_2$has_arms
+#' result_2$data
+#' }
+
+#' @export
+redcap_arm_export <- function(
+  redcap_uri,
+  token,
+  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,}$")
+
+  token   <- sanitize_token(token)
+  verbose <- verbose_prepare(verbose)
+
+  post_body <-
+    list(
+      token     = token,
+      content   = "arm",
+      format    = "csv"
+    )
+
+  try(
+    {
+      # This is the important line that communicates with the REDCap server.
+      kernel <- kernel_api(redcap_uri, post_body, config_options)
+    },
+    # 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("kernel")) {
+    if (kernel$success) {
+      has_arms <- TRUE
+      outcome_message <- sprintf(
+        paste(
+          "The list of arms was retrieved from the REDCap project in %0.1f seconds.",
+          "The http status code was %i."
+        ),
+        kernel$elapsed_seconds,
+        kernel$status_code
+      )
+
+      col_types <- readr::cols(
+        arm_num = readr::col_integer(),
+        name    = readr::col_character()
+      )
+      d <-
+        readr::read_csv(I(kernel$raw_text), col_types = col_types) %>%
+        dplyr::select(
+          arm_number  = arm_num,
+          arm_name    = name
+        )
+
+      #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 if (kernel$raw_text == "ERROR: You cannot export arms for classic projects") {
+      has_arms <- FALSE
+      outcome_message <- sprintf(
+        paste(
+          "A 'classic' REDCap project has no arms.  Retrieved in %0.1f seconds.",
+          "The http status code was %i."
+        ),
+        kernel$elapsed_seconds,
+        kernel$status_code
+      )
+
+      d <- tibble::tibble(
+        arm_number = integer(0),
+        arm_name   = character(0)
+      )
+    } else {
+        error_message <- sprintf(
+          paste(
+            "The REDCapR arm export failed.",
+            "The http status code was %i.",
+            "The error message was: '%s'."
+          ),
+          kernel$status_code,
+          kernel$raw_text
+        )
+      stop(error_message)
+    }
+  } else {
+    # nocov start
+    error_message     <- sprintf(
+      paste(
+        "The REDCapR arm export failed",
+        "The error message was:\n%s"
+      ),
+      kernel$raw_text
+    )
+    stop(error_message)
+    # nocov end
+  }
+
+  if (verbose)
+    message(outcome_message)
+
+  list(
+    has_arms                  = has_arms,
+    data                      = d,
+    success                   = kernel$success,
+    status_code               = kernel$status_code,
+    outcome_message           = outcome_message,
+    elapsed_seconds           = kernel$elapsed_seconds,
+    raw_text                  = kernel$raw_text
+  )
+}

inst/test-data/delete-multiple-arm/arm.csv

@@ -0,0 +1,4 @@
+arm_num,name
+1,Arm 1
+2,Arm 2
+3,Arm 3

tests/testthat/test-arm-export.R

@@ -0,0 +1,73 @@
+library(testthat)
+
+read_arms <- function (path) {
+  full_path   <- system.file(path, package = "REDCapR")
+  if (!file.exists(full_path))
+    stop("The expected file `", full_path, "` was not found.")  # nocov
+
+  col_types <- readr::cols(
+    arm_num = readr::col_integer(),
+    name    = readr::col_character()
+  )
+  full_path |>
+    readr::read_csv(col_types = col_types) %>%
+    dplyr::select(
+      arm_number  = arm_num,
+      arm_name    = name
+    )
+}
+
+empty_data_frame <-
+  tibble::tibble(
+    arm_number = integer(0),
+    arm_name   = character(0)
+  )
+
+test_that("delete-multiple-arm", {
+  testthat::skip_on_cran()
+  credential  <- retrieve_credential_testing(2627L)
+
+  path_expected <- "test-data/delete-multiple-arm/arm.csv"
+  expected_data_frame <- read_arms(path_expected)
+  # start_clean_result <- REDCapR:::clean_start_delete_single_arm()
+
+  expected_outcome_message <- "The list of arms was retrieved from the REDCap project in \\d+(\\.\\d+\\W|\\W)seconds\\."
+  expect_message(
+    returned_object <-
+      redcap_arm_export(
+        redcap_uri        = credential$redcap_uri,
+        token             = credential$token
+      ),
+    regexp = expected_outcome_message
+  )
+
+  expect_equal(returned_object$data, expected=expected_data_frame, label="The returned data.frame should be correct", ignore_attr = TRUE) #returned_object2$data$bmi<-NULL; returned_object2$data$age<-NULL;dput(returned_object2$data)
+  expect_equal(returned_object$status_code, expected=200L)
+  expect_equal(returned_object$raw_text, expected="", ignore_attr = TRUE) # dput(returned_object2$raw_text)
+  expect_match(returned_object$outcome_message, regexp=expected_outcome_message, perl=TRUE)
+  expect_true(returned_object$success)
+})
+
+
+test_that("delete-single-arm", {
+  testthat::skip_on_cran()
+  credential  <- retrieve_credential_testing(2626L)
+
+  expected_outcome_message <- "A 'classic' REDCap project has no arms.  Retrieved in \\d+(\\.\\d+\\W|\\W)seconds\\."
+  expect_message(
+    returned_object <-
+      redcap_arm_export(
+        redcap_uri        = credential$redcap_uri,
+        token             = credential$token
+      ),
+    regexp = expected_outcome_message
+  )
+
+  expect_equal(returned_object$data, expected=empty_data_frame, label="The returned data.frame should be correct", ignore_attr = TRUE) #returned_object2$data$bmi<-NULL; returned_object2$data$age<-NULL;dput(returned_object2$data)
+  expect_equal(returned_object$status_code, expected=400L)
+  expect_equal(returned_object$raw_text, expected="ERROR: You cannot export arms for classic projects", ignore_attr = TRUE) # dput(returned_object2$raw_text)
+  expect_match(returned_object$outcome_message, regexp=expected_outcome_message, perl=TRUE)
+  expect_false(returned_object$success)
+})
+
+rm(read_arms, empty_data_frame)

utility/refresh.R

@@ -34,7 +34,7 @@ devtools::run_examples(); #dev.off() #This overwrites the NAMESPACE file too
 # devtools::run_examples(, "redcap_read.Rd")
 # pkgload::load_all()
 test_results_checked <- devtools::test()
-test_results_checked <- devtools::test(filter = "column")
+test_results_checked <- devtools::test(filter = "arm-export")
 test_results_checked <- devtools::test(filter = "delete")
 withr::local_envvar(ONLYREADTESTS = "true")
 test_results_checked <- devtools::test(filter = "write-batch")