Skip to content

Commit

Permalink
return tibble instead of data.frame
Browse files Browse the repository at this point in the history
close #415
  • Loading branch information
wibeasley committed Aug 30, 2022
1 parent e7442cb commit 293dc5e
Show file tree
Hide file tree
Showing 9 changed files with 63 additions and 52 deletions.
19 changes: 11 additions & 8 deletions R/metadata-utilities.R
Original file line number Diff line number Diff line change
Expand Up @@ -13,7 +13,7 @@
#' @param perl Indicates if perl-compatible regexps should be used.
#' Default is `TRUE`. Optional.
#'
#' @return Currently, a [base::data.frame()] is returned a row for each match,
#' @return Currently, a [tibble::tibble()] is returned a row for each match,
#' and a column for each *named* group within a match. For the
#' `retrieve_checkbox_choices()` function, the columns will be.
#' * `id`: The numeric value assigned to each choice (in the data dictionary).
Expand All @@ -22,13 +22,17 @@
#' @details
#' The [regex_named_captures()] function is general, and not specific to
#' REDCap; it accepts any arbitrary regular expression.
#' It returns a [base::data.frame()] with as many columns as named matches.
#' It returns a [tibble::tibble()] with as many columns as named matches.
#'
#' The [checkbox_choices()] function is specialized, and accommodates the
#' "select choices" for a *single* REDCap checkbox group (where multiple boxes
#' can be selected). It returns a [base::data.frame()] with two columns, one
#' can be selected). It returns a [tibble::tibble()] with two columns, one
#' for the numeric id and one for the text label.
#'
#' The parse will probably fail if a label contains a pipe (*i.e.*, `|`),
#' since that the delimiter REDCap uses to separate choices
#' presented to the user.
#'
#' @author Will Beasley
#' @references See the official documentation for permissible characters in a
#' checkbox label.
Expand Down Expand Up @@ -59,7 +63,7 @@
#' token <- "9A81268476645C4E5F03428B8AC3AA7B"
#'
#' ds_metadata <- redcap_metadata_read(redcap_uri=uri, token=token)$data
#' choices_2 <- ds_metadata[ds_metadata$field_name=="race", "select_choices_or_calculations"]
#' choices_2 <- ds_metadata[ds_metadata$field_name=="race", ]$select_choices_or_calculations
#'
#' REDCapR::regex_named_captures(pattern=pattern_boxes, text=choices_2)
#' }
Expand All @@ -70,15 +74,14 @@
#' REDCapR::regex_named_captures(pattern=pattern_boxes, text=choices_3)

#' @export
regex_named_captures <- function(pattern, text, perl=TRUE) {

regex_named_captures <- function(pattern, text, perl = TRUE) {
checkmate::assert_character(pattern, any.missing=FALSE, min.chars=0L, len=1)
checkmate::assert_character(text , any.missing=FALSE, min.chars=0L, len=1)
checkmate::assert_logical( perl , any.missing=FALSE)

match <- gregexpr(pattern, text, perl = perl)[[1]]
capture_names <- attr(match, "capture.names")
d <- as.data.frame(matrix(
d <- base::data.frame(matrix(
data = NA_character_,
nrow = length(attr(match, "match.length")),
ncol = length(capture_names)
Expand All @@ -95,7 +98,7 @@ regex_named_captures <- function(pattern, text, perl=TRUE) {
attr(match, "capture.length")[, column_name]
)
}
d
tibble::as_tibble(d)
}

#' @rdname metadata_utilities
Expand Down
19 changes: 4 additions & 15 deletions R/redcap-metadata-read.R
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
#' @title Export the metadata of a REDCap project
#'
#' @description Export the metadata (as a data dictionary) of a REDCap project
#' as a [base::data.frame()]. Each row in the data dictionary corresponds to
#' as a [tibble::tibble()]. Each row in the data dictionary corresponds to
#' one field in the project's dataset.
#'
#' @param redcap_uri The
Expand All @@ -28,7 +28,7 @@
#'
#' @return Currently, a list is returned with the following elements:
#'
#' * `data`: An R [base::data.frame()] of the desired records and columns.
#' * `data`: An R [tibble::tibble()] of the desired fields (as rows).
#' * `success`: A boolean value indicating if the operation was apparently
#' successful.
#' * `status_codes`: A collection of
Expand All @@ -43,17 +43,6 @@
#' string, separated by commas.
#' * `elapsed_seconds`: The duration of the function.
#'
#' @details
#' Specifically, it internally uses multiple calls to [redcap_read_oneshot()]
#' to select and return data. Initially, only primary key is queried through
#' the REDCap API. The long list is then subsetted into partitions, whose
#' sizes are determined by the `batch_size` parameter. REDCap is then queried
#' for all variables of the subset's subjects. This is repeated for each
#' subset, before returning a unified [base::data.frame()].
#'
#' The function allows a delay between calls, which allows the server to
#' attend to other users' requests.
#'
#' @author Will Beasley
#'
#' @references The official documentation can be found on the 'API Help Page'
Expand Down Expand Up @@ -142,15 +131,15 @@ redcap_metadata_read <- function(
# Override the 'success' determination from the http status code
# and return an empty data.frame.
kernel$success <- FALSE
ds <- data.frame()
ds <- tibble::tibble()
outcome_message <- sprintf(
"The REDCap metadata export failed. The http status code was %i. The 'raw_text' returned was '%s'.",
kernel$status_code,
kernel$raw_text
)
} # nocov end
} else {
ds <- data.frame() #Return an empty data.frame
ds <- tibble::tibble() # Return an empty data.frame
outcome_message <- sprintf(
"The REDCapR metadata export operation was not successful. The error message was:\n%s",
kernel$raw_text
Expand Down
6 changes: 3 additions & 3 deletions R/redcap-read-oneshot-eav.R
Original file line number Diff line number Diff line change
Expand Up @@ -70,7 +70,7 @@
#' `httr` package. See the details below. Optional.
#'
#' @return Currently, a list is returned with the following elements:
#' * `data`: An R [base::data.frame()] of the desired records and columns.
#' * `data`: A [tibble::tibble()] of the desired records and columns.
#' * `success`: A boolean value indicating if the operation was apparently
#' successful.
#' * `status_code`: The
Expand Down Expand Up @@ -351,7 +351,7 @@ redcap_read_oneshot_eav <- function(
} else {
# nocov start
kernel$success <- FALSE #Override the 'success' determination from the http status code.
ds_2 <- tibble::tibble() #Return an empty data.frame
ds_2 <- tibble::tibble() # Return an empty data.frame
outcome_message <- sprintf(
"The REDCap read failed. The http status code was %s. The 'raw_text' returned was '%s'.",
kernel$status_code,
Expand All @@ -361,7 +361,7 @@ redcap_read_oneshot_eav <- function(
}
} else {
# nocov start
ds_2 <- tibble::tibble() #Return an empty data.frame
ds_2 <- tibble::tibble() # 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."
} else {
Expand Down
12 changes: 8 additions & 4 deletions man/metadata_utilities.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

15 changes: 2 additions & 13 deletions man/redcap_metadata_read.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

2 changes: 1 addition & 1 deletion man/redcap_read_oneshot_eav.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

5 changes: 5 additions & 0 deletions tests/testthat/test-metadata-read.R
Original file line number Diff line number Diff line change
Expand Up @@ -30,6 +30,7 @@ test_that("Super-wide", {
expect_equal(nrow(returned_object$data), expected=expected_row_count) # dput(returned_object$data)
expect_equal(ncol(returned_object$data), expected=expected_column_count)
expect_equal(sum(is.na(returned_object$data)), expected=expected_na_cells)
expect_s3_class(returned_object$data, "tbl")
})

test_that("Super-wide 2", {
Expand All @@ -47,6 +48,7 @@ test_that("Super-wide 2", {
expect_equal(nrow(returned_object$data), expected=expected_row_count) # dput(returned_object$data)
expect_equal(ncol(returned_object$data), expected=expected_column_count)
expect_equal(sum(is.na(returned_object$data)), expected=expected_na_cells)
expect_s3_class(returned_object$data, "tbl")
})

test_that("Super-wide 3", {
Expand All @@ -64,6 +66,7 @@ test_that("Super-wide 3", {
expect_equal(nrow(returned_object$data), expected=expected_row_count) # dput(returned_object$data)
expect_equal(ncol(returned_object$data), expected=expected_column_count)
expect_equal(sum(is.na(returned_object$data)), expected=expected_na_cells)
expect_s3_class(returned_object$data, "tbl")
})

test_that("Problematic Dictionary", {
Expand All @@ -81,6 +84,7 @@ test_that("Problematic Dictionary", {
expect_equal(nrow(returned_object$data), expected=expected_row_count) # dput(returned_object$data)
expect_equal(ncol(returned_object$data), expected=expected_column_count)
expect_equal(sum(is.na(returned_object$data)), expected=expected_na_cells)
expect_s3_class(returned_object$data, "tbl")
})

test_that("normal", {
Expand All @@ -104,6 +108,7 @@ test_that("normal", {
expect_true(returned_object$fields_collapsed=="", "A subset of fields was not requested.")
expect_match(returned_object$outcome_message, regexp=expected_outcome_message, perl=TRUE)
expect_true(returned_object$success)
expect_s3_class(returned_object$data, "tbl")
})

rm(credential )
Expand Down
26 changes: 18 additions & 8 deletions tests/testthat/test-metadata-utilities.R
Original file line number Diff line number Diff line change
Expand Up @@ -6,12 +6,17 @@ test_that("Named Captures", {
choices_1 <- "1, American Indian/Alaska Native | 2, Asian | 3, Native Hawaiian or Other Pacific Islander | 4, Black or African American | 5, White | 6, Unknown / Not Reported"
ds_boxes <- regex_named_captures(pattern=pattern_checkboxes, text=choices_1)

ds_expected <- structure(list(id = c("1", "2", "3", "4", "5", "6"), label = c("American Indian/Alaska Native",
"Asian", "Native Hawaiian or Other Pacific Islander", "Black or African American",
"White", "Unknown / Not Reported")), .Names = c("id", "label"
), row.names = c(NA, -6L), class = "data.frame")
ds_expected <- structure(
list(
id = c("1", "2", "3", "4", "5", "6"),
label = c("American Indian/Alaska Native", "Asian", "Native Hawaiian or Other Pacific Islander", "Black or African American", "White", "Unknown / Not Reported")
),
class = c("tbl_df", "tbl", "data.frame"),
row.names = c(NA, -6L)
)

expect_equal(ds_boxes, expected=ds_expected, label="The returned data.frame should be correct") #dput(ds_boxes)
expect_s3_class(ds_boxes, "tbl")
})

test_that("checkbox choices", {
Expand All @@ -20,10 +25,15 @@ test_that("checkbox choices", {
choices_1 <- "1, American Indian/Alaska Native | 2, Asian | 3, Native Hawaiian or Other Pacific Islander | 4, Black or African American | 5, White | 6, Unknown / Not Reported"
ds_boxes <- checkbox_choices(select_choices=choices_1)

ds_expected <- structure(list(id = c("1", "2", "3", "4", "5", "6"), label = c("American Indian/Alaska Native",
"Asian", "Native Hawaiian or Other Pacific Islander", "Black or African American",
"White", "Unknown / Not Reported")), .Names = c("id", "label"
), row.names = c(NA, -6L), class = "data.frame")
ds_expected <- structure(
list(
id = c("1", "2", "3", "4", "5", "6"),
label = c("American Indian/Alaska Native", "Asian", "Native Hawaiian or Other Pacific Islander", "Black or African American", "White", "Unknown / Not Reported")
),
class = c("tbl_df", "tbl", "data.frame"),
row.names = c(NA, -6L)
)

expect_equal(ds_boxes, expected=ds_expected, label="The returned data.frame should be correct") #dput(ds_boxes)
expect_s3_class(ds_boxes, "tbl")
})
11 changes: 11 additions & 0 deletions tests/testthat/test-read-oneshot-eav.R
Original file line number Diff line number Diff line change
Expand Up @@ -33,6 +33,7 @@ test_that("default", {
expect_true(returned_object$filter_logic=="", "A filter was not specified.")
expect_match(returned_object$outcome_message, regexp=expected_outcome_message, perl=TRUE)
expect_true(returned_object$success)
expect_s3_class(returned_object$data, "tbl")
})
test_that("specify-forms", {
testthat::skip_on_cran()
Expand All @@ -56,6 +57,7 @@ test_that("specify-forms", {
expect_true(returned_object$filter_logic=="", "A filter was not specified.")
expect_match(returned_object$outcome_message, regexp=expected_outcome_message, perl=TRUE)
expect_true(returned_object$success)
expect_s3_class(returned_object$data, "tbl")
})
test_that("raw", {
testthat::skip_on_cran()
Expand All @@ -78,6 +80,7 @@ test_that("raw", {
expect_true(returned_object$filter_logic=="", "A filter was not specified.")
expect_match(returned_object$outcome_message, regexp=expected_outcome_message, perl=TRUE)
expect_true(returned_object$success)
expect_s3_class(returned_object$data, "tbl")
})
test_that("raw-and-dag", {
testthat::skip_on_cran()
Expand All @@ -100,6 +103,7 @@ test_that("raw-and-dag", {
expect_true(returned_object$filter_logic=="", "A filter was not specified.")
expect_match(returned_object$outcome_message, regexp=expected_outcome_message, perl=TRUE)
expect_true(returned_object$success)
expect_s3_class(returned_object$data, "tbl")
})
test_that("label-and-dag", {
testthat::skip_on_cran()
Expand All @@ -122,6 +126,7 @@ test_that("label-and-dag", {
expect_true(returned_object$filter_logic=="", "A filter was not specified.")
expect_match(returned_object$outcome_message, regexp=expected_outcome_message, perl=TRUE)
expect_true(returned_object$success)
expect_s3_class(returned_object$data, "tbl")
})
test_that("label-header", {
testthat::skip_on_cran()
Expand All @@ -145,6 +150,7 @@ test_that("label-header", {
expect_true(returned_object$filter_logic=="", "A filter was not specified.")
expect_match(returned_object$outcome_message, regexp=expected_outcome_message, perl=TRUE)
expect_true(returned_object$success)
expect_s3_class(returned_object$data, "tbl")
})
test_that("filter-numeric", {
testthat::skip_on_cran()
Expand All @@ -168,6 +174,7 @@ test_that("filter-numeric", {
expect_equal(returned_object$filter_logic, filter)
expect_match(returned_object$outcome_message, regexp=expected_outcome_message, perl=TRUE)
expect_true(returned_object$success)
expect_s3_class(returned_object$data, "tbl")
})
test_that("filter-character", {
testthat::skip_on_cran()
Expand All @@ -194,6 +201,7 @@ test_that("filter-character", {
expect_equal(returned_object$filter_logic, filter)
expect_match(returned_object$outcome_message, regexp=expected_outcome_message, perl=TRUE)
expect_true(returned_object$success)
expect_s3_class(returned_object$data, "tbl")
})
test_that("blank-for-gray-status-true", {
testthat::skip_on_cran()
Expand Down Expand Up @@ -221,6 +229,7 @@ test_that("blank-for-gray-status-true", {
expect_true(returned_object$filter_logic=="", "A filter was not specified.")
expect_match(returned_object$outcome_message, regexp=expected_outcome_message, perl=TRUE)
expect_true(returned_object$success)
expect_s3_class(returned_object$data, "tbl")
})
test_that("blank-for-gray-status-false", {
testthat::skip_on_cran()
Expand Down Expand Up @@ -248,6 +257,7 @@ test_that("blank-for-gray-status-false", {
expect_true(returned_object$filter_logic=="", "A filter was not specified.")
expect_match(returned_object$outcome_message, regexp=expected_outcome_message, perl=TRUE)
expect_true(returned_object$success)
expect_s3_class(returned_object$data, "tbl")
})

test_that("date-range", {
Expand Down Expand Up @@ -279,6 +289,7 @@ test_that("date-range", {
expect_equal(returned_object$filter_logic, "")
expect_match(returned_object$outcome_message, regexp=expected_outcome_message, perl=TRUE)
expect_true(returned_object$success)
expect_s3_class(returned_object$data, "tbl")
})
test_that("bad token -Error", {
testthat::skip_on_cran()
Expand Down

0 comments on commit 293dc5e

Please sign in to comment.