diff --git a/.Rbuildignore b/.Rbuildignore index c0537c2..60d60ae 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -7,3 +7,6 @@ ^docs$ ^pkgdown$ ^\.github$ +^vignettes/articles$ +^doc$ +^Meta$ diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml new file mode 100644 index 0000000..0ab748d --- /dev/null +++ b/.github/workflows/test-coverage.yaml @@ -0,0 +1,62 @@ +# Workflow derived from https://github.com/r-lib/actions/tree/v2/examples +# Need help debugging build failures? Start at https://github.com/r-lib/actions#where-to-find-help +on: + push: + branches: [main, master] + pull_request: + +name: test-coverage.yaml + +permissions: read-all + +jobs: + test-coverage: + runs-on: ubuntu-latest + env: + GITHUB_PAT: ${{ secrets.GITHUB_TOKEN }} + + steps: + - uses: actions/checkout@v4 + + - uses: r-lib/actions/setup-r@v2 + with: + use-public-rspm: true + + - uses: r-lib/actions/setup-r-dependencies@v2 + with: + extra-packages: any::covr, any::xml2 + needs: coverage + + - name: Test coverage + run: | + cov <- covr::package_coverage( + quiet = FALSE, + clean = FALSE, + install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") + ) + print(cov) + covr::to_cobertura(cov) + shell: Rscript {0} + + - uses: codecov/codecov-action@v5 + with: + # Fail if error if not on PR, or if on PR and token is given + fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }} + files: ./cobertura.xml + plugins: noop + disable_search: true + token: ${{ secrets.CODECOV_TOKEN }} + + - name: Show testthat output + if: always() + run: | + ## -------------------------------------------------------------------- + find '${{ runner.temp }}/package' -name 'testthat.Rout*' -exec cat '{}' \; || true + shell: bash + + - name: Upload test results + if: failure() + uses: actions/upload-artifact@v4 + with: + name: coverage-test-failures + path: ${{ runner.temp }}/package diff --git a/.gitignore b/.gitignore index 6ebd4e6..74167b2 100644 --- a/.gitignore +++ b/.gitignore @@ -6,3 +6,5 @@ docs .httr-oauth .DS_Store .quarto +/doc/ +/Meta/ diff --git a/DESCRIPTION b/DESCRIPTION index 440887e..76e597e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: REDCapDM Type: Package Title: 'REDCap' Data Management -Version: 0.9.9.2000 +Version: 1.0.0 Authors@R: c( person("João", "Carmezim", email = "jcarmezim@igtp.cat", role = c("aut", "cre")), person("Pau", "Satorra", role = c("aut")), @@ -11,16 +11,15 @@ Authors@R: c( person("Cristian", "Tebé", role = c("aut")) ) Maintainer: João Carmezim -Description: REDCap Data Management - REDCapDM is an R package that allows users to manage data exported directly from REDCap or using an API connection. This package includes several functions designed for pre-processing data, generating reports of queries such as outliers or missing values, and following up on the identified queries. 'REDCap' (Research Electronic Data CAPture; ) is a web application developed at Vanderbilt University, designed for creating and managing online surveys and databases and the REDCap API is an interface that allows external applications to connect to REDCap remotely, and is used to programmatically retrieve or modify project data or settings within REDCap, such as importing or exporting data. +Description: REDCap Data Management - 'REDCap' (Research Electronic Data CAPture; ) is a web application developed at Vanderbilt University, designed for creating and managing online surveys and databases and the REDCap API is an interface that allows external applications to connect to REDCap remotely, and is used to programmatically retrieve or modify project data or settings within REDCap, such as importing or exporting data. REDCapDM is an R package that allows users to manage data exported directly from REDCap or using an API connection. This package includes several functions designed for pre-processing data, generating reports of queries such as outliers or missing values, and following up on previously identified queries. License: MIT + file LICENSE URL: https://bruigtp.github.io/REDCapDM/, https://doi.org/10.1186/s12874-024-02178-6 BugReports: https://github.com/bruigtp/REDCapDM/issues Encoding: UTF-8 -RoxygenNote: 7.3.2 +RoxygenNote: 7.3.3 Imports: dplyr, janitor, - magrittr, openxlsx, purrr, REDCapR, @@ -33,12 +32,18 @@ Imports: utils, stringi, cli, - forcats + forcats, + lifecycle Suggests: knitr, rmarkdown, - kableExtra + kableExtra, + testthat (>= 3.0.0), + mockery VignetteBuilder: knitr Depends: - R (>= 3.6) + R (>= 4.1) LazyData: true +Config/testthat/edition: 3 +Config/Needs/website: rmarkdown +Roxygen: list(markdown = TRUE) diff --git a/NAMESPACE b/NAMESPACE index 10dbec9..ba00b00 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,15 +1,25 @@ # Generated by roxygen2: do not edit by hand -export("%>%") export(check_queries) +export(rd_checkbox) +export(rd_dates) +export(rd_delete_vars) +export(rd_dictionary) export(rd_event) export(rd_export) +export(rd_factor) export(rd_insert_na) export(rd_query) +export(rd_recalculate) export(rd_rlogic) +export(rd_split) export(rd_transform) export(redcap_data) import(cli) -importFrom(magrittr,"%>%") +importFrom(lifecycle,deprecated) importFrom(rlang,":=") importFrom(rlang,.data) +importFrom(rlang,eval_tidy) +importFrom(rlang,parse_expr) +importFrom(stats,na.omit) +importFrom(stats,setNames) diff --git a/R/REDCapDM-package.R b/R/REDCapDM-package.R new file mode 100644 index 0000000..e43e8eb --- /dev/null +++ b/R/REDCapDM-package.R @@ -0,0 +1,49 @@ +#' @name REDCapDM-package +#' @keywords internal +#' @aliases REDCapDM +#' +#' @title Managing REDCap Data: The R package REDCapDM / REDCapDM: A Toolkit for Managing REDCap Data in R +#' +#' @description +#' The **REDCapDM** package provides tools to import, process, and manage REDCap data within R. +#' It supports data retrieval through the REDCap API or directly from exported files and includes a robust +#' set of functions for data transformation, validation, and discrepancy management. Designed for efficient +#' workflow integration, **REDCapDM** simplifies the handling of REDCap datasets, making it easier to ensure +#' data quality and consistency. +#' +#' Key Features: +#' +#' - **Flexible Data Import**: Import data directly from REDCap using API connections or process exported REDCap files. +#' - **Data Transformation**: Streamline the cleaning and preparation of raw datasets for analysis. +#' - **Query Management**: Identify and track data discrepancies, missing events, and manage resolution reports. +#' +#' Core Functions: +#' +#' - `redcap_data`: Reads data exported from REDCap or retrieved through the REDCap API into R. +#' - `rd_transform`: One-step pipeline to clean and preprocess the raw REDCap data. +#' - `rd_dates`: Standardize date and datetime fields. +#' - `rd_delete_vars`: Remove specified variables (by name or pattern). +#' - `rd_recalculate`: Recompute calculated fields and compare with REDCap values. +#' - `rd_factor`: Replace numeric multiple-choice columns with their factor version. +#' - `rd_checkbox`: Expand checkbox responses with custom labels and rename 'var___1' columns (REDCap style) to 'var_option'. +#' - `rd_split`: Splits a REDCap dataset by form or event. +#' - `rd_insert_na`: Manually set specified variables to missing based on a logical filter. +#' - `rd_rlogic`: Translate REDCap branching or calculation logic into R syntax. +#' - `rd_dictionary`: Update dictionary (translation of REDCap logic into R syntax) to reflect transformed data and logic. +#' - `rd_query`: Identifies discrepancies (queries) in the dataset for validation. +#' - `rd_event`: Detects missing events in longitudinal datasets. +#' - `check_queries`: Compares historical and current query reports to track changes and additions. +#' - `rd_export`: Exports a summary report of identified queries to an Excel (.xlsx) file. +#' +#' +#' @examples +#' \dontrun{ +#' # Install REDCapDM from CRAN: +#' install.packages("REDCapDM") +#' +#' # Install the latest version of REDCapDM from GitHub: +#' remotes::install_github("bruigtp/REDCapDM") +#' } +#' +#' @importFrom lifecycle deprecated +NULL diff --git a/R/REDCapDM_PACKAGE.R b/R/REDCapDM_PACKAGE.R deleted file mode 100644 index 235f73f..0000000 --- a/R/REDCapDM_PACKAGE.R +++ /dev/null @@ -1,37 +0,0 @@ -#' @name REDCapDM-package -#' @keywords internal -#' @aliases REDCapDM -#' -#' @title Managing REDCap Data: The R package REDCapDM -#' -#' @description -#' -#' The REDCapDM package facilitates the importing of data from REDCap into R through either an API connection or directly from exported files. It includes a range of data processing and transformation functions, and supports the creation and management of queries to address any discrepancies or uncertainties within the dataset. -#' -#' REDCapDM functions: -#' -#' - `redcap_data`: reads data exported directly from REDCap or via an API connection. -#' -#' - `rd_transform`: processes the raw dataset. -#' -#' - `rd_rlogic`: translates REDCap logic into R logic. -#' -#' - `rd_insert_na`: manually inserts a missing value for specified variables using a filter. -#' -#' - `rd_query`: identifies discrepancies in the dataset (queries). -#' -#' - `rd_event`: identifies missing events in each record of the dataset. -#' -#' - `check_queries`: compares a current report of queries with an older one to determine which queries have been modified, which remain unchanged, and which are new. -#' -#' - `rd_export`: exports a report of identified queries to an .xlsx file. -#' -#' @examples -#' \dontrun{ -#' # Install REDCapDM from CRAN: -#' install.packages('REDCapR') -#' -#' # Install REDCapDM from GitHub: -#' remotes::install_github('bruigtp/REDCapDM') -#' } -NULL diff --git a/R/check_queries.R b/R/check_queries.R index c8e5e2f..376bcf4 100644 --- a/R/check_queries.R +++ b/R/check_queries.R @@ -1,104 +1,178 @@ #' Check for Changes Between Two Query Reports #' -#' This function compares an old report of queries with a new one. It allows you to identify which queries are new, which have been modified, and which remain unchanged. -#' @param old Previous version of the queries report. -#' @param new New version of the queries report. This object is used to determine the status of each query. -#' @param report_title Character string specifying the title of the report. -#' @return A list consisting of a dataframe containing each individual query from both reports and a column showing the status of the queries (new, solved, miscorrected or pending) compared to the previous query report. In addition to this dataframe, there is also a summary of the total number of queries per category. +#' @description +#' `r lifecycle::badge('stable')` +#' +#' @description +#' Compare an older query report (`old`) with a newer one (`new`) and classify each +#' query into one of four statuses: +#' \itemize{ +#' \item \strong{Pending} — the same query is present in both reports (no change detected), +#' \item \strong{Solved} — the query was present in the old report but is absent from the new report, +#' \item \strong{New} — the query appears in the new report but was not present in the old report, +#' \item \strong{Miscorrected} — a special case where a query in the new report is marked as \code{New} +#' but shares the same \code{Identifier} and \code{Description} as an existing record (suggesting a +#' re-issued or modified query for the same identifier). +#' } +#' +#' The function returns a detailed comparison table of queries with a \code{Modification} factor (one of the four statuses) and an HTML summary table showing counts per status. +#' +#' @param old Data frame containing the previous (older) query report. Must include +#' \code{Identifier}, \code{Description} and \code{Query} columns (character or factor). +#' @param new Data frame containing the newer query report. Must include +#' \code{Identifier}, \code{Description} and \code{Query} columns (character or factor). +#' If \code{new} contains a \code{Code} column, it will be removed at the start of processing. +#' @param report_title Optional single string used as the caption for the HTML summary table. +#' Defaults to \code{"Comparison report"} when not supplied or when \code{NA}. +#' @param return_viewer Logical; if \code{TRUE} (default) an HTML table (knitr/kable + kableExtra) +#' summarizing the counts per state is produced and returned in the \code{results} element of the +#' returned list. If \code{FALSE}, no HTML viewer is produced (useful for non-interactive runs). +#' +#' @return A list with two elements: +#' \describe{ +#' \item{\code{queries}}{A data frame containing all queries present in either \code{old} or \code{new}. +#' A factor column \code{Modification} indicates the state for each row (levels: \code{Pending}, +#' \code{Solved}, \code{Miscorrected}, \code{New}). The function also reassigns \code{Code} +#' values so codes are consistent per \code{Identifier}.} +#' \item{\code{results}}{If \code{return_viewer = TRUE}, an HTML \code{knitr::kable} (styled with +#' \code{kableExtra}) summarising totals per state. If \code{return_viewer = FALSE}, this is \code{NULL}.} +#' } +#' +#' @details +#' Requirements: +#' \itemize{ +#' \item Both \code{old} and \code{new} must be data frames. +#' \item Both data frames must contain at least the following character columns: +#' \code{Identifier}, \code{Description}, and \code{Query}. +#' \item A \code{Code} column is optional; if present it will be preserved and considered +#' for sorting and output. If \code{Code} exists in \code{new}, it is removed at the +#' beginning of the routine to avoid conflicts with re-assigned codes. +#' } +#' +#' The function merges the two reports, constructs composite keys used for comparison, classifies each row into a modification state, detects and re-labels \code{Miscorrected} cases, reassigns a \code{Code} per \code{Identifier} to keep codes consistent, and returns a detailed dataset plus an optional HTML summary viewer. +#' +#' @section Notes and edge cases: +#' \itemize{ +#' \item \strong{Column types:} If \code{Identifier}, \code{Description} or \code{Query} are +#' factors, they will be used in the comparison — it is recommended to convert them to +#' character prior to calling \code{check_queries()} to avoid factor-level mismatches. +#' \item \strong{Sorting:} When \code{Identifier} values contain a dash (e.g. \code{"100-20"}), +#' the function attempts to split into numeric \code{center} and \code{id} parts for +#' logical ordering. Otherwise \code{Identifier} is coerced to numeric for ordering. +#' \item \strong{Miscorrected detection:} A \code{Miscorrected} label is assigned when more +#' than one row shares the same \code{Identifier + Description} composite and a row is +#' otherwise classified as \code{New} — this signals a likely re-issued or modified query +#' for an existing identifier. +#' } +#' #' @examples -#' # Example of a query -#' data_old <- rd_query(covican, -#' variables = "copd", -#' expression = "is.na(x)", -#' event = "baseline_visit_arm_1") -#' data_new <- rbind(data_old$queries[1:5,], c("100-20",rep("abc",8))) +#' # Minimal reproducible example +#' old <- data.frame( +#' Identifier = c("100-1", "100-2", "200-1"), +#' Description = c("age check", "weight check", "lab miss"), +#' Query = c("is.na(age)", "is.na(weight)", "missing lab result"), +#' Code = c("100-1-1", "100-2-1", "200-1-1"), +#' stringsAsFactors = FALSE +#' ) +#' +#' new <- data.frame( +#' Identifier = c("100-1", "200-1", "300-1"), +#' Description = c("age check", "lab miss", "new query"), +#' Query = c("is.na(age)", "missing lab result (clarify)", "is.na(x)"), +#' stringsAsFactors = FALSE +#' ) +#' +#' res <- check_queries(old = old, new = new, report_title = "My Query Comparison") +#' # detailed table +#' head(res$queries) +#' # HTML summary (if in an RMarkdown or interactive viewer) +#' res$results #' -#' # Control of queries -#' check <- check_queries(old = data_old$queries, -#' new = data_new) #' @export -check_queries <-function(old, new, report_title = NULL) - { +check_queries <- function(old, new, report_title = NULL, return_viewer = TRUE) { + # Ensure both objects provided are dataframes + if (!is.data.frame(old) | !is.data.frame(new)) { + stop("The 'old' and 'new' arguments must be a data frame.", call. = FALSE) + } + if (!is.null(report_title) && length(report_title) > 1) { + stop("There is more than one title for the report, please choose only one.", call. = FALSE) + } - # Creation of the merged dataset - new <- new %>% dplyr::select(-"Code") - old[,"comp"] <- paste0(old$Identifier, old$Description, old$Query) - new[,"comp"] <- paste0(new$Identifier, new$Description, new$Query) + # Merge old and new datasets + new <- new |> dplyr::select(-dplyr::any_of("Code")) + old[, "comp"] <- paste0(old$Identifier, old$Description, old$Query) + new[, "comp"] <- paste0(new$Identifier, new$Description, new$Query) check <- merge(old, new, by = intersect(names(old), names(new)), all = TRUE) - # Checking each type of query - check[,"comp"] <- paste0(check$Identifier, check$Description, check$Query) - check[,"comp2"] <- paste0(check$Identifier, check$Description) - check[,"Modification"] <- NA - check[,"Modification"][check$comp %in% old$comp & check$comp %in% new$comp] <- "Pending" - check[,"Modification"][check$comp %in% old$comp & !check$comp %in% new$comp] <- "Solved" - check[,"Modification"][!check$comp %in% old$comp & check$comp %in% new$comp] <- "New" - - # Adding the new category of miscorrected if a query is not present in the old report but there is a new query from the same variable with the same identifier - check <- check %>% - dplyr::group_by(.data$comp2) %>% - dplyr::mutate(n = dplyr::n()) + # Add columns for comparisons and determine statuses + check[, "comp"] <- paste0(check$Identifier, check$Description, check$Query) + check[, "comp2"] <- paste0(check$Identifier, check$Description) + check[, "Modification"] <- NA + check[, "Modification"][check$comp %in% old$comp & check$comp %in% new$comp] <- "Pending" + check[, "Modification"][check$comp %in% old$comp & !check$comp %in% new$comp] <- "Solved" + check[, "Modification"][!check$comp %in% old$comp & check$comp %in% new$comp] <- "New" + + # Identify miscorrected queries: If a query does not exist in the old report, but there is a new query from the same variable with the same identifier + check <- check |> + dplyr::group_by(.data$comp2) |> + dplyr::mutate(n = dplyr::n()) check <- as.data.frame(check) - # The duplicated queries are the ones that were miscorrected if (any(check[, "n"] > 1)) { - dups <- check %>% - dplyr::filter(.data$n > 1 & .data$Modification %in% "New") + dups <- check |> + dplyr::filter(.data$n > 1 & .data$Modification %in% "New") if (nrow(dups) > 0) { dups[, "Modification"] <- "Miscorrected" - check <- check %>% + check <- check |> dplyr::filter(!(.data$n > 1 & .data$Modification %in% "New")) check <- rbind(check, dups) } } - # Convert the column Modification in a factor + # Convert the "Modification" column to a factor check[, "Modification"] <- factor(check[, "Modification"], - levels = c("Pending", "Solved", "Miscorrected", "New")) + levels = c("Pending", "Solved", "Miscorrected", "New") + ) - # Remove exceeding columns - check <- check %>% - dplyr::select(-"comp", -"comp2", -"n") + # Clean up unnecessary columns + check <- check |> + dplyr::select(-dplyr::any_of(c("comp", "comp2", "n"))) - # Arrange the dataset + # Arrange the dataset by specific fields if (any(stringr::str_detect(check$Identifier, "-"))) { - - check <- check %>% tidyr::separate("Identifier", c("center", "id"), sep = "([-])", remove = FALSE) + check <- check |> tidyr::separate("Identifier", c("center", "id"), sep = "([-])", remove = FALSE) check[, "center"] <- as.numeric(check[, "center"]) check[, "id"] <- as.numeric(check[, "id"]) check <- check[order(check[, "center"], check[, "id"], check[, "Code"], na.last = TRUE), ] rownames(check) <- NULL - check <- check %>% - dplyr::select(-"center", -"id") - + check <- check |> + dplyr::select(-dplyr::any_of(c("center", "id"))) } else { - check$Identifier <- as.numeric(check$Identifier) check <- check[order(check$Identifier, check$Code), ] - } - # We update the code of each query in order to match the old dataset - check <- data.frame(check %>% - dplyr::group_by(.data$Identifier) %>% - dplyr::mutate(cod = 1:dplyr::n())) + # Assign new codes to each query to match the old dataset + check <- data.frame(check |> + dplyr::group_by(.data$Identifier) |> + dplyr::mutate(cod = 1:dplyr::n())) check$Code <- paste0(as.character(check$Identifier), "-", check$cod) - check <- check %>% - dplyr::select(-"cod") + check <- check |> + dplyr::select(-dplyr::any_of("cod")) - # Creation of the report indicating the variables checked - report <- check %>% - dplyr::group_by(.data$Modification, .drop = FALSE) %>% - dplyr::summarise("total" = dplyr::n()) + # Summarize query statuses + report <- check |> + dplyr::group_by(.data$Modification, .drop = FALSE) |> + dplyr::summarise("total" = dplyr::n()) report <- as.data.frame(report) report <- report[order(as.numeric(report$total), decreasing = TRUE), ] names(report) <- c("State", "Total") rownames(report) <- NULL - # Before starting we check if there is more than one report_title and if it isn't the case we stabilish the caption for the report_title + # Handle report title if (all(is.na(report_title))) { report_title <- "Comparison report" } else { @@ -107,13 +181,17 @@ check_queries <-function(old, new, report_title = NULL) } } - # Adaptation to viewer - viewer <- knitr::kable(report, align = c("cc"), row.names = FALSE, caption = report_title, format = "html", longtable = TRUE) - viewer <- kableExtra::kable_styling(viewer, bootstrap_options = c("striped", "condensed"), full_width = FALSE) - viewer <- kableExtra::row_spec(viewer, 0, italic = FALSE, extra_css = "border-bottom: 1px solid grey") + # Generate styled HTML summary + viewer <- NULL + if (isTRUE(return_viewer)) { + viewer <- knitr::kable(report, align = c("cc"), row.names = FALSE, caption = report_title, format = "html", longtable = TRUE) + viewer <- kableExtra::kable_styling(viewer, bootstrap_options = c("striped", "condensed"), full_width = FALSE) + viewer <- kableExtra::row_spec(viewer, 0, italic = FALSE, extra_css = "border-bottom: 1px solid grey") + } - # Return the final product - list(queries = check, - results = viewer) + # Return results + list( + queries = check, + results = viewer + ) } - diff --git a/R/rd_checkbox.R b/R/rd_checkbox.R new file mode 100644 index 0000000..3c8a32a --- /dev/null +++ b/R/rd_checkbox.R @@ -0,0 +1,407 @@ +#' Transform Checkbox Variables in a REDCap Project +#' +#' @description +#' `r lifecycle::badge('experimental')` +#' +#' This function is used to process checkbox variables in a REDCap dataset. By default, it changes their default categories ("Unchecked" and "Checked") to new ones ("No" and "Yes). Optionally, the function can also evaluate the branching logic for checkbox fields and adjust the data and dictionary accordingly. +#' +#' @param project A list containing the REDCap data, dictionary, and event mapping (expected `redcap_data()` output). Overrides `data`, `dic`, and `event_form`. +#' @param data A `data.frame` or `tibble` with the REDCap dataset. +#' @param dic A `data.frame` with the REDCap dictionary. +#' @param event_form Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects. +#' @param checkbox_labels Character vector of length 2 for labels of unchecked/checked values. Default: `c("No", "Yes")`. +#' @param checkbox_names Logical. If `TRUE` (default), checkbox columns are renamed using choice labels. +#' @param na_logic Controls how missing values are set based on branching logic. Must be one of `"none"` (do nothing), `"missing"` (set to `NA` only when the logic evaluation is `NA`), or `"eval"` (set to `NA` when the logic evaluates to `FALSE`). Defaults to `"none"`. +#' +#' @return A list with: +#' \describe{ +#' \item{data}{Transformed dataset with checkbox fields as factors and optionally renamed.} +#' \item{dictionary}{Updated dictionary with checkbox fields expanded and optionally renamed.} +#' \item{event_form}{The `event_form` passed in (if applicable).} +#' \item{results}{Summary of transformations and any fields needing review.} +#' } +#' +#' @details +#' * Checkbox columns are expected in REDCap wide format (`field___code`). +#' * Branching logic evaluation requires `event_form` for longitudinal projects. +#' * Names are cleaned and truncated to 60 characters; uniqueness is enforced. +#' * Fields that cannot be evaluated are listed in `results`. +#' +#' +#' @examples +#' # Basic usage with a project object +#' res <- rd_checkbox(covican) +#' +#' # With custom labels +#' res <- rd_checkbox(data = covican$data, +#' dic = covican$dictionary, +#' checkbox_labels = c("Not present", "Present")) +#' +#' # Keep original checkbox names +#' res <- rd_checkbox(covican, checkbox_names = FALSE) +#' +#' # Longitudinal project with NA logic +#' res <- rd_checkbox(data = covican$data, +#' dic = covican$dictionary, +#' event_form = covican$event_form,, +#' na_logic = "eval") +#' +#' @export +#' @importFrom stats setNames na.omit + +rd_checkbox <- function(project = NULL, data = NULL, dic = NULL, event_form = NULL, checkbox_labels = c("No", "Yes"), checkbox_names = TRUE, na_logic = "none") { + results <- NULL + rlogic_eval <- NULL + + # validate na_logic against allowed choices + na_logic <- match.arg(na_logic, choices = c("none", "missing", "eval")) + + # Handle potential overwriting when both `project` and other arguments are provided + if (!is.null(project)) { + env_vars <- check_proj(project, data, dic, event_form) + list2env(env_vars, envir = environment()) + } + + # Ensure both `data` and `dic` are provided; stop if either is missing + if (is.null(data) | is.null(dic)) { + stop("Both `data` and `dic` (data and dictionary) arguments must be provided.") + } + + # Extract labels from the data to reapply later + labels <- labels <- purrr::map_chr(data, function(x) { + lab <- attr(x, "label") + if (!is.null(lab)) { + lab + } else { + "" + } + }) + + # Identify if the project is longitudinal or includes repeated instruments + longitudinal <- "redcap_event_name" %in% names(data) + repeat_instrument <- any("redcap_repeat_instrument" %in% names(data) & !is.na(data$redcap_repeat_instrument)) + + # Identify checkbox variables in the data (those with '___' in their names) + var_check <- names(data)[grep("___", names(data))] + + # Remove factor-type checkbox variables from the list + var_check_factors <- var_check[grep(".factor$", var_check)] + + # Identify checkbox variables in the dictionary + var_check_dic <- dic$field_name[dic$field_type == "checkbox"] + + # Ensure there are checkbox fields in either the data or the dictionary + if (length(var_check) == 0 & length(var_check_dic) == 0) { + stop("No checkbox fields found in either the data or the dictionary.") + } + + # Check for missing checkbox fields in either the data or the dictionary + if (length(var_check) > 0 & length(var_check_dic) == 0) { + stop("No checkbox fields found in the dictionary.") + } + if (length(var_check) == 0 & length(var_check_dic) > 0) { + stop("No checkbox fields found in the data.") + } + + # Remove factor-type checkbox variables from the data + if (length(var_check_factors) > 0) { + var_check <- var_check[!grepl(".factor$", var_check)] + } else { + if (any(purrr::map_lgl(var_check, ~ "Unchecked" %in% levels(data[[.x]])))) { + # Transform checkbox variables into binary values (0 or 1) + data <- data |> + dplyr::mutate(dplyr::across( + tidyselect::all_of(var_check), + ~ dplyr::case_when( + .x == "Unchecked" ~ 0, + .x == "Checked" ~ 1, + TRUE ~ NA + ) + )) + } + } + + # Update results with the this transformation + reason <- if (na_logic == "eval") + "when the logic isn't satisfied or it's missing" + else if (na_logic == "missing") + "when the logic is missing" + else + "" + + base <- "Transforming checkboxes: changing their values to No/Yes and changing their names to the names of its options." + + transf_message <- if (repeat_instrument || reason == "") base + else paste0(base, " For checkboxes that have a branching logic, ", reason, " their values will be set to missing.") + + if (is.null(results)) { + results <- c(results, stringr::str_glue("{transf_message} (rd_checkbox)\n")) + } else { + + if(grepl("^[A-Z]", results[1])) { + results[1] <- paste("1.", results[1]) + } + + last_val_res <- results |> + stringr::str_extract("^(\n)?\\d+\\.") |> + na.omit() |> + dplyr::last() |> + stringr::str_remove("\\.") |> + as.numeric() + + results <- c(results, stringr::str_glue("\n\n{last_val_res + 1}. {transf_message} (rd_checkbox)\n")) + } + + # Evaluate branching logic for checkbox variables if applicable + if (any(dic$field_type == "checkbox" & dic$branching_logic_show_field_only_if != "")) { + if (is.null(event_form) & longitudinal) { + warning("Branching logic evaluation could not be performed because the project contains multiple events and the event-form correspondence was not specified. Please provide the `event_form` argument to enable branching logic evaluation.", call. = FALSE) + } else { + # Handle projects with repeated instruments where branching logic can't be evaluated + if (repeat_instrument) { + warning("The project contains repeated instruments, and this function cannot accurately evaluate the branching logic of checkboxes in such cases.", call. = FALSE) + } + + + caption <- "Checkbox variables advisable to be reviewed" + review <- NULL + review2 <- NULL + + for (i in seq_along(var_check_dic)) { + # Identify variables associated with each checkbox option + vars_data <- names(data)[grep(stringr::str_glue("{var_check_dic[i]}___"), names(data))] + vars_data <- vars_data[!grepl(".factor$", vars_data)] + + # Retrieve branching logic for the checkbox field + logic <- dic$branching_logic_show_field_only_if[dic$field_name == var_check_dic[i]] + + # If there is branching logic, attempt to translate and evaluate it + if (!is.na(logic) & !logic %in% "") { + # Checking if the logic is already in R format + if (grepl("<>|\\[.*?\\]", logic) & !grepl("==|!=|\\$", logic)) { + # Translate REDCap logic to R language using rd_rlogic function + rlogic <- try(rd_rlogic(data = data, dic = dic, event_form = event_form, logic = logic, var = var_check_dic[i]), silent = TRUE) + + if (!inherits(rlogic, "try-error")) { + # Evaluate the logic and apply missing values accordingly + rlogic_eval <- rlogic$eval + } else { + # Track variables that can't be evaluated due to logic issues + review2 <- c(review2, var_check_dic[i]) + } + } else { + rlogic_eval <- eval(parse(text = logic)) + } + + # Set missing values where logic is not satisfied + if (na_logic == "eval") { + for (j in seq_along(vars_data)) { + data[, vars_data[j]] <- ifelse(rlogic_eval, as.character(data[, vars_data[j]]), NA) + } + } else if (na_logic == "missing") { + # Set missing values only where logic evaluation is missing + for (j in seq_along(vars_data)) { + data[, vars_data[j]] <- ifelse(!is.na(rlogic_eval), as.character(data[, vars_data[j]]), NA) + } + } + } else { + # If no branching logic, mark variable for review + review <- c(review, var_check_dic[i]) + } + } + + # Summarize the results of the branching logic review + if (!is.null(review)) { + results1 <- tibble::tibble("Variables without any branching logic" = review) + results <- c(results, "", knitr::kable(results1, "pipe", align = c("ccc"), caption = caption)) + if (!is.null(review2)) { + results <- c(results, "\n") + caption <- NULL + } + } + + if (!is.null(review2)) { + results2 <- tibble::tibble("Variables with a logic that can't be transcribed" = review2) + results <- c(results, knitr::kable(results2, "pipe", align = c("ccc"), caption = caption)) + } + + data <- data + } + } + + # Transform checkbox variables into the defined labels + if (length(var_check_factors) > 0) { + data <- data |> + dplyr::mutate(dplyr::across( + tidyselect::all_of(var_check_factors), + ~ factor(.x, levels = c("Unchecked", "Checked"), labels = checkbox_labels) + )) + } else { + data <- data |> + dplyr::mutate(dplyr::across( + tidyselect::all_of(var_check), + ~ factor(as.character(.x), levels = c(0, 1), labels = checkbox_labels) + )) + } + + + # Identify checkbox variables + var_check <- names(data)[grep("___", names(data))] + + # Trim the checkbox variable names + names_trim <- unique(gsub("___.*$", "", var_check)) + + correspondence <- NULL + + # Update the dictionary with new variable names and labels + for (i in seq_along(names_trim)) { + # Find variable names in `var_check` that start with the current name in `names_trim` + svar_check <- grep(stringr::str_glue("^{names_trim[i]}___"), var_check, value = TRUE) + svar_check <- svar_check[!grepl(".factor$", svar_check)] + + # Extract labels corresponding to the found variables + label <- labels[svar_check] + label <- gsub(".*choice=", "", label) + label <- gsub("\\)", "", label) + + # Add rows to dictionary for each checkbox option + new_row <- dic |> + dplyr::filter(.data$field_name == names_trim[i]) + + # Repeat the `new_row` for each checkbox option and update fields + new_row <- purrr::map_dfr(seq_len(length(svar_check)), ~new_row) |> + dplyr::mutate( + field_name = svar_check, + field_label = label, + choices_calculations_or_slider_labels = stringr::str_glue("0, {checkbox_labels[1]} | 1, {checkbox_labels[2]}") + ) + + # Add the new row to the dictionary and remove the original checkbox variable + dic <- dic |> + tibble::add_row(new_row, .before = which(dic$field_name == names_trim[i])) |> + dplyr::filter(!.data$field_name %in% names_trim[i]) + + # Create clean variable names for the new checkbox options + label_name <- purrr::map_chr(label, ~ janitor::make_clean_names(.x)) + label_name <- gsub("^x(\\d)", "\\1", label_name) + + if (checkbox_names) { + + # Generate new variable names by appending the cleaned labels to the original variable names + out <- stringr::str_glue("{names_trim[i]}_{label_name}") + + # Trim the name if it exceeds 60 characters (to prevent very long names) + out <- strtrim(out, 60) + + # Save correspondence between the old names and the new names + x <- cbind(gsub("___(.+)", "\\(\\1\\)", svar_check), out) + correspondence <- rbind(correspondence, x) + + # For each new variable name, check if it already exists in the dataset + for (j in seq_along(out)) { + out0 <- out[j] + + # Ensure uniqueness by appending a unique suffix if necessary + out[j] <- utils::tail(make.unique(c(names(data), out[j])), 1) + + # If the name was changed to ensure uniqueness, issue a warning + if (out[j] != out0) { + warning( + stringr::str_glue( + "The transformed checkbox name '{out0}' already exists in the dataset. It has been renamed to '{out[j]}' to avoid conflicts." + ) + ) + + correspondence[,"out"] <- ifelse(correspondence[,"out"] == out0, out[j], correspondence[,"out"]) + } + + # Update the variable names in the data and dictionary + names(data) <- dplyr::case_when(names(data) == svar_check[j] ~ out[j], + names(data) == paste0(svar_check[j], ".factor") ~ paste0(out[j], ".factor"), + .default = names(data)) + + # Update the labels to match the new variable names + names(labels) <- dplyr::case_when(names(labels) == svar_check[j] ~ out[j], + names(labels) == paste0(svar_check[j], ".factor") ~ paste0(out[j], ".factor"), + .default = names(labels)) + + # Update the dictionary with the new variable name + dic <- dic |> + dplyr::mutate(field_name = dplyr::case_when(field_name == svar_check[j] ~ out[j], TRUE ~ field_name)) + } + } else { + # Trim the name if it exceeds 60 characters (to prevent very long names) + out <- strtrim(svar_check, 60) + + # Save correspondence between the old names and the new names + x <- cbind(gsub("___(.+)", "\\(\\1\\)", svar_check), out) + correspondence <- rbind(correspondence, x) + } + } + + # After processing all the checkboxes, transform the branching logic that contains checkboxes + correspondence <- as.data.frame(correspondence) + + # Filter the dictionary to include only variables that were renamed during checkbox transformation + cats <- dic |> + dplyr::select("field_name", "choices_calculations_or_slider_labels") |> + dplyr::filter(.data$field_name %in% correspondence$out) + + # Split the `choices_calculations_or_slider_labels` into separate options for each checkbox + cats <- cats |> + dplyr::mutate(choices_calculations_or_slider_labels = strsplit(.data$choices_calculations_or_slider_labels, "\\|")) |> + tidyr::unnest("choices_calculations_or_slider_labels") + + # Separate numeric and category parts from the options + cats <- cats |> + tidyr::separate(.data$choices_calculations_or_slider_labels, c("num", "cat"), ", ", extra = "merge") |> + dplyr::filter(.data$cat != "") |> + dplyr::mutate(num = trimws(.data$num), cat = trimws(.data$cat)) + + # Merge the transformed data with the correspondence to link new names with the original variables + cats <- merge(cats, correspondence, by.x = "field_name", by.y = "out") + + # Prepare the branching logic expressions for the transformed checkbox variables + cats <- cats |> + dplyr::mutate( + factor = paste0("[", .data$field_name, "]='", .data$cat, "'"), + V1 = stringi::stri_replace_all_fixed(cats$V1, c("(", ")"), c("\\(", "\\)"), vectorize_all = FALSE), + redcap = paste0("\\[", .data$V1, "\\] ?=? ?'?", .data$num, "'?"), + redcap2 = paste0("\\[", .data$V1, "\\] ?? ?'?", .data$num, "'?") + ) |> + dplyr::select(-"V1") |> + dplyr::arrange(dplyr::desc(.data$redcap)) + + # Create the final mappings for replacing the branching logic in REDCap with the new factor logic + replace <- setNames(cats$factor, cats$redcap) + replace2 <- setNames(cats$factor, cats$redcap2) + + # Apply the new branching logic to the dictionary by replacing the old logic with the new ones + dic <- dic |> + dplyr::mutate( + choices_calculations_or_slider_labels = stringr::str_replace_all(.data$choices_calculations_or_slider_labels, replace), + choices_calculations_or_slider_labels = stringr::str_replace_all(.data$choices_calculations_or_slider_labels, replace2), + branching_logic_show_field_only_if = stringr::str_replace_all(.data$branching_logic_show_field_only_if, replace), + branching_logic_show_field_only_if = stringr::str_replace_all(.data$branching_logic_show_field_only_if, replace2) + ) + + # Returning checkboxes to numeric version + if (length(var_check_factors) > 0) { + data <- data |> + dplyr::mutate(dplyr::across(correspondence$out, ~ as.numeric(.x))) + } + + # Apply the labels to the data + data <- data |> + labelled::set_variable_labels(.labels = labels |> as.list(), .strict = FALSE) + + + # Return the modified data, dictionary, event_form, and results + list( + data = data, + dictionary = dic, + event_form = event_form, + results = stringr::str_glue("{results}") + ) |> + purrr::compact() # Remove any NULL elements from the output list +} diff --git a/R/rd_dates.R b/R/rd_dates.R new file mode 100644 index 0000000..bbb3921 --- /dev/null +++ b/R/rd_dates.R @@ -0,0 +1,129 @@ +#' Transform Dates and Datetimes in REDCap Data +#' +#' @description +#' `r lifecycle::badge('experimental')` +#' +#' Converts date and datetime fields in a REDCap dataset to appropriate R classes. +#' +#' @param project A list containing the REDCap data, dictionary, and event mapping (expected `redcap_data()` output). Overrides `data`, `dic`, and `event_form`. +#' @param data A `data.frame` or `tibble` with the REDCap dataset. +#' @param dic A `data.frame` with the REDCap dictionary. +#' @param event_form Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects. +#' +#' @return A list with the following elements: +#' \describe{ +#' \item{data}{The transformed dataset with date and datetime fields formatted as `Date` and `POSIXct`.} +#' \item{dictionary}{The original REDCap dictionary passed to the function.} +#' \item{event_form}{The original event-form mapping (if applicable).} +#' \item{results}{A summary of the transformations performed.} +#' } +#' +#' @details +#' The function performs the following tasks: +#' * Detects date and datetime fields from the REDCap dictionary (`date_*` and `datetime_*` validation types). +#' * Converts date fields to `Date` class. +#' * Converts datetime fields to `POSIXct` class, treating empty strings as `NA`. +#' +#' +#' @examples +#' result <- rd_dates(covican) +#' transformed_data <- result$data +#' +#' @export +#' @importFrom stats na.omit + +rd_dates <- function(project = NULL, data = NULL, dic = NULL, event_form = NULL) { + results <- NULL + + # Handle potential overwriting when both `project` and other arguments are provided + if (!is.null(project)) { + env_vars <- check_proj(project, data, dic, event_form) + + list2env(env_vars, envir = environment()) + } + + # Ensure both `data` and `dic` are provided; stop if either is missing + if (is.null(data) | is.null(dic)) { + stop("Both `data` and `dic` (data and dictionary) arguments must be provided.") + } + + # Extract labels from the data to reapply later + labels <- labels <- purrr::map_chr(data, function(x) { + lab <- attr(x, "label") + if (!is.null(lab)) { + lab + } else { + "" + } + }) + + # Identify date variables in the dictionary (those with `date_` in validation type) + var_date <- dic |> + dplyr::filter(grepl("^date_", .data$text_validation_type_or_show_slider_number)) |> + dplyr::pull(.data$field_name) + + var_date_valid <- data |> + dplyr::select(dplyr::all_of(var_date)) |> + purrr::keep(~ inherits(.x, "Date")) |> + names() + + # Identify datetime variables in the dictionary (those with `datetime_` in validation type) + var_datetime <- dic |> + dplyr::filter(grepl("^datetime_", .data$text_validation_type_or_show_slider_number)) |> + dplyr::pull(.data$field_name) + + var_datetime_valid <- data |> + dplyr::select(dplyr::all_of(var_datetime)) |> + purrr::keep(~ inherits(.x, "POSIXct")) |> + names() + + # Validation for Date/Datetime Formatting + if (identical(var_date, var_date_valid) & identical(var_datetime, var_datetime_valid)) { + warning("All date and datetime variables are already in the correct format. No transformation applied.", call. = FALSE) + } else { + var_date <- setdiff(var_date, var_date_valid) + + var_datetime <- setdiff(var_datetime, var_datetime_valid) + + # Convert date variables in the data to `Date` class + data <- data |> + dplyr::mutate_at(var_date, as.Date) |> + # Convert datetime variables to `POSIXct` class, handling empty strings as NA + dplyr::mutate_at(var_datetime, function(x) { + x <- dplyr::case_when(x == "" ~ NA, TRUE ~ x) + as.POSIXct(x, origin = "1970-01-01", tz = "UTC") + }) + } + + # Reapply variable labels to the data after transformation + data <- data |> + labelled::set_variable_labels(.labels = labels |> as.list(), .strict = FALSE) + + # Update results with the this transformation + if (is.null(results)) { + results <- c(results, stringr::str_glue("Transforming date and datetime fields. (rd_dates)\n")) + } else { + + if(grepl("^[A-Z]", results[1])) { + results[1] <- paste("1.", results[1]) + } + + last_val_res <- results |> + stringr::str_extract("^(\n)?\\d+\\.") |> + na.omit() |> + dplyr::last() |> + stringr::str_remove("\\.") |> + as.numeric() + + results <- c(results, stringr::str_glue("\n\n{last_val_res + 1}. Transforming date and datetime fields. (rd_dates)\n")) + } + + # Return the updated data, dictionary, event_form, and results (if present) + list( + data = data, + dictionary = dic, + event_form = event_form, + results = stringr::str_glue("{results}") + ) |> + purrr::compact() # Remove NULL elements from the list +} diff --git a/R/rd_delete_vars.R b/R/rd_delete_vars.R new file mode 100644 index 0000000..8c51beb --- /dev/null +++ b/R/rd_delete_vars.R @@ -0,0 +1,169 @@ +#' Delete Variables from REDCap Dataset and Dictionary +#' +#' @description +#' `r lifecycle::badge('experimental')` +#' +#' Deletes selected variables from a REDCap dataset and its dictionary, keeping them consistent and preserving variable labels. +#' +#' @param project A list containing the REDCap data, dictionary, and event mapping (expected `redcap_data()` output). Overrides `data`, `dic`, and `event_form`. +#' @param data A `data.frame` or `tibble` with the REDCap dataset. +#' @param dic A `data.frame` with the REDCap dictionary. +#' @param event_form Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects. +#' @param vars Optional. A character vector of variable names to remove from both the dataset and dictionary. +#' @param pattern Optional. A character vector of regular expression patterns. Variables matching these patterns will be removed from the dataset and dictionary. +#' +#' +#' @details +#' - Ensure that at least one of `vars` or `pattern` is specified. +#' - Removes specified variables and their factor versions (e.g., `variable.factor`) from the dataset. +#' - Removes matching variables from the dictionary. +#' - Warns about factor versions of variables matching patterns, recommending use of `rd_factor()` if necessary. +#' +#' @return A list containing: +#' \describe{ +#' \item{data}{The updated dataset with specified variables removed.} +#' \item{dictionary}{The updated REDCap dictionary.} +#' \item{event_form}{The original event-form mapping (if applicable).} +#' \item{results}{A summary message describing the variable removal operation.} +#' } +#' +#' @examples +#' # Delete specific variables by name +#' result <- rd_delete_vars( +#' project = covican, +#' vars = c("potassium", "leuk_lymph") +#' ) +#' +#' # Delete variables matching patterns +#' result <- rd_delete_vars( +#' data = covican$data, +#' dic = covican$dictionary, +#' pattern = c("_complete$", "_other$") +#' ) +#' +#' @export + +rd_delete_vars <- function(project = NULL, data = NULL, dic = NULL, event_form = NULL, vars = NULL, pattern = NULL) { + results <- NULL + + # Handle potential overwriting when both `project` and other arguments are provided + if (!is.null(project)) { + env_vars <- check_proj(project, data, dic, event_form) + list2env(env_vars, envir = environment()) + } + + # Ensure both `data` and `dic` are provided; stop if either is missing + if (is.null(data) | is.null(dic)) { + stop("Both `data` and `dic` (data and dictionary) arguments must be provided.", call. = FALSE) + } + + # Ensure one of the arguments is fullfilled + if (is.null(vars) & is.null(pattern)) { + stop("At least one of the 'vars' or 'pattern' arguments must be provided.", call. = FALSE) + } + + # Extract labels from the data to reapply later + labels <- purrr::map_chr(data, function(x) { + lab <- attr(x, "label") + if (!is.null(lab)) { + lab + } else { + "" + } + }) + + # If `vars` is specified, iterate through each variable and remove it from the data and dictionary + if (!is.null(vars)) { + vars_missing <- setdiff(vars, names(data)) + + if (length(vars_missing) > 0) { + stop(stringr::str_glue("The following variables are not present in the dataset: {paste0(vars_missing, collapse = ', ')}.\nPlease remove them from the `vars` argument."), call. = FALSE) + } + + for (i in seq_along(vars)) { + # Remove the variable from the dataset + data <- data |> + dplyr::select(!vars[i]) + + # Check if the factor version of the variable exists and remove it if present + if (paste0(vars[i], ".factor") %in% names(data)) { + data <- data |> + dplyr::select(!paste0(vars[i], ".factor")) + } + + # Remove the variable from the dictionary + dic <- dic |> + dplyr::filter(.data$field_name != vars[i]) + } + } + + + # If `pattern` is specified, use it to identify and remove matching variables + if (!is.null(pattern)) { + # Collapse patterns used + comb_pattern <- paste(pattern, collapse = "|") + + # Create factor versions of the patterns for additional checks + pattern_factor <- data |> + dplyr::select(grep(comb_pattern, names(data), value = TRUE)) |> + names() + + if (length(pattern_factor) > 0) { + pattern_factor <- ifelse( + endsWith(pattern_factor, ".factor"), + pattern_factor, + paste0(pattern_factor, ".factor") + ) + + vars_eliminated <- data |> + dplyr::select(!dplyr::matches(comb_pattern)) + + # Warn if factor versions of the variables matching the patterns are present in the dataset + if (any(pattern_factor %in% names(vars_eliminated)) & any(grepl("\\$", pattern))) { + warning("The dataset contains factor versions of variables matching the specified patterns. To properly remove them, use the `rd_factor` function first.", call. = FALSE) + } + } + + # Remove variables matching the pattern from the dataset + data <- data |> + dplyr::select(!dplyr::matches(comb_pattern)) + + # Remove variables matching the pattern from the dictionary + dic <- dic |> + dplyr::filter(!grepl(comb_pattern, .data$field_name)) + } + + # Reapply variable labels to the dataset after modifications + data <- data |> + labelled::set_variable_labels( + .labels = labels |> as.list(), .strict = FALSE + ) + + # Update results with the this transformation + if (is.null(results)) { + results <- c(results, stringr::str_glue("Removing selected variables (rd_delete_vars)\n")) + } else { + + if(grepl("^[A-Z]", results[1])) { + results[1] <- paste("1.", results[1]) + } + + last_val_res <- results |> + stringr::str_extract("^(\n)?\\d+\\.") |> + na.omit() |> + dplyr::last() |> + stringr::str_remove("\\.") |> + as.numeric() + + results <- c(results, stringr::str_glue("\n\n{last_val_res + 1}. Removing selected variables (rd_delete_vars)\n")) + } + + # Return the updated dataset, dictionary, event_form, and results + list( + data = data, + dictionary = dic, + event_form = event_form, + results = stringr::str_glue("{results}") + ) |> + purrr::compact() # Remove any NULL elements from the output list +} diff --git a/R/rd_dictionary.R b/R/rd_dictionary.R new file mode 100644 index 0000000..c234303 --- /dev/null +++ b/R/rd_dictionary.R @@ -0,0 +1,245 @@ +#' Transform the data dictionary and handle branching logic +#' +#' @description +#' `r lifecycle::badge('experimental')` +#' +#' Updates a REDCap data dictionary by converting branching logic and calculation expressions into valid R expressions. This ensures that conditional display rules and calculated fields in the dictionary can be programmatically evaluated with the dataset. Any variables that cannot be converted are reported in the results. +#' +#' @param project A list containing the REDCap data, dictionary, and event mapping (expected `redcap_data()` output). Overrides `data`, `dic`, and `event_form`. +#' @param data A `data.frame` or `tibble` with the REDCap dataset. +#' @param dic A `data.frame` with the REDCap dictionary. +#' @param event_form Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects. +#' +#' @return A list with the following elements: +#' \describe{ +#' \item{data}{The original dataset passed to the function.} +#' \item{dictionary}{The updated data dictionary with modified branching logic and calculations.} +#' \item{event_form}{The original event-form mapping (if applicable).} +#' \item{results}{A summary of the transformations, including any variables with unconverted branching logic.} +#' } +#' +#' @details +#' The function performs the following tasks: +#' * Evaluates and transforms branching logic expressions into valid R expressions using `rd_rlogic`. +#' * Evaluates and converts calculation expressions for fields of type `calc`. +#' * Generates a results summary table listing any variables that could not be converted. +#' +#' @examples +#' \dontrun{ +#' result <- rd_dictionary(covican) +#' print(result$results) +#' updated_dic <- result$dictionary +#' } +#' +#' @export +#' @importFrom stats setNames na.omit + + +rd_dictionary <- function(project = NULL, data = NULL, dic = NULL, event_form = NULL) { + + results <- NULL + + # Handle potential overwriting when both `project` and other arguments are provided + if (!is.null(project)) { + env_vars <- check_proj(project, data, dic, event_form) + + list2env(env_vars, envir = environment()) + } + + # Ensure both `data` and `dic` are provided; stop if either is missing + if (is.null(data) | is.null(dic)) { + stop("Both `data` and `dic` (data and dictionary) arguments must be provided.") + } + + # Checking if there was already a transformation of the original variables into factors + factors <- data |> + dplyr::select(dplyr::any_of(dic$field_name) & dplyr::where(is.factor)) |> + colnames() + + if (length(factors) > 0) { + # Select the branching logic for any variables that are being transformed into factors + cat_factors <- dic |> + dplyr::select("field_name", "choices_calculations_or_slider_labels") |> + dplyr::filter(.data$field_name %in% factors) + + # Split the `choices_calculations_or_slider_labels` to separate each option in a multi-option field + cat_factors <- cat_factors |> + dplyr::mutate( + choices_calculations_or_slider_labels = strsplit(.data$choices_calculations_or_slider_labels, "\\|") + ) |> + tidyr::unnest("choices_calculations_or_slider_labels") + + # Separate numeric and category labels from the choices string + cat_factors <- cat_factors |> + tidyr::separate(.data$choices_calculations_or_slider_labels, + into = c("num", "cat"), + sep = ", ", + extra = "merge" + ) |> + dplyr::filter(.data$cat != "") |> + dplyr::mutate( + num = stringr::str_trim(.data$num), + cat = stringr::str_trim(.data$cat) + ) + + # Transform each branching logic into R logic + cat_factors <- cat_factors |> + dplyr::mutate( + redcap_v1 = paste0("\\[", .data$field_name, "\\] ?=? ?'?", .data$num, "'?"), + redcap_v2 = paste0("\\[", .data$field_name, "\\] ?? ?'?", .data$num, "'?"), + factor_v1 = paste0("[", .data$field_name, "]='", .data$cat, "'"), + factor_v2 = paste0("[", .data$field_name, "]<>'", .data$cat, "'") + ) |> + dplyr::arrange(.data$field_name, dplyr::desc(.data$num)) + + # Create a mapping for replacing the branching logic in the dictionary + replace_v1 <- setNames(cat_factors$factor_v1, cat_factors$redcap_v1) + replace_v2 <- setNames(cat_factors$factor_v2, cat_factors$redcap_v2) + + # Apply the replacements to the dictionary + dic <- dic |> + dplyr::mutate( + branching_logic_show_field_only_if = stringr::str_replace_all(.data$branching_logic_show_field_only_if, replace_v1), + branching_logic_show_field_only_if = stringr::str_replace_all(.data$branching_logic_show_field_only_if, replace_v2), + choices_calculations_or_slider_labels = stringr::str_replace_all(.data$choices_calculations_or_slider_labels, replace_v1), + choices_calculations_or_slider_labels = stringr::str_replace_all(.data$choices_calculations_or_slider_labels, replace_v2) + ) + } + + logics <- NULL + # Generate the object that will contain the warnings + warnings_env <- new.env(parent = emptyenv()) + warnings_env$count <- 0 + warnings_env$msgs <- character() + warnings_env$id <- numeric() + + # Starting time + start_time <- Sys.time() + + # Identify rows in the dictionary with branching logic that needs evaluation + pos_branch <- which(!dic$branching_logic_show_field_only_if %in% "") + + # Loop through each row with branching logic + for (i in pos_branch) { + # Attempt to evaluate and convert the branching logic using `rd_rlogic` + evaluation <- withCallingHandlers( + { + try( + rd_rlogic( + data = data, + dic = dic, + event_form = event_form, + logic = dic$branching_logic_show_field_only_if[i], + var = dic$field_name[i] + )$rlogic, + silent = TRUE + ) + }, + warning = function(w) { + warnings_env$count <- warnings_env$count + 1 + warnings_env$msgs <- c(warnings_env$msgs, conditionMessage(w)) + invokeRestart("muffleWarning") + } + ) + + # If evaluation succeeds, update the dictionary with the converted logic + if (!inherits(evaluation, "try-error")) { + dic$branching_logic_show_field_only_if[i] <- evaluation + } else { + # If evaluation fails, add the variable name to the `logics` object + logics <- rbind(logics, dic$field_name[i]) + } + } + + # Warning with almost done + elapsed <- as.numeric(Sys.time() - start_time, units = "secs") + + if (elapsed > 10) { + message("\u23F3 Almost done!") + } + + # Identify rows in the dictionary with calculations that need evaluation + pos_calc <- which(dic$field_type == "calc") + + # Loop through each row with calculations + for (i in pos_calc) { + # Attempt to evaluate and convert the calculations using `rd_rlogic` + evaluation <- withCallingHandlers( + { + try( + rd_rlogic( + data = data, + dic = dic, + event_form = event_form, + logic = dic$choices_calculations_or_slider_labels[i], + var = dic$field_name[i] + )$rlogic, + silent = TRUE + ) + }, + warning = function(w) { + warnings_env$count <- warnings_env$count + 1 + warnings_env$msgs <- c(warnings_env$msgs, conditionMessage(w)) + warnings_env$id <- c(warnings_env$id, i) + invokeRestart("muffleWarning") + } + ) + + # If evaluation succeeds, update the dictionary with the converted logic + if (!inherits(evaluation, "try-error")) { + dic$choices_calculations_or_slider_labels[i] <- evaluation + } else { + # If evaluation fails, add the variable name to the `logics` object + logics <- rbind(logics, dic$field_name[i]) + } + } + + # Update results with the this transformation + if (is.null(results)) { + results <- c(results, stringr::str_glue("Converting every branching logic in the dictionary into R logic. (rd_dictionary)\n")) + } else { + + if(grepl("^[A-Z]", results[1])) { + results[1] <- paste("1.", results[1]) + } + + last_val_res <- results |> + stringr::str_extract("^(\n)?\\d+\\.") |> + na.omit() |> + dplyr::last() |> + stringr::str_remove("\\.") |> + as.numeric() + + results <- c(results, stringr::str_glue("\n\n{last_val_res + 1}. Converting every branching logic in the dictionary into R logic. (rd_dictionary)\n")) + } + + # If there are variables with unconverted logic, prepare a report + if (!is.null(logics)) { + # Make sure there are unique variables to review + logics <- unique(logics) + + # Create a table of unconverted variables + tabla <- tibble::tibble("Variables" = logics) + + # Append the table to the `results` for later reporting + results <- c(results, "\n", knitr::kable(tabla, "pipe", align = c("ccc"), caption = "Variables with unconverted branching logic")) + } + + # Generating a global warning if one of the iteractions of the loop generates a warning inside rd_rlogic + if (warnings_env$count > 0) { + warnings_env$msgs <- warnings_env$msgs |> unique() + + for (i in warnings_env$msgs) { + warning(i, call. = FALSE) + } + } + + # Return the processed objects + list( + data = data, + dictionary = dic, + event_form = event_form, + results = stringr::str_glue("{results}") + ) |> + purrr::compact() # Remove any NULL elements from the output list +} diff --git a/R/rd_event.R b/R/rd_event.R index edfaf0e..bf99944 100644 --- a/R/rd_event.R +++ b/R/rd_event.R @@ -1,303 +1,356 @@ -#' Identification of Missing Event(s) +#' Identify Missing Events in REDCap Data #' -#' When working with a longitudinal REDCap project, the exported data has a structure where each row represents one event per record. However, by default REDCap does not export events for which there is no information available. -#' This function allows you to identify which records do not contain information about a particular event. +#' @description +#' `r lifecycle::badge('stable')` +#' +#' Helps identify records in a REDCap longitudinal project that are missing one or more specified events. Because REDCap typically omits empty events from exports, an event that contains no data for a record will not appear. This function finds those absent events and returns a per-record query table and a summarized HTML report. +#' +#' @param project A list containing the REDCap data, dictionary, and event mapping (expected `redcap_data()` output). Overrides `data`, `dic`, and `event_form`. +#' @param data A `data.frame` or `tibble` with the REDCap dataset. +#' @param dic A `data.frame` with the REDCap dictionary. +#' @param event_form Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects. +#' @param event Character vector with one or more REDCap event names to check for missing records. +#' @param filter Optional. A single character string containing a filter expression to subset the dataset before checking for missing events. Example: \code{"age >= 18"}. +#' @param query_name Optional character vector describing each query. Defaults to a standard format: `The event (event_name) is missing`. +#' @param addTo Optional data frame from a previous query report to which the new results can be appended. +#' @param report_title Optional string specifying the title of the final report. Defaults to `"Report of queries"`. +#' @param report_zeros Logical, include variables with zero queries in the report. Default is `FALSE`. +#' @param link Optional list containing project information (`domain`, `redcap_version`, `proj_id`, `event_id`) to generate clickable links for each query. +#' +#' +#' @return A named list with two elements: +#' \describe{ +#' \item{\code{queries}}{A data frame listing records missing the specified events. +#' Columns: \code{Identifier}, \code{DAG}, \code{Event}, \code{Instrument}, +#' \code{Field}, \code{Repetition}, \code{Description}, \code{Query}, \code{Code}, +#' and optionally \code{Link}. If no queries are found this will be an empty +#' data frame with the expected columns.} +#' \item{\code{results}}{An HTML table (knitr::kable styled with kableExtra) summarising +#' the number of missing records per event. Returned as \code{knitr::kable} (HTML).} +#' } #' -#' @param ... List containing the data, dictionary and event mapping (if required) of the REDCap project. This should be the output of the `redcap_data` function. -#' @param data Data frame containing the data read from REDCap. If the list is specified, this argument is not required. -#' @param dic Data frame containing the dictionary read from REDCap. If the list is specified, this argument is not required. -#' @param event Character vector with the name of the REDCap event(s) to be analyzed. -#' @param filter A filter to be applied to the dataset. This argument can be used to identify the missing events on a subset of the dataset. -#' @param query_name Description of the query. It can be the same for all variables, or you can define a different one for each variable. By default, the function defines it as `The event [event] is missing' for each event`. -#' @param addTo Data frame corresponding to a previous query data frame to which you can add the new query data frame. By default, the function always generates a new data frame without taking into account previous reports. -#' @param report_title Character string specifying the title of the report. -#' @param report_zeros Logical. If `TRUE`, the function returns a report containing variables with zero queries. -#' @param link List of project information used to create a web link for each missing event. -#' @return A list with a data frame of 9 columns (10 columns if the link argument is specified) to help the user identify each missing event and a table with the total number of missing events per event analyzed. #' #' @examples -#' example <- rd_event(covican, -#' event = "follow_up_visit_da_arm_1") -#' example +#' # Minimal reproducible example +#' data0 <- data.frame( +#' record_id = c("100-1", "100-2", "200-1"), +#' redcap_event_name = c("baseline_arm_1", "baseline_arm_1", "follow_up_arm_1"), +#' redcap_event_name.factor = factor(c("Baseline", "Baseline", "Follow-up")), +#' stringsAsFactors = FALSE +#' ) +#' +#' # Suppose we want to check that every record has the follow-up event +#' res <- rd_event( +#' data = data0, +#' dic = data.frame(), # placeholder dictionary +#' event = "follow_up_arm_1", +#' report_zeros = TRUE +#' ) +#' +#' # Records missing the event: +#' res$queries +#' +#' # HTML summary (in RMarkdown or Viewer) +#' res$results +#' #' @export #' @importFrom rlang .data -rd_event <- function(..., data = NULL, dic = NULL, event, filter = NA, query_name = NA, addTo = NA, report_title = NA, report_zeros = FALSE, link = list()) - { - # If the entire list resulting from the 'redcap_data' function is used - project <- c(...) - - if(!is.null(project)){ +rd_event <- function(project = NULL, + data = NULL, + dic = NULL, + event_form = NULL, + event, + filter = NA, + query_name = NA, + addTo = NA, + report_title = NA, + report_zeros = FALSE, + link = list()) { + + # Handle potential overwriting when both `project` and other arguments are provided + if (!is.null(project)) { + env_vars <- check_proj(project, data, dic, event_form) + + list2env(env_vars, envir = environment()) + } - if (!is.null(data)) { + # Ensure both `data` and `dic` are provided; stop if either is missing + if (is.null(data) | is.null(dic)) { + stop("Both `data` and `dic` (data and dictionary) arguments must be provided.") + } - warning("Data has been specified twice so the function will not use the information in the data argument.") + # Ensure the input data is a data frame + data <- as.data.frame(data) - } + # Create an empty data frame to store identified queries + queries <- as.data.frame(matrix(ncol = 10, nrow = 0)) + colnames(queries) <- c("Identifier", "DAG", "Event", "Instrument", "Field", "Repetition", "Description", "Query", "Code", "Link") - if (!is.null(dic)) { - - warning("Dictionary has been specified twice so the function will not use the information in the dic argument.") + # Rename the first column to "record_id" if necessary + if ("record_id" %in% names(data)) { + names(data)[1] <- "record_id" + } - } + # Error: Stop if more than one filter is provided + if (!is.na(filter) & length(filter) > 1) { + stop("More than one filter applied, please select only one.", call. = FALSE) + } - data <- project$data - dic <- project$dictionary - } + # Save the original dataset for reference + data0 <- data - # Making sure that the object data is a data.frame - data <- as.data.frame(data) + # Apply the filter expression to the dataset if provided + if (!is.na(filter) & length(filter) == 1) { + command <- paste0("data", "<-dplyr::filter(data,", filter, ")") - # Creation of the structure of the queries - queries <- as.data.frame(matrix(ncol = 10, nrow = 0)) - colnames(queries) <- c("Identifier", "DAG", "Event", "Instrument", "Field", "Repetition", "Description", "Query", "Code", "Link") + # Test the validity of the filter logic + evaluation <- try(eval(parse(text = command)), silent = TRUE) - # Naming the first column of the REDCap's database as record_id - if (all(!names(data) == "record_id")) { - names(data)[1] <- "record_id" + if (inherits(evaluation, "try-error")) { + stop("Invalid `filter` argument logic. Please review and correct the expression.", call. = FALSE) + } else { + eval(parse(text = command)) } - # Error: More than one filter applied. - if (!is.na(filter) & length(filter) > 1) { - stop("More than one filter applied, please select only one.", call. = FALSE) + # Warn if the filter results in no observations + if (nrow(data) == 0) { + warning("The filter applied does not match any records. Please review the `filter` argument.", call. = FALSE) } + } - # We save de original dataset - data0 <- data - - # Filtering the data using the information of the argument 'filter' - if (!is.na(filter) & length(filter) == 1) { - - # Error: logic used in the filter is incorrect - command <- paste0("data", "<-dplyr::filter(data,", filter, ")") - - evaluation <- try(eval(parse(text = command)), silent = TRUE) - - if(inherits(evaluation, "try-error")){ - - stop("The logic used in the filter is incorrect. Please review and adjust the filter's logic.") - - } else { - - eval(parse(text = command)) - - } - - # Error: filtering results in zero observations - if (nrow(data) == 0) { - warning("The applied filter is accurate, but it does not correspond to any observations. Please ensure that you have selected the appropriate filter.", call. = FALSE) + # Validate that the specified events are present in the dataset + if (all(!is.na(event))) { + if (any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data0))) { + if (any(!event %in% data0$redcap_event_name) & any(!event %in% data0$redcap_event_name.factor)) { + stop("One or more specified events do not exist in the dataset. Please review the 'event' argument.", call. = FALSE) } - } - # Applying a filter of the chosen events to the database - if (all(!is.na(event))) { + # Iterate over each specified event to identify missing records + for (k in seq_along(event)) { + # Find record IDs associated with the current event (factor form) + if (any(names(data0) == "redcap_event_name.factor") & all(event %in% data0$redcap_event_name.factor)) { + ids <- data0$record_id[data0$redcap_event_name.factor %in% event[k]] + } - # Error: one of the specified events does not exist in the database - if (any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data0))) { - if (any(!event %in% data0$redcap_event_name) & any(!event %in% data0$redcap_event_name.factor)) { - stop("One of the events mentioned does not exist in the database, please verify the argument 'event'.") - } + # Find record IDs associated with the current event (raw form) + if (all(event %in% data0$redcap_event_name)) { + ids <- data0$record_id[data0$redcap_event_name %in% event[k]] } - # Identify queries for each event - for (k in 1:length(event)) { - # If the event is specified in the factor form - if (any(names(data0) == "redcap_event_name.factor") & all(event %in% data0$redcap_event_name.factor)) { - ids <- data0$record_id[data0$redcap_event_name.factor %in% event[k]] - } + # Identify records missing the current event + raw <- data |> + dplyr::filter(!data$record_id %in% ids) |> + dplyr::slice(rep(1:dplyr::n(), each = length(event[k]))) - # If the event is specified in the raw form - if (all(event %in% data0$redcap_event_name)) { - ids <- data0$record_id[data0$redcap_event_name %in% event[k]] + # If missing records are found, create query entries for them + if (nrow(raw) > 0) { + # Assign the current event name to the missing records - raw version + if ("redcap_event_name" %in% names(raw)) { + raw$redcap_event_name <- rep(event[k], length(event[k])) } - - # Identification of the record_ids that do not present the events specified - raw <- data %>% - dplyr::filter(!data$record_id %in% ids) - raw <- raw %>% - dplyr::slice(rep(1:dplyr::n(), each = length(event[k]))) - - # Identification of queries, using the structure built before - if (nrow(raw) > 0) { - - # Retrieve the names of the missing events - raw version - if ("redcap_event_name" %in% names(raw)) { - raw$redcap_event_name <- rep(event[k], length(event[k])) - } - - # Retrieve the names of the missing events - factor version - if ("redcap_event_name.factor" %in% names(raw)) { - for (i in 1:nrow(raw)) { - - raw$redcap_event_name.factor[i] <- unique(data0$redcap_event_name.factor[data0$redcap_event_name %in% raw$redcap_event_name[i]]) - - } + # Assign the current event name to the missing records - factor version + if ("redcap_event_name.factor" %in% names(raw)) { + for (i in seq_len(nrow(raw))) { + raw$redcap_event_name.factor[i] <- unique(data0$redcap_event_name.factor[data0$redcap_event_name %in% raw$redcap_event_name[i]]) } + } - # Queries - x <- raw[, c("record_id", grep("redcap", names(raw), value = T))] - excel <- data.frame( - Identifier = x[, "record_id"], - DAG = if (any(c("redcap_data_access_group", "redcap_data_access_group.factor") %in% names(x))) { - ifelse("redcap_data_access_group.factor" %in% names(x), - as.character(x[, "redcap_data_access_group.factor"]), - as.character(x[, "redcap_data_access_group"])) - } else { - "-" - }, - Event = rep(event[k], length(event[k])), - Instrument = "-", - Field = "-", - Repetition = "-", - Description = if ("redcap_event_name.factor" %in% names(x)) { - as.character(x[, "redcap_event_name.factor"]) - } else{ - "-" - }, - Query = if (!is.na(query_name)) { - if (length(query_name) > 1) { - query_name[k] - } else { - query_name - } + # Queries + x <- raw[, c("record_id", grep("redcap", names(raw), value = TRUE))] + excel <- data.frame( + Identifier = x[, "record_id"], + DAG = if (any(c("redcap_data_access_group", "redcap_data_access_group.factor") %in% names(x))) { + ifelse("redcap_data_access_group.factor" %in% names(x), + as.character(x[, "redcap_data_access_group.factor"]), + as.character(x[, "redcap_data_access_group"]) + ) + } else { + "-" + }, + Event = rep(event[k], length(event[k])), + Instrument = "-", + Field = "-", + Repetition = "-", + Description = if ("redcap_event_name.factor" %in% names(x)) { + as.character(x[, "redcap_event_name.factor"]) + } else { + "-" + }, + Query = if (!is.na(query_name)) { + if (length(query_name) > 1) { + query_name[k] } else { - paste0("The event '", if ("redcap_event_name.factor" %in% names(x)) { + query_name + } + } else { + paste0( + "The event '", if ("redcap_event_name.factor" %in% names(x)) { as.character(x[, "redcap_event_name.factor"]) } else { as.character(x[, "redcap_event_name"]) - } - , "' is missing.") - }, - Code = "", - stringsAsFactors = FALSE - ) - - # Add the column Link - if (all(c("domain", "redcap_version", "proj_id") %in% names(link))) { - excel[, "Link"] <- paste0("https://", link[["domain"]], "/redcap_v", link[["redcap_version"]], "/DataEntry/record_home.php?pid=", link[["proj_id"]], "&id=", x[, "record_id"]) - } - - # Add the identified queries to the structure - queries <- rbind(queries, excel) + }, + "' is missing." + ) + }, + Code = "", + stringsAsFactors = FALSE + ) + + # Add a hyperlink for the query if link information is provided + if (all(c("domain", "redcap_version", "proj_id") %in% names(link))) { + excel[, "Link"] <- paste0("https://", link[["domain"]], "/redcap_v", link[["redcap_version"]], "/DataEntry/record_home.php?pid=", link[["proj_id"]], "&id=", x[, "record_id"]) } - } - } - - # If the argument 'addTo' is specified, combine the queries generated with a previous data frame of queries - if (!is.na(addTo)) { - col_names <- names(queries) - queries <- merge(queries, - addTo$queries, - by = intersect(names(addTo$queries), names(queries)), - all = TRUE) - queries <- queries %>% dplyr::select(col_names) - } - # Classify each query with it's own code - if (nrow(queries) != 0) { - - # First we sort the data frame by record_id - if (all(grepl("-", queries$Identifier))) { - queries <- queries %>% - tidyr::separate("Identifier", c("center", "id"), sep = "([-])", remove = FALSE) - queries[, "center"] <- as.numeric(queries[, "center"]) - queries[, "id"] <- as.numeric(queries[, "id"]) - queries <- queries[order(queries[, "center"], queries[, "id"]), ] - rownames(queries) <- NULL - queries <- queries %>% dplyr::select(-"center", -"id") - } else { - queries$Identifier <- as.numeric(queries$Identifier) - queries <- queries[order(queries$Identifier), ] + # Append the query to the list of identified queries + queries <- rbind(queries, excel) } + } + } - # Add the code to each query and eliminate duplicated ones - queries <- unique(queries %>% - dplyr::select(-"Code")) - queries <- data.frame(queries %>% - dplyr::group_by(.data$Identifier) %>% - dplyr::mutate(cod = 1:dplyr::n())) - queries$Code <- paste0(as.character(queries$Identifier), "-", queries$cod) - queries <- queries %>% dplyr::select(-"cod") - - # Reorder the columns if the link argument was specified - if ("Link" %in% names(queries)) { - queries <- queries %>% - dplyr::select("Identifier":"Query", "Code", "Link") - } + # Merge with an existing query data frame if specified in 'addTo' + if (!is.na(addTo)) { + # Save the column names of the existing queries + col_names <- names(queries) + + # Merge the existing queries with the new ones + queries <- merge(queries, + addTo$queries, + by = intersect(names(addTo$queries), names(queries)), + all = TRUE + ) + + # Reorder the columns to match the original structure + queries <- queries |> + dplyr::select(dplyr::all_of(col_names)) + } - # Build the report - report <- data.frame("var" = queries$Event, - "descr" = queries$Description) + # Classify each query with a unique code if there are queries present + if (nrow(queries) != 0) { + # Handle cases where the Identifier contains a center and id separated by a dash + if (all(grepl("-", queries$Identifier))) { + # Separate the Identifier into center and id components + queries <- queries |> + tidyr::separate("Identifier", c("center", "id"), sep = "([-])", remove = FALSE) - # If there is no previous report specified we convert the events and their description to factors using the dictionary - if (all(addTo %in% NA)) { - report$var <- factor(report$var, levels = c(unique(event))) - report$descr <- factor(report$descr) - } + # Convert center and id to numeric for sorting + queries[, "center"] <- as.numeric(queries[, "center"]) + queries[, "id"] <- as.numeric(queries[, "id"]) - # Report of all variables (including the ones with zero queries) - if (report_zeros == TRUE) { - report <- report %>% - dplyr::group_by(.data$var, .drop = FALSE) %>% - dplyr::summarise("total" = dplyr::n()) - } else { - report <- report %>% - dplyr::group_by(.data$var, .drop = TRUE) %>% - dplyr::summarise("total" = dplyr::n()) - } + # Sort queries by center and id + queries <- queries[order(queries[, "center"], queries[, "id"]), ] + # Reset row names and remove temporary columns + rownames(queries) <- NULL + queries <- queries |> dplyr::select(-"center", -"id") } else { - # If there is none query, the function still creates a report containing all selected variables. + # If Identifier doesn't contain a dash, sort numerically by Identifier + queries$Identifier <- as.numeric(queries$Identifier) + queries <- queries[order(queries$Identifier), ] + } - # Message: if there is none query to be identified - message("There is no query to be identified.") + # Remove duplicate queries and ensure only unique rows are retained + queries <- queries |> + dplyr::select(-"Code") |> + unique() + + # Assign a unique code to each query based on Identifier + queries <- data.frame(queries |> + dplyr::group_by(.data$Identifier) |> + dplyr::mutate(cod = 1:dplyr::n())) + queries$Code <- paste0(as.character(queries$Identifier), "-", queries$cod) + queries <- queries |> dplyr::select(-"cod") + + # Reorder columns if the 'Link' argument is specified + if ("Link" %in% names(queries)) { + queries <- queries |> + dplyr::select("Identifier":"Query", "Code", "Link") + } - report <- as.data.frame(matrix(ncol = 2, nrow = length(event))) - colnames(report) <- c("var", "descr") + # Create a summary report of the queries + report <- data.frame( + "var" = queries$Event, + "descr" = queries$Description + ) - report$var <- event - report$descr <- if ("redcap_event_name.factor" %in% names(data)) { - as.character(unique(data0$redcap_event_name.factor[which(data0$redcap_event_name %in% event)])) - } else{ - "-" - } - report$total <- 0 + # If no previous report exists, set events and descriptions as factors using the dictionary + if (all(addTo %in% NA)) { + report$var <- factor(report$var, levels = c(unique(event))) + report$descr <- factor(report$descr) + } + # Include all variables in the report, with or without zero queries, based on 'report_zeros' + if (report_zeros == TRUE) { + report <- report |> + dplyr::group_by(.data$var, .drop = FALSE) |> + dplyr::summarise("total" = dplyr::n()) + } else { + report <- report |> + dplyr::group_by(.data$var, .drop = TRUE) |> + dplyr::summarise("total" = dplyr::n()) } + } else { + # Handle cases where there are no queries + + # Notify the user that no queries were identified + message("No queries identified.") - # We check if there is more than one report_title and if it isn't the case we stabilish the caption for the report_title - if (all(is.na(report_title))) { - report_title <- "Report of queries" + # Create an empty report with placeholders for events + report <- as.data.frame(matrix(ncol = 2, nrow = length(event))) + colnames(report) <- c("var", "descr") + + # Populate the report with event names and placeholders for descriptions + report$var <- event + report$descr <- if ("redcap_event_name.factor" %in% names(data)) { + as.character(unique(data0$redcap_event_name.factor[which(data0$redcap_event_name %in% event)])) } else { - if (length(report_title) > 1) { - stop("There is more than one title for the report, please choose only one.", call. = FALSE) - } + "-" } - # Arrange report - report <- report %>% - dplyr::mutate(descr = unique(data0$redcap_event_name.factor[data0$redcap_event_name %in% report$var])) %>% - dplyr::select("var", "descr", "total") %>% - dplyr::arrange(dplyr::desc(.data$total)) - names(report) <- c("Events", "Description", "Total") - rownames(report) <- NULL - - # Viewer - result <- knitr::kable(report, - align = c("ccccc"), - row.names = FALSE, - caption = report_title, - format = "html", - longtable = TRUE) - result <- kableExtra::kable_styling(result, - bootstrap_options = c("striped", "condensed"), - full_width = FALSE) - result <- kableExtra::row_spec(result, 0, italic = FALSE, extra_css = "border-bottom: 1px solid grey") - - # Return the final product - list(queries = queries, - results = result) + # Set total queries for each event to zero + report$total <- 0 } + + # Set the report title or validate the provided title + if (all(is.na(report_title))) { + report_title <- "Report of queries" + } else { + # Ensure only one report title is provided + if (length(report_title) > 1) { + stop("Multiple titles provided for the report. Please specify only one..", call. = FALSE) + } + } + + # Finalize and arrange the report for output + report <- report |> + dplyr::mutate(descr = unique(data0$redcap_event_name.factor[data0$redcap_event_name %in% report$var])) |> + dplyr::select("var", "descr", "total") |> + dplyr::arrange(dplyr::desc(.data$total)) + + # Rename columns for the final report + names(report) <- c("Events", "Description", "Total") + rownames(report) <- NULL + + # Generate an HTML table for the report + result <- knitr::kable(report, + align = c("ccccc"), + row.names = FALSE, + caption = report_title, + format = "html", + longtable = TRUE + ) + result <- kableExtra::kable_styling(result, + bootstrap_options = c("striped", "condensed"), + full_width = FALSE + ) + result <- kableExtra::row_spec(result, 0, italic = FALSE, extra_css = "border-bottom: 1px solid grey") + + # Return the queries and the formatted report + list( + queries = queries, + results = result + ) +} diff --git a/R/rd_export.R b/R/rd_export.R index 824ba7e..15bc41a 100644 --- a/R/rd_export.R +++ b/R/rd_export.R @@ -1,44 +1,53 @@ -#' Exporting Query Dataset +#' Export Queries to an Excel File #' -#' This function exports a query report, generated using the `rd_query` or `rd_event` functions, to an .xlsx file. +#' @description +#' `r lifecycle::badge('experimental')` #' -#' @param ... List containing the data frame of queries. This list must be the output of the `rd_query` or `rd_event` functions. -#' @param queries Data frame containing the identified queries. If the list is specified, this argument is not required. -#' @param column Character element specifying the column containing the link for each query. -#' @param sheet_name Character element specifying the sheet name of the resulting xlsx file. -#' @param path Character element specifying the file path to save the xlsx file. If `NULL`, the file will be created in the current working directory. -#' @param password String with the password to protect the worksheet and prevent others from making changes. -#' @return An .xlsx file containing all the queries and, if available, hyperlinks to each of them. +#' Export a query dataset (e.g., from `rd_query` or `rd_event`) to an `.xlsx` file. The function can optionally convert a column of URLs into Excel hyperlinks and apply password protection to the worksheet. +#' +#' @param project A list containing the dataframe of queries and results (expected `rd_query` or `rd_event` output). Overrides `queries`. +#' @param queries A data frame of identified queries. +#' @param column Name of the column containing URLs to convert into hyperlinks. If `NULL`, hyperlinks are added only if a `Link` column exists. +#' @param sheet_name Name of the Excel sheet in the resulting `.xlsx` file. Default: `"Sheet1"`. +#' @param path File path for saving the `.xlsx` file. If `NULL`, the file is saved as `"example.xlsx"` in the working directory. +#' @param password Optional password to protect the worksheet from edits. +#' +#' @return An `.xlsx` file written to the specified path. +#' +#' @examples +#' \dontrun{ +#' rd_export( +#' queries = my_queries, +#' column = "Link", +#' sheet_name = "My Queries", +#' path = "queries.xlsx" +#' ) +#' } #' #' @export -rd_export <- function(..., queries = NULL, column = NULL, sheet_name = NULL, path = NULL, password = NULL) -{ - # If the entire list resulting from the 'redcap_data' function is used - project <- c(...) - if(!is.null(project)){ - if(!is.null(queries)){ - - warning("Queries have been specified twice so the function will not use the information in the queries argument.") +rd_export <- function(project = NULL, queries = NULL, column = NULL, sheet_name = NULL, path = NULL, password = NULL) { + # Handle potential overwriting when both `project` and other arguments are provided + if (!is.null(project)) { + if (!is.null(queries)) { + warning("Queries has been provided twice. The function will ignore the `queries` argument.") } queries <- project$queries } - # Making sure that the object data is a data.frame + # Ensure `queries` is a data frame queries <- as.data.frame(queries) # Warning: links detected but the column argument is not specified. - if (is.null(column) & !"Link" %in% names(queries) & any(queries %>% dplyr::summarise_all(~ any(grepl("https", .))))) { - - warning("A column containing links was detected. If you want to convert them into hyperlinks, please specify the column argument.", call. = F) - + if (is.null(column) & !"Link" %in% names(queries) & any(queries |> dplyr::summarise_all(~ any(grepl("https", .))))) { + warning("Links were detected in the dataset. To convert them into hyperlinks in the Excel file, specify the `column` argument.", call. = FALSE) } # Create a new workbook wb <- openxlsx::createWorkbook() - # Add a new worksheet to the workbook + # Set the worksheet name sheet_name <- if (!is.null(sheet_name)) { sheet_name } else { @@ -46,59 +55,67 @@ rd_export <- function(..., queries = NULL, column = NULL, sheet_name = NULL, pat } sheet <- openxlsx::addWorksheet(wb, sheet_name) - # Converting the links into hyperlinks + # Handle hyperlink conversion if a column is specified or `Link` is present if (!is.null(column) | "Link" %in% names(queries)) { - - # Stabilish the column name + # Determine the column name column <- if (!is.null(column)) { if (column %in% names(queries)) { column } else { - - # Error: the named column is not present in the dataset - stop("The column you have specified does not exist in the dataset.", call. = F) - + # Error: Stop execution if the specified column doesn't exist + stop("The specified column for hyperlinks does not exist in the dataset. Please review the `column` argument.", call. = FALSE) } } else { "Link" } - # Add hyperlinks to a cell + # Mark the column as hyperlinks class(queries[, column]) <- "hyperlink" - } - # Write the data frame to the worksheet - openxlsx::writeDataTable(wb = wb, sheet = sheet, x = queries, startRow = 1, startCol = 1, rowNames = F, tableStyle = "TableStyleLight11") - - # Align cells to the center - openxlsx::addStyle(wb = wb, sheet = sheet, style = openxlsx::createStyle(halign = "CENTER"), rows = 1:(nrow(queries) + 1), cols = 1:length(queries), gridExpand = T) - - # Cell widths - openxlsx::setColWidths(wb = wb, sheet = sheet, cols = 1:length(queries), widths = "auto") - - # Path to the file + # Write data to the worksheet + openxlsx::writeDataTable( + wb = wb, + sheet = sheet, + x = queries, + startRow = 1, + startCol = 1, + rowNames = FALSE, + tableStyle = "TableStyleLight11" + ) + + # Center-align cells + openxlsx::addStyle( + wb = wb, + sheet = sheet, + style = openxlsx::createStyle(halign = "CENTER"), + rows = 1:(nrow(queries) + 1), + cols = seq_along(queries), + gridExpand = TRUE + ) + + # Automatically adjust column widths + openxlsx::setColWidths( + wb = wb, + sheet = sheet, + cols = seq_along(queries), + widths = "auto" + ) + + # Determine the file path for saving path <- if (!is.null(path)) { path } else { paste0(getwd(), "/example.xlsx") } - # Save workbook to a file with password + # Save the workbook with or without password protection if (!is.null(password)) { - openxlsx::protectWorksheet(wb, sheet = sheet, password = password) - openxlsx::saveWorkbook(wb, path, overwrite = T) + openxlsx::saveWorkbook(wb, path, overwrite = TRUE) message(paste0("The file has been successfully created in '", path, "' with password protection.")) - } else { - - # Save workbook to a file - openxlsx::saveWorkbook(wb, path, overwrite = T) + openxlsx::saveWorkbook(wb, path, overwrite = TRUE) message(paste0("The file has been successfully created in '", path, "'.")) - } } - - - diff --git a/R/rd_factor.R b/R/rd_factor.R new file mode 100644 index 0000000..51fabb3 --- /dev/null +++ b/R/rd_factor.R @@ -0,0 +1,175 @@ +#' Convert Variables to Factors in a REDCap Dataset +#' +#' @description +#' `r lifecycle::badge('experimental')` +#' +#' Converts variables in a REDCap dataset with associated `.factor` columns into actual factor variables, while allowing the exclusion of specific variables. Ensures consistency with the dataset and preserves variable labels. +#' +#' @param project A list containing the REDCap data, dictionary, and event mapping (expected `redcap_data()` output). Overrides `data`, `dic`, and `event_form`. +#' @param data A `data.frame` or `tibble` with the REDCap dataset. +#' @param dic A `data.frame` with the REDCap dictionary. +#' @param event_form Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects. +#' @param exclude Optional character vector of variable names (use original names **without** the `.factor` suffix) to exclude from conversion. +#' +#' @return A list with the following elements: +#' \describe{ +#' \item{data}{The transformed dataset with `.factor` columns applied as factors.} +#' \item{dictionary}{The dictionary used (unchanged).} +#' \item{event_form}{The event-form mapping used (if applicable).} +#' \item{results}{A brief text summary of the transformation.} +#' } +#' +#' @details +#' The function looks for columns ending in `.factor` and replaces the original variable values with those `.factor` values (converted to factors). It preserves variable labels. The `exclude` argument must contain base variable names (no `.factor` suffix); if any `.factor` names are passed to `exclude` the function will throw an informative error. The columns `redcap_event_name`, `redcap_repeat_instrument` and `redcap_data_access_group` (and their `.factor` counterparts) are handled specially to avoid altering event or access-group data. +#' +#' @examples +#' \dontrun{ +#' result <- rd_factor(covican) +#' result <- rd_factor(covican, exclude = c("available_analytics", "urine_culture")) +#' transformed_data <- result$data +#' } +#' +#' @export +#' @importFrom stats na.omit + +rd_factor <- function(project = NULL, data = NULL, dic = NULL, event_form = NULL, exclude = NULL) { + + results <- NULL + + # Handle potential overwriting when both `project` and other arguments are provided + if (!is.null(project)) { + env_vars <- check_proj(project, data, dic, event_form) + + list2env(env_vars, envir = environment()) + } + + # Ensure both `data` and `dic` are provided; stop if either is missing + if (is.null(data) | is.null(dic)) { + stop("Both `data` and `dic` (data and dictionary) arguments must be provided.") + } + + # Extract labels from the data to reapply later + labels <- purrr::map_chr(data, function(x) { + lab <- attr(x, "label") + if (!is.null(lab)) { + lab + } else { + "" + } + }) + + # We need to preserve the original values of `redcap_event_name` and `redcap_data_access_group`, so exclude them from conversion + keep <- c("redcap_event_name.factor", "redcap_repeat_instrument.factor", "redcap_data_access_group.factor") + keep_factors <- data |> + dplyr::select(dplyr::any_of(keep)) + + # Remove the factor versions of the variables to prevent them from being affected + data <- data |> + dplyr::select(-dplyr::any_of(keep)) + + # Identify factor columns and remove orphans + factor_cols <- grep("\\.factor$", names(data), value = TRUE) + factors <- sub("\\.factor$", "", factor_cols) + factors <- setdiff(factors, sub("\\.factor$", "", keep)) + + # Detect orphan .factor columns (base column missing) + orphan <- factor_cols[!factors %in% names(data)] + + if (length(orphan) > 0) { + warning( + stringr::str_glue( + "Removed {length(orphan)} '.factor' column(s) whose original variables no longer exist. This usually happens if the original variables were deleted earlier using `rd_delete_vars` and the '.factor' version was kept." + ), + call. = FALSE + ) + # Remove orphan columns + data <- data[, setdiff(names(data), orphan)] + # Update factors vector after removal + factors <- setdiff(factors, sub("\\.factor$", "", orphan)) + } + + # If there are no factor variables, stop the function + if (length(factors) == 0) { + warning("There are no variables in the data which can be converted to factors.", call. = FALSE) + } else { + if (!is.null(exclude)) { + bad_vars <- exclude[grepl("\\.factor$", exclude)] + if (length(bad_vars) > 0) { + stop( + sprintf( + "Please use the original form of the variable(s) without '.factor' in the exclude argument: %s", + paste(bad_vars, collapse = ", ") + ), + call. = FALSE + ) + } + } + # Exclude specified variables that should not be converted to factors + factors <- setdiff(factors, exclude) + + # If no variables are left to convert, stop and ask to review the exclude argument + if (length(factors) == 0) { + stop("All variables in the data which can be converted to factors are specified in the `exclude` argument. Please, review the `exclude` argument.", call. = FALSE) + } + + # Perform the transformation of factor columns into actual factor variables + data <- data |> + # Assign the values from the factor columns to the original columns and remove the '.factor' versions + dplyr::mutate(dplyr::across(tidyselect::all_of(factors), ~ get( + stringr::str_glue("{dplyr::cur_column()}.factor") + ))) |> + dplyr::select(-stringr::str_glue("{factors}.factor")) + } + + # If there were any variables that were excluded from conversion, reattach them to the data + if (length(keep_factors) > 0) { + data <- data |> + dplyr::bind_cols(keep_factors) + + # Relocate the kept factor variables to the correct position in the data + for (i in seq_along(keep_factors)) { + data <- data |> + dplyr::relocate(names(keep_factors)[i], .after = sub("\\.factor$", "", names(keep_factors)[i])) + } + + # Alternativa + # data <- purrr::reduce2( + # .x = c(names(keep_factors)), + # .y = c(sub("\\.factor$", "", names(keep_factors))), + # .f = ~ dplyr::relocate(..1, ..2, .after = ..3), + # .init = data + # ) + } + + # Apply the labels to the data + data <- data |> + labelled::set_variable_labels(.labels = labels |> as.list(), .strict = FALSE) + + # Update results with the this transformation + if (is.null(results)) { + results <- c(results, stringr::str_glue("Replacing original variables for their factor version. (rd_factor)\n")) + } else { + + if(grepl("^[A-Z]", results[1])) { + results[1] <- paste("1.", results[1]) + } + + last_val_res <- results |> + stringr::str_extract("^(\n)?\\d+\\.") |> + na.omit() |> + dplyr::last() |> + stringr::str_remove("\\.") |> + as.numeric() + + results <- c(results, stringr::str_glue("\n\n{last_val_res + 1}. Replacing original variables for their factor version. (rd_factor)\n")) + } + + # Return the results: the transformed data, event_form, and results + list( + data = data, + dictionary = dic, + event_form = event_form, + results = stringr::str_glue("{results}") + ) |> + purrr::compact() # Remove any NULL elements from the output list +} diff --git a/R/rd_insert_na.R b/R/rd_insert_na.R index 42eeea7..43a4faa 100644 --- a/R/rd_insert_na.R +++ b/R/rd_insert_na.R @@ -1,124 +1,252 @@ #' Insert Missing Values Using a Filter #' -#' This function allows you to manually insert a missing value into certain variables (`vars`) if the specified filter/s (`filter`) are satisfied. It's particularly useful for checkboxes without a gatekeeper question in the branching logic. Note that the variable is only transformed in the events where both the variable and the filter evaluation are present, so they must have at least one event in common. +#' @description +#' `r lifecycle::badge('stable')` +#' +#' Sets selected variables to `NA` when a filter condition is satisfied. Useful for managing checkboxes or other fields without explicit gatekeeper questions. +#' +#' @param project A list containing the REDCap data, dictionary, and event mapping (expected `redcap_data()` output). Overrides `data`, `dic`, and `event_form`. +#' @param data A `data.frame` or `tibble` with the REDCap dataset. +#' @param dic A `data.frame` with the REDCap dictionary. +#' @param event_form Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects. +#' @param vars Character vector of variable names to set to `NA`. +#' @param filter A single logical expression (as string). Rows where the filter evaluates to `TRUE` will have the corresponding `vars` set to `NA`. +#' +#' @details +#' * Each variable is only updated in rows/events where both the variable and filter are present. +#' * For longitudinal projects, `event_form` must be provided for proper event-level filtering. +#' * Only one filter expression is allowed. +#' * Variables and filter columns must exist in both `data` and `dictionary`. +#' +#' @return A list with: +#' \describe{ +#' \item{data}{The dataset with `NA` inserted where the filter applies.} +#' \item{dictionary}{The unchanged dictionary.} +#' \item{event_form}{The `event_form` passed in (if applicable).} +#' \item{results}{Summary message of the changes applied.} +#' } #' -#' @param ... List containing the data, the dictionary and the event if it's needed. Should be the output of the function `redcap_data`. -#' @param data Data frame containing data from REDCap. If the list is specified, this argument is not needed. -#' @param dic Data frame containing the dictionary read from REDCap. If the list is specified, this argument is not needed. -#' @param event_form Data frame containing the correspondence of each event with each form. If the list is specified, this argument is not needed. -#' @param vars Character vector containing the names of the variables to be transformed. -#' @param filter Character vector containing the logic to be evaluated directly. If each logic is TRUE, the corresponding variable in `vars` is set to missing. -#' @return Transformed data with the specified variables converted. #' @examples -#' table(is.na(covican$data$potassium)) -#' data <- rd_insert_na(covican, -#' vars = "potassium", -#' filter = "age < 65") +#' # Set 'potassium' to NA where age < 65 +#' \dontrun{ +#' data <- rd_insert_na( +#' data = covican$data, +#' dic = covican$dictionary, +#' vars = "potassium", +#' filter = "age < 65" +#' ) #' table(data$potassium) +#' } +#' #' @export -#' @importFrom rlang .data - -rd_insert_na <- function(..., data = NULL, dic = NULL, event_form = NULL, vars, filter){ +#' @importFrom rlang .data parse_expr eval_tidy - project <- c(...) +rd_insert_na <- function(project = NULL, data = NULL, dic = NULL, event_form = NULL, vars, filter) { - if(!is.null(project)){ - if(!is.null(data)){ - warning("Data has been specified twice so the function will not use the information in the data argument.") - } + results <- NULL - if(!is.null(dic)){ - warning("Dictionary has been specified twice so the function will not use the information in the dic argument.") - } - - data <- project$data - dic <- project$dictionary - - if("event_form" %in% names(project)){ - if(!is.null(event_form)){ - warning("Event has been specified twice so the function will not use the information in the event argument.") - } - event_form <- project$event_form - } + # Handle potential overwriting when both `project` and other arguments are provided + if (!is.null(project)) { + env_vars <- check_proj(project, data, dic, event_form) + # browser() + list2env(env_vars, envir = environment()) } - if(is.null(data) | is.null(dic)){ - stop("No data/dictionary was provided") + # Ensure both `data` and `dic` are provided; stop if either is missing + if (is.null(data) | is.null(dic)) { + stop("Both `data` and `dic` (data and dictionary) arguments must be provided.") } - #Check if the project is longitudinal (has more than one event) or not: + # Determine if the dataset is longitudinal longitudinal <- ifelse("redcap_event_name" %in% names(data), TRUE, FALSE) - if(is.null(event_form) & longitudinal){ - stop("There is more than one event in the data and the event-form correspondence hasn't been specified") + # Error: For longitudinal data, ensure `event_form` is specified + if (is.null(event_form) & longitudinal) { + stop("The dataset contains multiple events, but the `event_form` mapping was not provided. Please specify it.") } - if(length(filter) != length(vars)){ - - stop("The number of filter variables specified doesn't match with the number of variables specified", call. = FALSE) - - }else{ + # Validate there is exactly one filter and allow multiple vars + if (length(filter) != 1) { + stop("Please provide exactly one filter.") + } else { + # Parse variables within the single filter expression once + vars_filter <- trimws(unlist(stringr::str_split(filter[1], "[&|]"))) + vars_filter <- gsub("!?is.na\\(", "", vars_filter) + vars_filter <- gsub("\\[|\\]", "", vars_filter) + vars_filter <- gsub("data\\$", "", vars_filter) + vars_filter <- unlist(stringr::str_extract_all(vars_filter, "^\\w+")) + vars_filter <- unique(vars_filter) + + # check filter vars exist in the dataset + missing_in_data <- vars_filter[!vars_filter %in% names(data)] + if (length(missing_in_data) > 0) { + stop( + sprintf( + "Filter variable(s) not found in data: %s", + paste(shQuote(missing_in_data), collapse = ", ") + ), + call. = FALSE + ) + } - for(i in 1:length(filter)){ + # check filter vars exist in the dictionary + missing_in_dic <- vars_filter[!vars_filter %in% dic$field_name] + if (length(missing_in_dic) > 0) { + stop( + sprintf( + "Filter variable(s) not found in dictionary: %s", + paste(shQuote(missing_in_dic), collapse = ", ") + ), + call. = FALSE + ) + } - #For every filter & variable get the variables specified in the filter and their events (if there is more than one event) - if(longitudinal){ - #First, let's get the variables in the filter: - vars_filter <- trimws(unlist(stringr::str_split(filter[i], "[&|]"))) - vars_filter <- gsub("!?is.na\\(", "", vars_filter) - vars_filter <- unlist(stringr::str_extract_all(vars_filter, "^\\w+")) + # Extract corresponding events for filter variables + event_filter <- tibble::tibble(vars_filter = vars_filter) |> + dplyr::mutate( + form = purrr::map_chr(.data$vars_filter, ~ dic |> + dplyr::filter(.data$field_name %in% .x) |> + dplyr::pull(.data$form_name)), + event = purrr::map(.data$form, ~ event_form |> + dplyr::filter(.data$form %in% .x) |> + dplyr::pull(.data$unique_event_name)) + ) + + # Identify common events for filter variables + events <- Reduce(intersect, event_filter$event) + + # Stop if there are no common events among filter variables + if (length(events) == 0) { + stop("The variables in the filter belong to different events.") + } - #Get the events of these variables: - event_filter <- tibble::tibble(vars_filter = vars_filter) %>% - dplyr::mutate(form = purrr::map_chr(.data$vars_filter, ~dic %>% - dplyr::filter(.data$field_name %in% .x) %>% - dplyr::pull(.data$form_name)), - event = purrr::map(.data$form, ~event_form %>% - dplyr::filter(.data$form %in% .x) %>% - dplyr::pull(.data$unique_event_name))) + # Evaluate the filter expression once to get logical mask for rows + filter_expr <- tryCatch({ + rlang::parse_expr(filter[1]) + }, error = function(e) { + stop(sprintf("Unable to parse filter expression '%s'.", filter[1]), call. = FALSE) + }) + + rows_mask <- tryCatch({ + # Evaluate in the context of `data`; result should be logical vector of length nrow(data) + rlang::eval_tidy(filter_expr, data = data) + }, error = function(e) { + stop(sprintf("Error evaluating filter '%s'.", filter[1]), call. = FALSE) + }) + + if (!is.logical(rows_mask) || length(rows_mask) != nrow(data)) { + stop(sprintf("Filter '%s' did not return a logical vector with length equal to nrow(data).", filter[1])) + } - #Get the events in common of all the filter variables: - events <- Reduce(intersect, event_filter$event) + # Validate that provided vars exist in data and in dictionary + missing_vars_in_data <- vars[!vars %in% names(data)] + if (length(missing_vars_in_data) > 0) { + stop(sprintf("Variable(s) not found in data: %s", paste(shQuote(missing_vars_in_data), collapse = ", ")), call. = FALSE) + } + missing_vars_in_dic <- vars[!vars %in% dic$field_name] + if (length(missing_vars_in_dic) > 0) { + stop(sprintf("Variable(s) not found in dictionary: %s", paste(shQuote(missing_vars_in_dic), collapse = ", ")), call. = FALSE) + } - #If the filter variables have no events in common: - if(length(events) == 0){ - stop("Variables included in the filter are in different events.") + # Try to detect an event column in `data` (common names or values matching event_form) + event_col <- NULL + candidate_names <- c("redcap_event_name", "unique_event_name", "event_name", "event") + event_col <- intersect(names(data), candidate_names)[1] + if (is.null(event_col)) { + for (col in names(data)) { + col_values <- unique(data[[col]]) + if (any(col_values %in% event_form$unique_event_name, na.rm = TRUE)) { + event_col <- col + break } + } + } + + # Loop through the variables to transform + for (j in seq_along(vars)) { + var_j <- vars[j] - #Now let's get the event of the variable to be transformed: - form_var <- dic %>% - dplyr::filter(.data$field_name == vars[i]) %>% + if (longitudinal) { + # Identify events for the variable to be transformed + form_var <- dic |> + dplyr::filter(.data$field_name == var_j) |> dplyr::pull(.data$form_name) - event_var <- event_form %>% - dplyr::filter(.data$form == form_var) %>% + event_var <- event_form |> + dplyr::filter(.data$form == form_var) |> dplyr::pull(.data$unique_event_name) + # Ensure the variable's events overlap with filter events match_events <- intersect(events, event_var) - #If the filter variables are in different events with respect to the variable to be transformed it will give an error: - if(length(match_events) == 0){ - stop("The variable to be transformed is in a different event than the filter to be evaluated.") - }else{ - #If there is some event of the variable to be transformed that is not present in the filter it will give a warning: + # Error: no overlapping events between the variable and the filter + if (length(match_events) == 0) { + stop(stringr::str_glue("The variable `{var_j}` and the filter do not overlap in any events."), call. = FALSE) + } else { + # Warn: variable present in more events than the filter if (!all(event_var %in% match_events)) { - warning(stringr::str_glue("The variable to be transformed ({vars[i]}) is present in more events than the events where the corresponding filter is evaluated. Only the rows of those events in common will be transformed ({match_events}).")) + warning(stringr::str_glue( + "The variable `{var_j}` is present in more events than the filter. ", + "Only rows in common events ({paste(match_events, collapse = ', ')}) will be transformed." + )) } } + } else { + # not longitudinal: no per-event checks required + match_events <- NULL } - #Transform the data: - id <- data %>% - dplyr::mutate(id = dplyr::row_number()) %>% - dplyr::filter(eval(parse(text = filter[i]))) %>% - dplyr::pull(id) + # Compute candidate row ids where the filter is TRUE + ids <- which(rows_mask) - data[id, vars[i]] <- NA + # If longitudinal and an event column is found, restrict ids to the overlapping events for this var + if (longitudinal && !is.null(event_col)) { + ids <- ids[which(data[[event_col]][ids] %in% match_events)] + } else if (longitudinal && is.null(event_col)) { + # No event column found in data — warn that event-level restriction cannot be applied + warning("No event column detected in `data`. The filter will be applied across all rows (event-level restriction skipped).") + } + # Apply the transformation (set selected rows for var_j to NA) + if (length(ids) > 0) { + data[ids, var_j] <- NA + } else { + # No rows to change for this variable (possible due to event restriction) + # We do not stop here; just inform via a message (could be silent depending on preference) + message(sprintf("No rows matched for variable '%s' after applying filter and event overlap.", var_j)) + } } - data + # Reapply variable labels to the data after transformation + data <- data |> + labelled::set_variable_labels(.labels = labels |> as.list(), .strict = FALSE) + + # Update results with this transformation + inserted_msg <- stringr::str_glue("Inserting missing values into variable(s): {paste(vars, collapse = ', ')}. (rd_insert_na)\n") + if (is.null(results)) { + results <- c(results, inserted_msg) + } else { + if (grepl("^[A-Z]", results[1])) { + results[1] <- paste("1.", results[1]) + } - } + last_val_res <- results |> + stringr::str_extract("^(\n)?\\d+\\.") |> + na.omit() |> + dplyr::last() |> + stringr::str_remove("\\.") |> + as.numeric() + results <- c(results, stringr::str_glue("\n\n{last_val_res + 1}. {inserted_msg}\n")) + } + + # Return the updated data, dictionary, event_form, and results (if present) + list( + data = data, + dictionary = dic, + event_form = event_form, + results = stringr::str_glue("{results}") + ) |> + purrr::compact() # Remove NULL elements from the list + } } diff --git a/R/rd_query.R b/R/rd_query.R index 388b722..121e435 100644 --- a/R/rd_query.R +++ b/R/rd_query.R @@ -1,882 +1,909 @@ #' Identification of Queries #' -#' This function allows you to identify queries using a particular expression/filter. -#' It can be used to identify missing values or to identify values outside the lower and upper limits of a variable. +#' @description +#' `r lifecycle::badge('stable')` #' -#' @param ... List containing the data, dictionary and event mapping (if required) of the REDCap project. This should be the output of the `redcap_data` function. -#' @param data Data frame containing the data read from REDCap. If the list is given, this argument is not required. -#' @param dic Data frame containing the dictionary read from REDCap. If the list is given, this argument is not required. -#' @param event_form Data frame containing the correspondence of each event with each form. If the list is specified, this argument is not required. -#' @param variables Character vector containing the names of the database variables to be checked. -#' @param expression Character vector of expressions to apply to the selected variables. -#' @param negate Logical value indicating whether the defined expression should be negated. Default value is `FALSE`. -#' @param variables_names Character vector containing the description of each selected variable. By default, the function automatically takes the description of each variable from of the REDCap project dictionary. -#' @param query_name Description of the query. It can be the same for all variables, or you can define a different one for each variable. By default, this function defines it as `The value is [value] and it should not be [expression]'`. -#' @param instrument REDCap instrument to which the variables belong. It can be the same for all variables, or you can define a different one for each variable. By default, the function automatically selects the corresponding instrument of each variable from the REDCap project dictionary. -#' @param event The name of the REDCap event to analyze. If there are events in your REDCap project, you should use this argument to name the event to which the defined variables belong. -#' @param filter A filter to be applied to the dataset. For example, this argument can be used to apply the branching logic of a defined variable. -#' @param addTo Data frame corresponding to a previous query data frame to which you can add the new query data frame. By default, this function always creates a new data frame regardless previous reports. -#' @param report_title Character string specifying the title of the report. -#' @param report_zeros Logical. If `TRUE`, the function returns a report containing variables with zero queries. -#' @param by_dag Logical. If `TRUE`, both elements of the output will be grouped by the Data Access Groups (DAGs) of the REDCap project. -#' @param link List containing project information used to create a web link to each query. -#' @return A list with a data frame of 9 columns (10 columns, if the link argument is specified) meant to help the user identify each query and a table with the total number of queries per variable. +#' Detects and summarizes queries in a REDCap dataset based on specified expressions, filters, or a defined branching logic. Useful for identifying missing values, out-of-range values, or values that do not meet predefined criteria. +#' +#' @param project A list containing the REDCap data, dictionary, and event mapping (expected `redcap_data()` output). Overrides `data`, `dic`, and `event_form`. +#' @param data A `data.frame` or `tibble` with the REDCap dataset. +#' @param dic A `data.frame` with the REDCap dictionary. +#' @param event_form Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects. +#' @param variables Character vector of variable names to check for queries. +#' @param expression Character vector of R expressions to evaluate for each variable. +#' @param negate Logical, if `TRUE`, identifies values that **do not** meet the condition. Default is `FALSE`. +#' @param variables_names Optional character vector of descriptions for each variable. Defaults to the variables labels in the dictionary. +#' @param query_name Optional character vector describing each query. Defaults to a standard format: `The value is [value] and it should not be [expression]`. +#' @param event Required for longitudinal projects to avoid overestimation. REDCap event(s) to analyze. +#' @param instrument Optional REDCap instrument(s) for each variable. Defaults to the instrument reported in the dictionary. +#' @param filter Optional string of filters to apply to the dataset, such as the branching logic of a variable. +#' @param addTo Optional data frame from a previous query report to which the new results can be appended. +#' @param report_title Optional string specifying the title of the final report. Defaults to `"Report of queries"`. +#' @param report_zeros Logical, include variables with zero queries in the report. Default is `FALSE`. +#' @param by_dag Logical, split results by Data Access Group (DAG). Default is `FALSE`. +#' @param link Optional list containing project information (`domain`, `redcap_version`, `proj_id`, `event_id`) to generate clickable links for each query. +#' +#' @details +#' The function performs the following steps: +#' * Applies user-specified expressions to the selected variables to detect queries. +#' * Optionally negates the expressions to find values that **do not** satisfy the condition. +#' * Handles REDCap branching logic, converting it into R-compatible expressions for evaluation. +#' * Applies additional user-specified filters before identifying queries. +#' * Generates structured query results with metadata including: +#' - Identifier (record_id) +#' - DAG (if present) +#' - Event and Instrument +#' - Field, Repetition, Description, Query statement +#' - Optional link to REDCap entry +#' * Optionally combines results with previous query outputs using `addTo`. +#' * Produces a summarized report, optionally including variables with zero queries. +#' * Provides warnings for variables with branching logic that could not be automatically evaluated. +#' +#' +#' @return A list containing: +#' \describe{ +#' \item{queries}{A data frame or a list of data frames (if `by_dag = TRUE`) with detailed query information for each record.} +#' \item{results}{A formatted report (HTML table) summarizing total queries per variable, event, and DAG if applicable.} +#' } #' #' @examples -#' # Missing values -#' example <- rd_query(covican, -#' variables = c("copd", "age"), -#' expression = c("is.na(x)", "x %in% NA"), -#' event = "baseline_visit_arm_1") -#' example +#' \dontrun{ +#' # Identify missing values for multiple variables +#' result <- rd_query(covican, +#' variables = c("copd", "age"), +#' expression = c("is.na(x)", "x %in% NA"), +#' event = "baseline_visit_arm_1" +#' ) +#' result$results +#' +#' # Identify values exceeding a threshold +#' result <- rd_query(covican, +#' variables = "age", +#' expression = "x > 20", +#' event = "baseline_visit_arm_1" +#' ) #' -#' # Expression -#' example <- rd_query(covican, -#' variables="age", -#' expression="x>20", -#' event="baseline_visit_arm_1") -#' example +#' # Apply a filter to select subset of data +#' result <- rd_query(covican, +#' variables = "potassium", +#' expression = "is.na(x)", +#' event = "baseline_visit_arm_1", +#' filter = "available_analytics == '1'" +#' ) +#' } #' -#' # Using the filter argument -#' example <- rd_query(covican, -#' variables = "potassium", -#' expression = "is.na(x)", -#' event = "baseline_visit_arm_1", -#' filter = "available_analytics=='1'") -#' example #' @export #' @importFrom rlang .data -rd_query <- function(..., variables = NA, expression = NA, negate = FALSE, event = NA, filter = NA, addTo = NA, variables_names = NA, query_name = NA, instrument = NA, report_title = NA, report_zeros = FALSE, by_dag = FALSE, link = list(), data = NULL, dic = NULL, event_form = NULL) - { +rd_query <- function(project = NULL, variables = NA, expression = NA, negate = FALSE, event = NA, filter = NA, addTo = NA, variables_names = NA, query_name = NA, instrument = NA, report_title = NA, report_zeros = FALSE, by_dag = FALSE, link = list(), data = NULL, dic = NULL, event_form = NULL) { - # If the entire list resulting from the 'redcap_data' function is used - project <- c(...) + # Handle potential overwriting when both `project` and other arguments are provided + if (!is.null(project)) { + env_vars <- check_proj(project, data, dic, event_form) + # browser() + list2env(env_vars, envir = environment()) + } - if(!is.null(project)){ + # Ensure both `data` and `dic` are provided; stop if either is missing + if (is.null(data) | is.null(dic)) { + stop("Both `data` and `dic` (data and dictionary) arguments must be provided.") + } - if(!is.null(data)){ - warning("Data has been specified twice so the function will not use the information in the data argument.") - } + # Ensure data and dictionary are data frames + data <- as.data.frame(data) + dic <- as.data.frame(dic) - if(!is.null(dic)){ - warning("Dictionary has been specified twice so the function will not use the information in the dic argument.") - } + # Initialize the query structure + queries <- as.data.frame(matrix(ncol = 10, nrow = 0)) + colnames(queries) <- c("Identifier", "DAG", "Event", "Instrument", "Field", "Repetition", "Description", "Query", "Code", "Link") - data <- project$data - dic <- project$dictionary + # Initialize the zero-query structure + excel_zero <- as.data.frame(matrix(ncol = 4, nrow = 0)) + colnames(excel_zero) <- c("DAG", "Variables", "Description", "Query") - if("event_form" %in% names(project)) { - if(!is.null(event_form)){ - warning("Event form has been specified twice so the function will not use the information in the event_form argument.") - } - event_form <- as.data.frame(project$event_form) - } - } + # Rename the first column of the dataset to 'record_id' if necessary + if (all(!names(data) == "record_id")) { + names(data)[1] <- "record_id" + } - # Making sure that the object data and dic are a data.frame - data <- as.data.frame(data) - dic <- as.data.frame(dic) + # Error: specified variables do not exist in the dataset + if (any(!variables %in% names(data))) { + stop("Specified variables do not exist in the dataset. Please review the `variables` argument.") + } - # Creation of the structure of the queries - queries <- as.data.frame(matrix(ncol = 10, nrow = 0)) - colnames(queries) <- c("Identifier", "DAG", "Event", "Instrument", "Field", "Repetition", "Description", "Query", "Code", "Link") + # Warning: event not specified + if (all(is.na(event)) & any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data)) & is.null(event_form)) { + warning("No event or event-form has been specified. Therefore, the function will automatically consider observations from all events in the dataset. Ensure that the selected variable(s) is(are) collected in all specified events. This will avoid overestimating the number of queries.", call. = FALSE) + } - # Creation of the structure for variables with zero queries - excel_zero <- as.data.frame(matrix(ncol = 4, nrow = 0)) - colnames(excel_zero) <- c("DAG", "Variables", "Description", "Query") + # Handle events automatically based on event_form and dictionary + if (all(is.na(event)) & !is.null(event_form)) { + var_form <- dic |> + dplyr::filter(.data$field_name %in% variables) |> + dplyr::pull(.data$form_name) - # Naming the first column of the REDCap's database as record_id - if (all(!names(data) == "record_id")) { - names(data)[1] <- "record_id" - } + event <- event_form |> + dplyr::filter(.data$form %in% var_form) |> + dplyr::pull(.data$unique_event_name) + } - # Error: one of the variables does not exist in the data - if (any(!variables %in% names(data))) { - stop("The data does not contain the specified variable(s). Please double-check the input variable name.") + # Apply event filtering if events are specified + if (all(!is.na(event))) { + # Saving initial dataset + data0 <- data + + # Error: event variable is missing in dataset + if (all(!c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { + stop("Event specified, but no event variable found in the dataset. Please review the `event` argument.") } - # Warning: event not specified - if (all(is.na(event)) & any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data)) & is.null(event_form)) { - warning("No event or event-form has been specified. Therefore, the function will automatically consider observations from all events in the dataset. Ensure that the selected variable(s) is(are) collected in all specified events. This will avoid overestimating the number of queries.", call. = F) + # Error: specified events are not in the dataset + if (any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { + if (any(!event %in% data$redcap_event_name) & any(!event %in% data$redcap_event_name.factor)) { + stop("One or more specified events are not found in the dataset. Please review the `event` argument.") + } } - # If the argument event is not specified but there is the event form element in our data frame - if (all(is.na(event)) & !is.null(event_form)) { - var_form <- dic %>% - dplyr::filter(.data$field_name %in% variables) %>% - dplyr::pull(.data$form_name) + # Warning: multiple events are specified + if (length(event) > 1 & is.null(event_form)) { + warning("Multiple events specified. Ensure variables are collected across all events to avoid overestimation.", .call = FALSE) + } - event <- event_form %>% - dplyr::filter(.data$form %in% var_form) %>% - dplyr::pull(.data$unique_event_name) + # Filter data by events - factor version + if ("redcap_event_name.factor" %in% names(data) & all(event %in% data$redcap_event_name.factor)) { + data <- dplyr::filter(data, data$redcap_event_name.factor %in% event) } - # Applying a filter of the chosen events to the database - if (all(!is.na(event))) { + # Filter data by events - raw version + if (all(event %in% data$redcap_event_name)) { + data <- dplyr::filter(data, data$redcap_event_name %in% event) + } - # Saving initial dataset - data0 <- data + # Warning: identifiers are missing observations in any event (it only appears when checking for missings - %in%NA) + if (length(unique(data0$record_id)) != length(unique(data$record_id)) & any(grepl("%in%NA", gsub(" ", "", expression)))) { + warning("Some identifiers are missing observations in specified events.\nUse 'rd_event' to check which identifiers are missing.", call. = FALSE) + } + } - # Error: there is no event name variable in the dataset but the argument has a value - if (all(!c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { - stop("The event argument is specified, but there is no event name variable in the dataset.") - } + # Error: by_dag is TRUE but no DAG variable exists + if (by_dag %in% TRUE & all(!c("redcap_data_access_group", "redcap_data_access_group.factor") %in% names(data))) { + stop("DAG-based reporting requested, but no DAG variable found in the dataset. Use `by_dag = FALSE` to continue.") + } - # Error: one of the specified events does not exist in the database - if (any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { - if (any(!event %in% data$redcap_event_name) & any(!event %in% data$redcap_event_name.factor)) { - stop("One of the events mentioned does not exist in the database, please verify the argument 'event'.") - } - } + # Warning: Validate 'link' argument and ensure completeness + if (!is.null(names(link))) { + if (!all(c("domain", "redcap_version", "proj_id", "event_id") %in% names(link)) & any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { + stop("Incomplete 'link' argument. To properly use it, please provide domain, redcap_version, project ID, and event ID.", call. = FALSE) + } - # Warning: there is more than one event specified - if (length(event) > 1 & is.null(event_form)) { - warning("More than one event has been specified. Ensure that the selected variable(s) are collected in all specified events. This will avoid overestimating the number of queries.", call. = F) - } + if (!all(c("domain", "redcap_version", "proj_id") %in% names(link)) & !any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { + stop("Incomplete 'link' argument. To properly use it, please provide domain, redcap_version and project ID.", call. = FALSE) + } + } - # Filtering by event_name.factor if the event is equal to the category in the factor version - if ("redcap_event_name.factor" %in% names(data) & all(event %in% data$redcap_event_name.factor)) { - data <- dplyr::filter(data, data$redcap_event_name.factor %in% event) + # Handle event_id addition based on the link argument + if (!is.null(link[["event_id"]])) { + if (any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { + # The event argument is specified and the event_id is specified using the events in the raw version + if (all(event %in% names(link[["event_id"]])) & all(event %in% data[, "redcap_event_name"])) { + event_link <- data.frame( + "name" = names(link[["event_id"]]), + "event_id" = as.numeric(link[["event_id"]]) + ) + data <- merge(data, event_link, by.x = "redcap_event_name", by.y = "name") } - # Filtering by event_name if the event is equal to the category in the raw version - if (all(event %in% data$redcap_event_name)) { - data <- dplyr::filter(data, data$redcap_event_name %in% event) + # The event argument is specified and the event_id is specified using the events in the factor version + if (all(event %in% names(link[["event_id"]])) & all(event %in% data[, "redcap_event_name.factor"])) { + event_link <- data.frame( + "name" = names(link[["event_id"]]), + "event_id" = as.numeric(link[["event_id"]]) + ) + data <- merge(data, event_link, by.x = "redcap_event_name.factor", by.y = "name") } - # Warning: there are identifiers that do not present the specified event (it only appears when checking for missings - %in%NA) - if (length(unique(data0$record_id)) != length(unique(data$record_id)) & any(grepl("%in%NA", gsub(" ", "", expression)))) { - warning("There are certain identifiers without observations in one of the events. \nUse the function 'rd_event' to check which ones are missing.", call. = FALSE) + # The event argument is not specified and the event_id is specified using the events in the raw version + if (all(is.na(event) & all(names(data[, "redcap_event_name"] %in% names(link[["event_id"]]))))) { + event_link <- data.frame( + "name" = names(link[["event_id"]]), + "event_id" = as.numeric(link[["event_id"]]) + ) + data <- merge(data, event_link, by.x = "redcap_event_name", by.y = "name") } - } - # Error: Trying to split the report by DAGs but the REDCap project does not present DAGs - if (by_dag %in% TRUE & all(!c("redcap_data_access_group", "redcap_data_access_group.factor") %in% names(data))) { - stop("Trying to split the query reporting according to each DAG, but the project does not present DAGs. To continue, please specify by_dag = F.", call. = F) - } - - # Warning: If the link argument is not fully completed - if (!is.null(names(link))) { - if (!all(c("domain", "redcap_version", "proj_id", "event_id") %in% names(link)) & any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { - stop("There is not enough information in the link argument. \nTo create the link correctly, please provide the domain, redcap version, project ID and event ID.", call. = F) - } - if (!all(c("domain", "redcap_version", "proj_id") %in% names(link)) & !any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { - stop("There is not enough information in the link argument. \nTo create the link correctly, please provide the domain, redcap version and project ID.", call. = F) + # The event argument is not specified and the event_id is specified using the events in the factor version + if (all(is.na(event) & all(names(data[, "redcap_event_name.factor"] %in% names(link[["event_id"]]))))) { + event_link <- data.frame( + "name" = names(link[["event_id"]]), + "event_id" = as.numeric(link[["event_id"]]) + ) + data <- merge(data, event_link, by.x = "redcap_event_name.factor", by.y = "name") } - } - - # Adding the information of the event_id from the link argument to the data - if (!is.null(link[["event_id"]])) { - - # The dataset has an event name variable - if (any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { - - # The event argument is specified and the event_id is specified using the events in the raw version - if (all(event %in% names(link[["event_id"]])) & all(event %in% data[, "redcap_event_name"])) { - event_link <- data.frame("name" = names(link[["event_id"]]), - "event_id" = as.numeric(link[["event_id"]])) - data <- merge(data, event_link, by.x = "redcap_event_name", by.y = "name") - } - - # The event argument is specified and the event_id is specified using the events in the factor version - if (all(event %in% names(link[["event_id"]])) & all(event %in% data[, "redcap_event_name.factor"])) { - event_link <- data.frame("name" = names(link[["event_id"]]), - "event_id" = as.numeric(link[["event_id"]])) - data <- merge(data, event_link, by.x = "redcap_event_name.factor", by.y = "name") - } - - # The event argument is not specified and the event_id is specified using the events in the raw version - if (all(is.na(event) & all(names(data[, "redcap_event_name"] %in% names(link[["event_id"]]))))) { - event_link <- data.frame("name" = names(link[["event_id"]]), - "event_id" = as.numeric(link[["event_id"]])) - data <- merge(data, event_link, by.x = "redcap_event_name", by.y = "name") - } - - # The event argument is not specified and the event_id is specified using the events in the factor version - if (all(is.na(event) & all(names(data[, "redcap_event_name.factor"] %in% names(link[["event_id"]]))))) { - event_link <- data.frame("name" = names(link[["event_id"]]), - "event_id" = as.numeric(link[["event_id"]])) - data <- merge(data, event_link, by.x = "redcap_event_name.factor", by.y = "name") - } - + } else { + # There is not an event name variable in the dataset + if (length(link[["event_id"]]) == 1) { + data[, "event_id"] <- as.numeric(link[["event_id"]]) } else { - - # There is not an event name variable in the dataset - if (length(link[["event_id"]]) == 1) { - - data[, "event_id"] <- as.numeric(link[["event_id"]]) - - } else { - - # Error: More than one event_id is specified and the project is non-longitudinal - stop("The project is non-longitudinal (has no events). Therefore, you only need to specify a single event ID.", call. = F) - - } - } + # Error: More than one event_id is specified and the project is non-longitudinal + stop("Non-longitudinal project. Please provide only one event ID.", .call = FALSE) + } } + } - # Warning: detecting more variables than expressions, so the function applies the same expression to all variables + # Ensure expressions and variables match in length + if (length(variables) != length(expression)) { if (length(variables) > length(expression)) { - + warning( + paste0( + "Number of variables (", length(variables), + ") is greater than the number of expressions (", length(expression), "). ", + "The first expression will be applied to all variables." + ), + call. = FALSE + ) + + # Repeat the first expression for remaining variables expression <- rep(expression[1], length(variables)) - warning("Due to the greater number of variables compared to expressions, the same expression has been applied to all of them.", call. = FALSE) - + } else { + warning( + paste0( + "Number of expressions (", length(expression), + ") is greater than the number of variables (", length(variables), "). ", + "The first variable will be used for all expressions." + ), + call. = FALSE + ) + + # Repeat the first variable for remaining expressions + variables <- rep(variables[1], length(expression)) } + } - # Filtering the data using the information of the argument 'filter' - if (all(!is.na(filter)) & length(filter) == 1) { - - # Error: logic used in the filter is incorrect - command <- paste0("data", "<-dplyr::filter(data,", filter, ")") - - evaluation <- try(eval(parse(text = command)), silent = TRUE) - - if(inherits(evaluation, "try-error")){ - - stop("The logic used in the filter is incorrect. Please review the filter argument and make the necessary adjustments.") - - } else { - - eval(parse(text = command)) + # Apply filter logic if specified + if (all(!is.na(filter)) & length(filter) == 1) { + # Error: logic used in the filter is incorrect + command <- paste0("data", "<-dplyr::filter(data,", filter, ")") - } + evaluation <- try(eval(parse(text = command)), silent = TRUE) - # Error: filter results in zero observations - if (nrow(data) == 0) { - warning("The filter applied is correct but does not match any observations. Please double-check that the filter is properly formulated.", call. = FALSE) - } + if (inherits(evaluation, "try-error")) { + stop("Invalid filter logic. Please review the `filter` argument.") + } else { + eval(parse(text = command)) } - # Variables to be checked for missing values which present a branching logic - var_logic <- variables[which(variables %in% dic[!dic$branching_logic_show_field_only_if %in% c(NA, ""), "field_name"])] - - # We create three objects that will contain the branching logic that can't be converted to R logic - compatible <- NULL - logics <- NULL - br_eval <- NULL - - # Branching logic detected (only in variables checked for missing values) - if (length(var_logic) > 0) { - - # Data frame with variable, variable name and branching logic - branch <- data.frame( - var = dic$field_name[dic$field_name %in% gsub("___\\d*$", "", var_logic)], - label = gsub("\\s+", "", gsub("<.*?>", "", dic$field_label[dic$field_name %in% gsub("___\\d*$", "", var_logic)])), - branch = dic$branching_logic_show_field_only_if[dic$field_name %in% gsub("___\\d*$", "", var_logic)]) - - # Saving the original data frame before the transformation - branch0 <- branch - - # We convert the REDCap logic into R logic - if ((!is.null(event_form) | all(!c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) & all(stringr::str_detect(branch$branch, paste(c("\\[", "\\]"), collapse = "|")))) { - - for (j in 1:nrow(branch)) { - - evaluation <- try(rd_rlogic(data = data, dic = dic, event_form = event_form, logic = branch$branch[j], var = branch$var[j])$rlogic, silent = T) - - if (!inherits(evaluation, "try-error")) { + # Error: filter results in zero observations + if (nrow(data) == 0) { + warning("Filter applied successfully, but no matching observations found. Please review the `filter` argument.") + } + } - branch$branch[j] <- rd_rlogic(data = data, dic = dic, event_form = event_form, logic = branch$branch[j], var = branch$var[j])$rlogic + # Handle branching logic for variables + var_logic <- variables[which(variables %in% dic[!dic$branching_logic_show_field_only_if %in% c(NA, ""), "field_name"])] - } else { + # Objects to track compatible logic, unconverted logic, and branching evaluations + compatible <- NULL + logics <- NULL + br_eval <- NULL - logics <- rbind(logics, branch$var[j]) + if (length(var_logic) > 0) { + # Create a data frame of variables, labels, and their branching logic + branch <- data.frame( + var = dic$field_name[dic$field_name %in% gsub("___\\d*$", "", var_logic)], + label = gsub("\\s+", "", gsub("<.*?>", "", dic$field_label[dic$field_name %in% gsub("___\\d*$", "", var_logic)])), + branch = dic$branching_logic_show_field_only_if[dic$field_name %in% gsub("___\\d*$", "", var_logic)] + ) - } - } + # Save the original branching logic data for reference + branch0 <- branch - if (!is.null(logics) & nrow(data) > 0) { - - warning(c("The branching logic of the following variables could not be converted into R logic:", paste0("\n - ", unique(logics)), "\n Check the results element of the output(...$results) for details."), call. = F) + # Convert REDCap logic into R-compatible logic + if ((!is.null(event_form) | all(!c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) & all(stringr::str_detect(branch$branch, paste(c("\\[", "\\]"), collapse = "|")))) { + for (j in seq_len(nrow(branch))) { + evaluation <- try(rd_rlogic(data = data, dic = dic, event_form = event_form, logic = branch$branch[j], var = branch$var[j])$rlogic, silent = TRUE) + if (!inherits(evaluation, "try-error")) { + branch$branch[j] <- rd_rlogic(data = data, dic = dic, event_form = event_form, logic = branch$branch[j], var = branch$var[j])$rlogic + } else { + logics <- rbind(logics, branch$var[j]) } } - # Arrange the data frames - rownames(branch0) <- NULL - names(branch0) <- c("Variable", "Label", "Branching logic") - rownames(branch) <- NULL - names(branch) <- c("Variable", "Label", "Branching logic") - - ## Warning about the variables with branching logic - if (is.null(event_form) & any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { - warning("At least one of the variables that have been checked for missing values present a branching logic. \nCheck the results element of the output(...$results) for details.", call. = FALSE) + # Issue warning for logic that could not be converted + if (!is.null(logics) & nrow(data) > 0) { + warning(stringr::str_glue("The branching logic of the following variables could not be converted into R logic: {paste0('\n - ', unique(logics))}\nCheck the results element of the output(...$results) for details."), call. = FALSE) } } - # Apply an expression to the corresponding variable - for (i in 1:length(expression)) { - - # If the chosen variable has a branching logic - if (length(var_logic) > 0 & (!is.null(event_form) | all(!c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) & any(!variables[i] %in% logics)) { - if (any(variables[i] == var_logic)) { + # Reorganize data frames for reporting + rownames(branch0) <- NULL + names(branch0) <- c("Variable", "Label", "Branching logic") + rownames(branch) <- NULL + names(branch) <- c("Variable", "Label", "Branching logic") - logic <- branch %>% - dplyr::filter(.data$Variable %in% variables[i]) %>% - dplyr::pull(.data$`Branching logic`) - - branching <- NULL - command <- paste0("branching", "<-dplyr::filter(data,", gsub(pattern = "data\\$", replacement = "data$", x = logic), ")") + ## Warning branching logic in multi-event REDCap projects + if (is.null(event_form) & any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { + warning("One or more variables checked for missing values have branching logic.\nSee results (...$results) for details.", call. = FALSE) + } + } - eval(parse(text = command)) + # Apply expression filters to variables + for (i in seq_along(expression)) { + # If the chosen variable has a branching logic + if (length(var_logic) > 0 & (!is.null(event_form) | all(!c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) & any(!variables[i] %in% logics)) { + if (any(variables[i] == var_logic)) { + # Retrieve branching logic for the current variable + logic <- branch |> + dplyr::filter(.data$Variable %in% variables[i]) |> + dplyr::pull(.data$`Branching logic`) - if(nrow(branching) > 0) { + branching <- NULL - compatible <- rbind(compatible, variables[i]) - raw0 <- branching + # Evaluate branching logic + command <- paste0("branching", "<-dplyr::filter(data,", gsub(pattern = "data\\$", replacement = "data$", x = logic), ")") - } else { + eval(parse(text = command)) - br_eval <- rbind(br_eval, variables[i]) - raw0 <- data - - } + if (nrow(branching) > 0) { + compatible <- rbind(compatible, variables[i]) + raw0 <- branching } else { - + br_eval <- rbind(br_eval, variables[i]) raw0 <- data - } } else { - raw0 <- data - } + } else { + raw0 <- data + } - # Applying the expression - x <- variables[i] + # Apply custom expression filters + x <- variables[i] + command <- paste0("raw", "<-dplyr::filter(raw0,", gsub("\\bx\\b", x, expression[i]), ")") + eval(parse(text = command)) - command <- paste0("raw", "<-dplyr::filter(raw0,", gsub("\\bx\\b", x, expression[i]), ")") + # Transform the expression so it does not contain "x" + expression[i] <- gsub("\\bx\\b", "", expression[i]) - # Evaluation of the command with the resulting expression - eval(parse(text = command)) + # Handle negation if specified + if (negate == TRUE) { + raw <- suppressMessages(dplyr::anti_join(raw0, raw)) + } - # Transform the expression so it does not contain "x" - expression[i] <- gsub("\\bx\\b", "", expression[i]) + # Handle multiple filters + if (all(!filter %in% NA) & length(filter) > 1) { + # If the number of filters is equal to the number of variables + if (length(filter) == length(variables)) { + # Apply each filter individually + command <- paste0("definitive", "<-dplyr::filter(raw,", filter[i], ")") + eval(parse(text = command)) - # If the argument negate is TRUE, reverse the expression apllied - if (negate == TRUE) { - raw <- suppressMessages(dplyr::anti_join(raw0, raw)) + # Filtering results in zero observations + if (nrow(data) == 0) { + warning( + paste0( + "The filter for variable '", variables[i], "' resulted in no matching observations. Verify the filter logic." + ), + call. = FALSE + ) + } + } else { + # Error: number of filters is different from the number of variables + stop("Mismatch in the number of filters and variables. Ensure each variable has a corresponding filter.", call. = FALSE) } + } else { + definitive <- raw + } - # If there is more than one filter - if (all(!filter %in% NA) & length(filter) > 1) { - # If the number of filters is equal to the number of variables - if (length(filter) == length(variables)) { + # Generate query structure and metadata + if (nrow(definitive) > 0) { + # Construct query data frame + x <- definitive[, c("record_id", grep("redcap", names(definitive), value = TRUE), variables[i])] - # Apply each filter - command <- paste0("definitive", "<-dplyr::filter(raw,", filter[i], ")") - eval(parse(text = command)) + # Add event_id when the link argument is specified + if (all(c("domain", "redcap_version", "proj_id", "event_id") %in% names(link))) { + x[, "event_id"] <- definitive[, "event_id"] + } - # Filtering results in zero observations - if (nrow(data) == 0) { - warning("One of the applied filters does not match any observations. Please check that it is correct.", call. = FALSE) - } + # Filling the structure data frame with data + excel <- data.frame( + Identifier = x[, "record_id"], + DAG = if (any(c("redcap_data_access_group", "redcap_data_access_group.factor") %in% names(x))) { + if ("redcap_data_access_group.factor" %in% names(x)) { + as.character(x[, "redcap_data_access_group.factor"]) } else { - # Error: number of filters is different from the number of variables - stop("Multiple filters have been applied, but the number of filters does not match the number of variables. Please verify it.", call. = F) + as.character(x[, "redcap_data_access_group"]) } - } else { - definitive <- raw - } - - - # Identification of queries, using the structure built before - if (nrow(definitive) > 0) { - x <- definitive[, c("record_id", grep("redcap", names(definitive), value = T), variables[i])] - - # Add event_id when the link argument is specified - if (all(c("domain", "redcap_version", "proj_id", "event_id") %in% names(link))) { - x[, "event_id"] <- definitive[, "event_id"] - } - - # Filling the structure data frame with data - excel <- data.frame( - Identifier = x[, "record_id"], - DAG = if (any(c("redcap_data_access_group", "redcap_data_access_group.factor") %in% names(x))) { - if ("redcap_data_access_group.factor" %in% names(x)) { - as.character(x[, "redcap_data_access_group.factor"]) - } else { - as.character(x[, "redcap_data_access_group"]) - } + "-" + }, + Event = if (any(c("redcap_event_name", "redcap_event_name.factor") %in% names(x))) { + if ("redcap_event_name.factor" %in% names(x)) { + as.character(x[, "redcap_event_name.factor"]) } else { - "-" - }, - Event = if (any(c("redcap_event_name", "redcap_event_name.factor") %in% names(x))) { - if ("redcap_event_name.factor" %in% names(x)) { - as.character(x[, "redcap_event_name.factor"]) - } else { - as.character(x[, "redcap_event_name"]) - } + as.character(x[, "redcap_event_name"]) + } + } else { + "-" + }, + Instrument = if (all(is.na(instrument))) { + if (gsub("___.*$", "", variables[i]) %in% dic$field_name) { + gsub("_", " ", stringr::str_to_sentence(dic[dic[, "field_name"] %in% gsub("___.*$", "", variables[i]), "form_name"])) } else { "-" - }, - Instrument = if (all(is.na(instrument))) { - if (gsub("___.*$", "", variables[i]) %in% dic$field_name) { - gsub("_", " ", stringr::str_to_sentence(dic[dic[, "field_name"] %in% gsub("___.*$", "", variables[i]), "form_name"])) - } else{ - "-" - } + } + } else { + if (length(instrument) == 1) { + instrument } else { - if (length(instrument) == 1) { - instrument + if (length(instrument) == length(variables) & length(instrument) > 1) { + instrument[i] } else { - if (length(instrument) == length(variables) & length(instrument) > 1) { - instrument[i] - } else { - if (length(instrument) != length(variables) & length(instrument) > 1) { - stop("Multiple instruments specified, but the number of instruments is different from the number of variables. Please match each variable to each instrument.", call. = F) - } + if (length(instrument) != length(variables) & length(instrument) > 1) { + stop("Multiple instruments specified, but the number of instruments is different from the number of variables. Please match each variable to each instrument.", call. = FALSE) } } - }, - Field = variables[i], - Repetition = if (any(c("redcap_repeat_instrument", "redcap_repeat_instance") %in% names(x))) { - if ("redcap_repeat_instrument" %in% names(x) & all(is.na(x[, "redcap_repeat_instrument"]))) { - if ("redcap_repeat_instance" %in% names(x) & all(is.na(x[, "redcap_repeat_instance"]))) { - "-" - } else { - paste0(x[, "redcap_repeat_instance"]) - } + } + }, + Field = variables[i], + Repetition = if (any(c("redcap_repeat_instrument", "redcap_repeat_instance") %in% names(x))) { + if ("redcap_repeat_instrument" %in% names(x) & all(is.na(x[, "redcap_repeat_instrument"]))) { + if ("redcap_repeat_instance" %in% names(x) & all(is.na(x[, "redcap_repeat_instance"]))) { + "-" } else { - paste0(x[, "redcap_repeat_instrument"], "-", x[, "redcap_repeat_instance"]) + paste0(x[, "redcap_repeat_instance"]) } + } else { + paste0(x[, "redcap_repeat_instrument"], "-", x[, "redcap_repeat_instance"]) + } + } else { + "-" + }, + Description = if (all(is.na(variables_names))) { + if (gsub("___.*$", "", variables[i]) %in% dic$field_name) { + trimws(gsub("<.*?>", "", as.character(dic[dic[, "field_name"] %in% gsub("___.*$", "", variables[i]), "field_label"]))) } else { "-" - }, - Description = if (all(is.na(variables_names))) { - if (gsub("___.*$", "", variables[i]) %in% dic$field_name) { - trimws(gsub("<.*?>", "", as.character(dic[dic[, "field_name"] %in% gsub("___.*$", "", variables[i]), "field_label"]))) - } else{ - "-" - } + } + } else { + if (length(variables_names) == 1) { + variables_names } else { - if (length(variables_names) == 1) { - variables_names + if (length(variables_names) == length(variables) & length(variables_names) > 1) { + variables_names[i] } else { - if (length(variables_names) == length(variables) & length(variables_names) > 1) { - variables_names[i] - } else { - if (length(variables_names) != length(variables) & length(variables_names) > 1) { - stop("Multiple variables names specified, but the number of names is different from the number of variables. Please match each variable to each name.", call. = F) - } + if (length(variables_names) != length(variables) & length(variables_names) > 1) { + stop("Multiple variables names specified, but the number of names is different from the number of variables. Please match each variable to each name.", call. = FALSE) } } - }, - Query = if (all(!is.na(query_name))) { - if (length(query_name) %in% 1) { - query_name + } + }, + Query = if (all(!is.na(query_name))) { + if (length(query_name) %in% 1) { + query_name + } else { + if (length(query_name) %in% length(variables) & length(query_name) > 1) { + query_name[i] } else { - if (length(query_name) %in% length(variables) & length(query_name) > 1) { - query_name[i] - } else { - if (!length(query_name) %in% length(variables) & length(query_name) > 1) { - stop("Multiple query names specified, but the number of query names is different from the number of variables. Please match each variable to each query name.", call. = F) - } + if (!length(query_name) %in% length(variables) & length(query_name) > 1) { + stop("Multiple query names specified, but the number of query names is different from the number of variables. Please match each variable to each query name.", call. = FALSE) } } + } + } else { + if (negate == TRUE) { + trimws(gsub(" ", " ", paste("The value is", x[, variables[i]], "and it should be", stringi::stri_replace_all_regex(gsub(" ", "", expression[i]), pattern = c("<", ">", "<=", ">=", "&", "\\|", "==", "!=", "%in%NA", "%in%", "%nin%", "is.na\\(\\)"), replacement = c(" less than ", " greater than ", " less than or equal to ", " greater than or equal to ", " and ", " or ", " equal to ", " not equal to ", " missing ", " equal to ", " not equal to ", " missing "), vectorize = FALSE)))) } else { - if (negate == TRUE) { - trimws(gsub(" ", " ", paste("The value is", x[, variables[i]], "and it should be", stringi::stri_replace_all_regex(gsub(" ", "", expression[i]), pattern=c("<", ">", "<=", ">=", "&", "\\|", "==", "!=", "%in%NA", "%in%", "%nin%", "is.na\\(\\)"), replacement=c(" less than ", " greater than ", " less than or equal to ", " greater than or equal to ", " and ", " or ", " equal to ", " not equal to ", " missing ", " equal to ", " not equal to ", " missing "), vectorize=FALSE)))) - } else { - trimws(gsub(" ", " ", paste("The value is", x[, variables[i]], "and it should not be", stringi::stri_replace_all_regex(gsub(" ", "", expression[i]), pattern=c("<", ">", "<=", ">=", "&", "\\|", "==", "!=", "%in%NA", "%in%", "%nin%", "is.na\\(\\)"), replacement=c(" less than ", "greater than ", " less than or equal to ", " greater than or equal to ", " and ", " or ", " equal to ", " not equal to ", " missing ", " equal to ", " not equal to ", " missing "), vectorize=FALSE)))) - } - }, - Code = "", - stringsAsFactors = FALSE - ) - - # Add link to each query - if (all(c("domain", "redcap_version", "proj_id", "event_id") %in% names(link)) & any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { - excel[, "Link"] <- paste0("https://", link[["domain"]], "/redcap_v", link[["redcap_version"]], "/DataEntry/index.php?pid=", link[["proj_id"]], "&event_id=", x[, "event_id"], "&page=", dic[dic[, "field_name"] %in% gsub("___.*$", "", variables[i]), "form_name"], "&id=", x[, "record_id"]) - } - - if (all(c("domain", "redcap_version", "proj_id") %in% names(link)) & !any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { - excel[, "Link"] <- paste0("https://", link[["domain"]], "/redcap_v", link[["redcap_version"]], "/DataEntry/index.php?pid=", link[["proj_id"]], "&page=", dic[dic[, "field_name"] %in% gsub("___.*$", "", variables[i]), "form_name"], "&id=", x[, "record_id"]) - } + trimws(gsub(" ", " ", paste("The value is", x[, variables[i]], "and it should not be", stringi::stri_replace_all_regex(gsub(" ", "", expression[i]), pattern = c("<", ">", "<=", ">=", "&", "\\|", "==", "!=", "%in%NA", "%in%", "%nin%", "is.na\\(\\)"), replacement = c(" less than ", "greater than ", " less than or equal to ", " greater than or equal to ", " and ", " or ", " equal to ", " not equal to ", " missing ", " equal to ", " not equal to ", " missing "), vectorize = FALSE)))) + } + }, + Code = "", + stringsAsFactors = FALSE + ) + + # Add link to each query + if (all(c("domain", "redcap_version", "proj_id", "event_id") %in% names(link)) & any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { + excel[, "Link"] <- paste0("https://", link[["domain"]], "/redcap_v", link[["redcap_version"]], "/DataEntry/index.php?pid=", link[["proj_id"]], "&event_id=", x[, "event_id"], "&page=", dic[dic[, "field_name"] %in% gsub("___.*$", "", variables[i]), "form_name"], "&id=", x[, "record_id"]) + } - # Adding each identified query to the queries data frame - queries <- rbind(queries, excel) + if (all(c("domain", "redcap_version", "proj_id") %in% names(link)) & !any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { + excel[, "Link"] <- paste0("https://", link[["domain"]], "/redcap_v", link[["redcap_version"]], "/DataEntry/index.php?pid=", link[["proj_id"]], "&page=", dic[dic[, "field_name"] %in% gsub("___.*$", "", variables[i]), "form_name"], "&id=", x[, "record_id"]) + } - } else { + # Adding each identified query to the queries data frame + queries <- rbind(queries, excel) + } else { - # If there are no queries to be identified, we still need this information to build the report - excel <- data.frame( - DAG = if (any(c("redcap_data_access_group", "redcap_data_access_group.factor") %in% names(data)) & nrow(data) > 0) { - if("redcap_data_access_group.factor" %in% names(data)) { - if (all(is.na(event))) { - unique(as.character(data[, "redcap_data_access_group.factor"])) - } else { - unique(as.character(data[data$redcap_event_name %in% event | data$redcap_event_name.factor %in% event, "redcap_data_access_group.factor"])) - } + # Handle cases with zero queries + excel <- tibble::tibble( + DAG = if (any(c("redcap_data_access_group", "redcap_data_access_group.factor") %in% names(data)) & nrow(data) > 0) { + if ("redcap_data_access_group.factor" %in% names(data)) { + if (all(is.na(event))) { + unique(as.character(data[, "redcap_data_access_group.factor"])) } else { - if (all(is.na(event))) { - unique(as.character(data[, "redcap_data_access_group"])) - } else { - unique(as.character(data[data$redcap_event_name %in% event | data$redcap_event_name.factor %in% event, "redcap_data_access_group"])) - } - } - } else { - "-" - }, - Variables = variables[i], - Description = if (all(is.na(variables_names))) { - if (gsub("___.*$", "", variables[i]) %in% dic$field_name) { - trimws(gsub("<.*?>", "", dic[dic[, "field_name"] %in% gsub("___.*$", "", variables[i]), "field_label"])) - } else{ - "-" + unique(as.character(data[data$redcap_event_name %in% event | data$redcap_event_name.factor %in% event, "redcap_data_access_group.factor"])) } } else { - if (length(variables_names) == 1) { - variables_names + if (all(is.na(event))) { + unique(as.character(data[, "redcap_data_access_group"])) } else { - if (length(variables_names) == length(variables) & length(variables_names) > 1) { - variables_names[i] - } else { - if (length(variables_names) != length(variables) & length(variables_names) > 1) { - stop("Multiple variables names specified, but the number of names is different from the number of variables. Please match each variable to each name.", call. = F) - } - } - } - }, - Event = if (any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data)) & nrow(data) > 0) { - if ("redcap_event_name.factor" %in% names(data)) { - unique(as.character(data[, "redcap_event_name.factor"])) - } else { - unique(as.character(data[, "redcap_event_name"])) + unique(as.character(data[data$redcap_event_name %in% event | data$redcap_event_name.factor %in% event, "redcap_data_access_group"])) } + } + } else { + "-" + }, + Variables = variables[i], + Description = if (all(is.na(variables_names))) { + if (gsub("___.*$", "", variables[i]) %in% dic$field_name) { + trimws(gsub("<.*?>", "", dic[dic[, "field_name"] %in% gsub("___.*$", "", variables[i]), "field_label"])) } else { "-" - }, - Query = if (all(!is.na(query_name))) { - if (length(query_name) == 1) { - query_name + } + } else { + if (length(variables_names) == 1) { + variables_names + } else { + if (length(variables_names) == length(variables) & length(variables_names) > 1) { + variables_names[i] } else { - if (length(query_name) == length(variables) & length(query_name) > 1) { - query_name[i] - } else { - if (length(query_name) != length(variables) & length(query_name) > 1) { - stop("Multiple query names specified, but the number of query names is different from the number of variables. Please match each variable to each query name.", call. = F) - } + if (length(variables_names) != length(variables) & length(variables_names) > 1) { + stop("Multiple variables names specified, but the number of names is different from the number of variables. Please match each variable to each name.", call. = FALSE) } } + } + }, + Event = if (any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data)) & nrow(data) > 0) { + if ("redcap_event_name.factor" %in% names(data)) { + unique(as.character(data[, "redcap_event_name.factor"])) } else { - if (negate == TRUE) { - gsub(" ", " ", paste("The value should be", stringi::stri_replace_all_regex(gsub(" ", "", expression[i]), pattern=c("<", ">", ">=", "<=", "&", "\\|", "==", "!=", "%in%NA", "%in%", "%nin%", "is.na\\(\\)"), replacement=c(" less than ", " greater than ", " greater than or equal to ", " less than or equal to ", " and ", " or ", " equal to ", " not equal to ", " missing ", " equal to ", " not equal to ", " missing "), vectorize=FALSE))) + unique(as.character(data[, "redcap_event_name"])) + } + } else { + "-" + }, + Query = if (all(!is.na(query_name))) { + if (length(query_name) == 1) { + query_name + } else { + if (length(query_name) == length(variables) & length(query_name) > 1) { + query_name[i] } else { - gsub(" ", " ", paste("The value should not be", stringi::stri_replace_all_regex(gsub(" ", "", expression[i]), pattern=c("<", ">", ">=", "<=", "&", "\\|", "==", "!=", "%in%NA", "%in%", "%nin%", "is.na\\(\\)"), replacement=c(" less than ", " greater than ", " greater than or equal to ", " less than or equal to ", " and ", " or ", " equal to ", " not equal to ", " missing ", " equal to ", " not equal to ", " missing "), vectorize=FALSE))) + if (length(query_name) != length(variables) & length(query_name) > 1) { + stop("Multiple query names specified, but the number of query names is different from the number of variables. Please match each variable to each query name.", call. = FALSE) + } } - }, - stringsAsFactors = F - ) + } + } else { + if (negate == TRUE) { + gsub(" ", " ", paste("The value should be", stringi::stri_replace_all_regex(gsub(" ", "", expression[i]), pattern = c("<", ">", ">=", "<=", "&", "\\|", "==", "!=", "%in%NA", "%in%", "%nin%", "is.na\\(\\)"), replacement = c(" less than ", " greater than ", " greater than or equal to ", " less than or equal to ", " and ", " or ", " equal to ", " not equal to ", " missing ", " equal to ", " not equal to ", " missing "), vectorize = FALSE))) + } else { + gsub(" ", " ", paste("The value should not be", stringi::stri_replace_all_regex(gsub(" ", "", expression[i]), pattern = c("<", ">", ">=", "<=", "&", "\\|", "==", "!=", "%in%NA", "%in%", "%nin%", "is.na\\(\\)"), replacement = c(" less than ", " greater than ", " greater than or equal to ", " less than or equal to ", " and ", " or ", " equal to ", " not equal to ", " missing ", " equal to ", " not equal to ", " missing "), vectorize = FALSE))) + } + }, + stringsAsFactors = FALSE + ) |> + as.data.frame() - # Adding each variable with zero queries to the data frame - excel_zero <- rbind(excel_zero, excel) - } + # Adding each variable with zero queries to the data frame + excel_zero <- rbind(excel_zero, excel) } + } - ## Warnings about the variables with branching logic - if (!is.null(br_eval) & nrow(data) > 0) { - warning("The branching logic of the following variables can not be applied automatically:", paste0("\n- ", unique(br_eval)), "\nCheck the results element of the output(...$results) for details.", call. = FALSE) - } + # Warnings: variables where branching logic could not be applied automatically + if (!is.null(br_eval) & nrow(data) > 0) { + warning(stringr::str_glue("The branching logic for the following variables could not be applied automatically: {paste0('\n- ', unique(br_eval))}\nCheck the results element of the output(...$results) for details."), call. = FALSE) + } - if (!is.null(compatible)) { - if (length(compatible) > 1) { - sentence <- c("The branching logic of the following variables were applied automatically: ", paste0("\n- ", unique(compatible))) - } else { - sentence <- paste0("The branching logic of the following variable was applied automatically: ", unique(compatible)) - } - warning(sentence, call. = F) + # Report variables where branching logic was applied automatically + if (!is.null(compatible)) { + if (length(compatible) > 1) { + sentence <- stringr::str_glue("The branching logic of the following variables were applied automatically: {paste0('\n- ', unique(compatible), collapse = '')}") + } else { + sentence <- stringr::str_glue("The branching logic of the following variables were applied automatically: {unique(compatible)}") } + warning(sentence, call. = FALSE) + } - # If the argument 'addTo' is specified, combine the queries generated with a previous data frame of queries - if (all(!is.na(addTo))) { - - if ("Link" %in% names(addTo$queries)) { - col_names <- c(names(queries), "Link") - } else { - col_names <- names(queries) - } - - queries <- merge(queries, - addTo$queries, - by = intersect(names(addTo$queries), names(queries)), - all = TRUE) - queries <- queries %>% - dplyr::select(dplyr::all_of(col_names)) + # If 'addTo' argument is specified, merge previous queries + if (all(!is.na(addTo))) { + # Add 'Link' column if it exists in the addTo$queries data frame + if ("Link" %in% names(addTo$queries)) { + col_names <- c(names(queries), "Link") + } else { + col_names <- names(queries) } - # Classify each query with it's own code - if (nrow(queries) > 0) { - - # First we sort the data frame by record_id - if (all(grepl("-", queries$Identifier))) { - queries <- queries %>% - tidyr::separate("Identifier", c("center", "id"), sep = "([-])", remove = FALSE) - queries[, "center"] <- as.numeric(queries[, "center"]) - queries[, "id"] <- as.numeric(queries[, "id"]) - queries <- queries[order(queries[, "center"], queries[, "id"]), ] - rownames(queries) <- NULL - queries <- queries %>% dplyr::select(-"center", -"id") - } else { - queries$Identifier <- as.numeric(queries$Identifier) - queries <- queries[order(queries$Identifier), ] - } - - # Add the code to each query and eliminate duplicated ones - queries <- unique(queries %>% - dplyr::select(-"Code")) - queries <- data.frame(queries %>% - dplyr::group_by(.data$Identifier) %>% - dplyr::mutate(cod = 1:dplyr::n())) - queries$Code <- paste0(as.character(queries$Identifier), "-", queries$cod) - queries <- queries %>% dplyr::select(-"cod") - - # Reorder the columns if the link argument was specified - if ("Link" %in% names(queries)) { - queries <- queries %>% - dplyr::select("Identifier":"Query", "Code", "Link") - } + # Merge queries and add 'Link' if present + queries <- merge(queries, + addTo$queries, + by = intersect(names(addTo$queries), names(queries)), + all = TRUE + ) + queries <- queries |> + dplyr::select(dplyr::all_of(col_names)) + } - # Build the report - report <- data.frame("dag" = queries$DAG, - "var" = queries$Field, - "descr" = queries$Description, - "event" = queries$Event, - "query_descr" = gsub(" is .* it", "", queries$Query)) - - # If there is no previous report or variables names specified we convert the variables and their description to factors using the dictionary - if (all(addTo %in% NA & variables_names %in% NA)) { - report$var <- factor(report$var, - levels = c(unique(variables))) - report$descr <- factor(report$descr, - levels = c(unique(trimws(gsub("<.*?>", "", dic$field_label[dic$field_name %in% gsub("___.*$", "", variables)]))))) - - # If our project has events, we also convert them to factors - if (any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { - report$event <- factor(report$event, - levels = if("redcap_event_name.factor" %in% names(data)) { - unique(as.character(data$redcap_event_name.factor)) - } else { - unique(as.character(data$redcap_event_name)) - }) - } - } + # Classify each query with its own code + if (nrow(queries) > 0) { + # Sort data by record ID + if (all(grepl("-", queries$Identifier))) { + queries <- queries |> + tidyr::separate("Identifier", c("center", "id"), sep = "([-])", remove = FALSE) + queries[, "center"] <- as.numeric(queries[, "center"]) + queries[, "id"] <- as.numeric(queries[, "id"]) + queries <- queries[order(queries[, "center"], queries[, "id"]), ] + rownames(queries) <- NULL + queries <- queries |> dplyr::select(-"center", -"id") + } else { + queries$Identifier <- as.numeric(queries$Identifier) + queries <- queries[order(queries$Identifier), ] + } - # If there is no previous report but the variables names argument is specified we convert the variables and their description to factors using the selected names - if (all(addTo %in% NA & !is.na(variables_names))) { - report$var <- factor(report$var, - levels = c(unique(variables))) - report$descr <- factor(report$descr, - levels = c(unique(variables_names))) - - # If our project has events, we also convert them to factors - if (any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { - report$event <- factor(report$event, - levels = if("redcap_event_name.factor" %in% names(data)) { - unique(as.character(data$redcap_event_name.factor)) - } else { - unique(as.character(data$redcap_event_name)) - }) - } + # Remove duplicates and add code for each query + queries <- unique(queries |> + dplyr::select(-"Code")) + queries <- data.frame(queries |> + dplyr::group_by(.data$Identifier) |> + dplyr::mutate(cod = 1:dplyr::n())) + queries$Code <- paste0(as.character(queries$Identifier), "-", queries$cod) + queries <- queries |> dplyr::select(-"cod") + + # Reorder columns if 'Link' was included + if ("Link" %in% names(queries)) { + queries <- queries |> + dplyr::select("Identifier":"Query", "Code", "Link") + } + # Build the report + report <- data.frame( + "dag" = queries$DAG, + "var" = queries$Field, + "descr" = queries$Description, + "event" = queries$Event, + "query_descr" = gsub(" is .* it", "", queries$Query) + ) + + # Convert variables and descriptions to factors if necessary + if (all(addTo %in% NA & variables_names %in% NA)) { + report$var <- factor(report$var, + levels = c(unique(variables)) + ) + report$descr <- factor(report$descr, + levels = c(unique(trimws(gsub("<.*?>", "", dic$field_label[dic$field_name %in% gsub("___.*$", "", variables)])))) + ) + + # If the project has events, convert them to factors + if (any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { + report$event <- factor(report$event, + levels = if ("redcap_event_name.factor" %in% names(data)) { + unique(as.character(data$redcap_event_name.factor)) + } else { + unique(as.character(data$redcap_event_name)) + } + ) } + } + # Handle cases where only variable names are specified + if (all(addTo %in% NA & !is.na(variables_names))) { + report$var <- factor(report$var, + levels = c(unique(variables)) + ) + report$descr <- factor(report$descr, + levels = c(unique(variables_names)) + ) - # Report of all variables (including the ones with zero queries) - if (report_zeros == TRUE) { - - # Total number of queries by variable, event and DAG - report <- report %>% - dplyr::group_by(.data$dag, .data$var, .data$event, .data$query_descr, .drop = FALSE) %>% - dplyr::summarise("total" = dplyr::n(), .groups = "keep") - - # Adding the description and query description to the variables with 0 queries - if (any(report$total %in% 0)) { - - # Add the query description - report$var_event <- paste0(report$var, "_", report$event) - complete_vars <- unique(as.character(report$var_event[report$total != 0])) - zero_vars <- unique(as.character(report$var_event[!report$var_event %in% complete_vars])) - report <- report %>% - dplyr::filter((.data$var_event %in% complete_vars & .data$total != 0) | .data$var_event %in% zero_vars) - - for (i in zero_vars) { - report$query_descr[report$var_event %in% i] <- paste0("The value should not be ", - stringi::stri_replace_all_regex(gsub(" ", "", expression[which(variables %in% report$var[which(report$var_event %in% i)])]), pattern=c("<", ">", ">=", "<=", "&", "\\|", "==", "!=", "%in%NA", "%in%", "%nin%", "is.na\\(\\)"), replacement=c(" less than ", " greater than ", " greater than or equal to ", " less than or equal to ", " and ", " or ", " equal to ", " not equal to ", " missing ", " equal to ", " not equal to ", " missing "), vectorize=FALSE)) + # If our project has events, we also convert them to factors + if (any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data))) { + report$event <- factor(report$event, + levels = if ("redcap_event_name.factor" %in% names(data)) { + unique(as.character(data$redcap_event_name.factor)) + } else { + unique(as.character(data$redcap_event_name)) } + ) + } + } - report <- report %>% dplyr::select(- "var_event") - - # Add the variables description - report$descr <- purrr::map_chr(gsub("___.*$","",report$var), function(x){ - if (x %in% dic$field_name){ - - # Truncate description name if it exceeds 50 characters - name <- gsub("<.*?>", "", dic$field_label[dic$field_name %in% x]) - stringr::str_trunc(name, 50) - } else { - "-" - }}) + # Handle variables with zero queries + if (report_zeros == TRUE) { + # Total number of queries by variable, event and DAG + report <- report |> + dplyr::group_by(.data$dag, .data$var, .data$event, .data$query_descr, .drop = FALSE) |> + dplyr::summarise("total" = dplyr::n(), .groups = "keep") + + # Add query description for variables with zero queries + if (any(report$total %in% 0)) { + # Add the query description + report$var_event <- paste0(report$var, "_", report$event) + complete_vars <- unique(as.character(report$var_event[report$total != 0])) + zero_vars <- unique(as.character(report$var_event[!report$var_event %in% complete_vars])) + report <- report |> + dplyr::filter((.data$var_event %in% complete_vars & .data$total != 0) | .data$var_event %in% zero_vars) + + for (i in zero_vars) { + report$query_descr[report$var_event %in% i] <- paste0( + "The value should not be ", + stringi::stri_replace_all_regex(gsub(" ", "", expression[which(variables %in% report$var[which(report$var_event %in% i)])]), pattern = c("<", ">", ">=", "<=", "&", "\\|", "==", "!=", "%in%NA", "%in%", "%nin%", "is.na\\(\\)"), replacement = c(" less than ", " greater than ", " greater than or equal to ", " less than or equal to ", " and ", " or ", " equal to ", " not equal to ", " missing ", " equal to ", " not equal to ", " missing "), vectorize = FALSE) + ) } - } else { - # Report of the variables with identified queries (eliminating the ones with zero queries) - report <- report %>% - dplyr::group_by(.data$var, .data$descr, .data$event, .data$query_descr, .data$dag, .drop = TRUE) %>% - dplyr::summarise("total" = dplyr::n(), .groups = "keep") %>% - dplyr::filter("total" != 0) + report <- report |> dplyr::select(-"var_event") + # Add the variables description + report$descr <- purrr::map_chr(gsub("___.*$", "", report$var), function(x) { + if (x %in% dic$field_name) { + # Truncate description name if it exceeds 50 characters + name <- gsub("<.*?>", "", dic$field_label[dic$field_name %in% x]) + stringr::str_trunc(name, 50) + } else { + "-" + } + }) } + } else { + # Report of the variables with identified queries (eliminating the ones with zero queries) + report <- report |> + dplyr::group_by(.data$var, .data$descr, .data$event, .data$query_descr, .data$dag, .drop = TRUE) |> + dplyr::summarise("total" = dplyr::n(), .groups = "keep") |> + dplyr::filter("total" != 0) + } - # Truncate variable name if it exceeds 26 characters - report$descr <- as.character(report$descr) - report$descr <- stringr::str_trunc(report$descr, 50) - - # Truncate variable name if it exceeds 26 characters - report$var <- as.character(report$var) - report$var <- stringr::str_trunc(report$var, 26) + # Truncate descriptions and variable names if too long + report$descr <- as.character(report$descr) + report$descr <- stringr::str_trunc(report$descr, 50) + + report$var <- as.character(report$var) + report$var <- stringr::str_trunc(report$var, 26) + + # Sort the report by the total number of queries + report <- as.data.frame(report) + report <- report[order(as.numeric(report$total), decreasing = TRUE), ] + + # Reorder columns and prepare the final report for output + report <- report |> dplyr::select("dag", "var", "descr", "event", "query_descr", "total") + names(report) <- c("DAG", "Variables", "Description", "Event", "Query", "Total") + report[, "Query"] <- gsub("&", " & ", gsub("\\|", " \\| ", report[, "Query"])) + rownames(report) <- NULL + } else { + # If no queries identified, return a report with zero queries + if (nrow(data) > 0) { + message("No queries were identified in the dataset.") + } - # Sorting by the total number of queries - report <- as.data.frame(report) - report <- report[order(as.numeric(report$total), decreasing = TRUE), ] + report <- excel_zero + report$Total <- 0 + rownames(report) <- NULL + } - # Arrange the report - report <- report %>% dplyr::select("dag", "var", "descr", "event", "query_descr", "total") - names(report) <- c("DAG", "Variables", "Description", "Event", "Query", "Total") - report[, "Query"] <- gsub("&", " & ", gsub("\\|", " \\| ", report[, "Query"])) - rownames(report) <- NULL + # Handle report title + if (all(is.na(report_title))) { + report_title <- "Report of queries" + } else { + if (length(report_title) > 1) { + stop("Multiple report titles found. Please specify only one.", call. = FALSE) + } + } - } else { - # If there is none query, the function still creates a report containing all selected variables. + # Add branching logic information to the report if applicable + if (length(var_logic) > 0 & (!is.null(logics) | is.null(event_form)) & (!is.null(br_eval) | any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data)))) { + # Truncate variable names to ensure they don't exceed 26 characters + branch0$Variable <- stringr::str_trunc(branch0$Variable, 26) - # Message: if there is none query to be identified - if (nrow(data) > 0) { - message("There is no query to be identified in the dataset.") - } + # Merge branching logic into the report + report <- merge(report, + branch0 |> dplyr::select("Variable", "Branching logic"), + by.x = "Variables", by.y = "Variable", all.x = TRUE + ) - report <- excel_zero - report$Total <- 0 - rownames(report) <- NULL - } + # Replace NA values in "Branching logic" with a placeholder "-" + report[, "Branching logic"] <- stringr::str_replace_na(report[, "Branching logic"], "-") + } - # Before starting we check if there is more than one report_title and if it isn't the case we stabilish the caption for the report_title - if (all(is.na(report_title))) { - report_title <- "Report of queries" - } else { - if (length(report_title) > 1) { - stop("There is more than one title for the report, please choose only one.", call. = FALSE) - } + # Reorder the report by descending total count + report <- report |> + dplyr::arrange(dplyr::desc(.data$Total)) + + # Handle the case where the 'by_dag' argument is TRUE + if (by_dag %in% TRUE) { + report[is.na(report)] <- "-" + report_dag <- split(report, f = report$DAG) + + # Build individual reports for each DAG + for (i in seq_along(report_dag)) { + report_dag[[i]] <- report_dag[[i]] |> + dplyr::select("DAG", names(report)) + + # Create HTML table for each DAG with proper styling and caption + report_dag[[i]] <- knitr::kable(report_dag[[i]], + align = "ccccc", + row.names = FALSE, + caption = report_title, + format = "html", + longtable = TRUE + ) + report_dag[[i]] <- kableExtra::kable_styling(report_dag[[i]], + bootstrap_options = c("striped", "condensed"), + full_width = FALSE + ) + report_dag[[i]] <- kableExtra::row_spec(report_dag[[i]], 0, + italic = FALSE, + extra_css = "border-bottom: 1px solid grey" + ) } - # Adding information about the variables with branching logic to the report + # Prepare final output in the 'by_dag' format + def <- list( + queries = split(queries, f = queries$DAG), + results = report_dag + ) + } else { + # Handle case when 'by_dag' argument is FALSE + # Ensure branching logic is retained if applicable if (length(var_logic) > 0 & (!is.null(logics) | is.null(event_form)) & (!is.null(br_eval) | any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data)))) { - branch0$Variable <- stringr::str_trunc(branch0$Variable, 26) - report <- merge(report, - branch0 %>% dplyr::select("Variable", "Branching logic"), - by.x = "Variables", by.y = "Variable", all.x = TRUE) - report[, "Branching logic"] <- stringr::str_replace_na(report[, "Branching logic"], "-") - } - - # Reorder the report - report <- report %>% - dplyr::arrange(dplyr::desc(.data$Total)) - - # Report in case the by_dag argument is true - if (by_dag %in% TRUE) { - report[is.na(report)] <- "-" - report_dag <- split(report, f = report$DAG) - - # Build structure of each report in order to appear in the RStudio Viewer tab - for (i in 1:length(report_dag)) { - report_dag[[i]] <- report_dag[[i]] %>% - dplyr::select("DAG", names(report)) - report_dag[[i]] <- knitr::kable(report_dag[[i]], - align = "ccccc", - row.names = FALSE, - caption = report_title, - format = "html", - longtable = TRUE) - report_dag[[i]] <- kableExtra::kable_styling(report_dag[[i]], - bootstrap_options = c("striped", "condensed"), - full_width = FALSE) - report_dag[[i]] <- kableExtra::row_spec(report_dag[[i]], 0, - italic = FALSE, - extra_css = "border-bottom: 1px solid grey") - } - - # Definitive output - def <- list(queries = split(queries, f = queries$DAG), - results = report_dag) - + report <- report |> + dplyr::select(-"DAG") |> + dplyr::group_by(.data$Variables, .data$Description, .data$Event, .data$Query, .data$`Branching logic`, .drop = FALSE) |> + dplyr::summarise("Total" = sum(.data$Total), .groups = "keep") |> + dplyr::select("Variables", "Description", "Event", "Query", "Total", "Branching logic") } else { + report <- report |> + dplyr::select(-"DAG") |> + dplyr::group_by(.data$Variables, .data$Description, .data$Event, .data$Query, .drop = FALSE) |> + dplyr::summarise("Total" = sum(.data$Total), .groups = "keep") + } - # If by_dag argument is false - # If there is a branching logic, we cannot lose the branching logic column - if (length(var_logic) > 0 & (!is.null(logics) | is.null(event_form)) & (!is.null(br_eval) | any(c("redcap_event_name", "redcap_event_name.factor") %in% names(data)))) { - - report <- report %>% - dplyr::select(-"DAG") %>% - dplyr::group_by(.data$Variables, .data$Description, .data$Event, .data$Query, .data$`Branching logic`, .drop = FALSE) %>% - dplyr::summarise("Total" = sum(.data$Total), .groups = "keep") %>% - dplyr::select("Variables", "Description", "Event", "Query", "Total", "Branching logic") + # If report_zeros is TRUE, handle zero total values + if (any(!report$Total %in% 0)) { + if (report_zeros == TRUE) { + report <- report |> + dplyr::arrange(dplyr::desc(.data$Total)) + # Print queries with zero totals (if any) + report$Query[report$Total %in% 0] } else { - - report <- report %>% - dplyr::select(-"DAG") %>% - dplyr::group_by(.data$Variables, .data$Description, .data$Event, .data$Query, .drop = FALSE) %>% - dplyr::summarise("Total" = sum(.data$Total), .groups = "keep") - - } - - if (any(!report$Total %in% 0)) { - if (report_zeros == TRUE) { - - report <- report %>% - dplyr::arrange(dplyr::desc(.data$Total)) - - report$Query[report$Total %in% 0] - - } else { - - report <- report %>% - dplyr::arrange(dplyr::desc(.data$Total)) %>% - dplyr::filter(.data$Total != 0) - - } + report <- report |> + dplyr::arrange(dplyr::desc(.data$Total)) |> + dplyr::filter(.data$Total != 0) } - - report[is.na(report)] <- "-" - - # Build structure of each report in order to appear in the RStudio Viewer tab - result <- knitr::kable(report, "pipe", - align = "ccccc", - caption = report_title) - viewer <- knitr::kable(report, - align = "ccccc", - row.names = FALSE, - caption = report_title, - format = "html", - longtable = TRUE) - viewer <- kableExtra::kable_styling(viewer, - bootstrap_options = c("striped", "condensed"), - full_width = FALSE) - viewer <- kableExtra::row_spec(viewer, 0, - italic = FALSE, - extra_css = "border-bottom: 1px solid grey") - - # Definitive output - def <- list(queries = dplyr::tibble(queries), - results = viewer) } - # Return the final product - def + # Replace NAs with "-" in the report + report[is.na(report)] <- "-" + + # Generate and style the HTML table for the report + result <- knitr::kable(report, "pipe", + align = "ccccc", + caption = report_title + ) + viewer <- knitr::kable(report, + align = "ccccc", + row.names = FALSE, + caption = report_title, + format = "html", + longtable = TRUE + ) + viewer <- kableExtra::kable_styling(viewer, + bootstrap_options = c("striped", "condensed"), + full_width = FALSE + ) + viewer <- kableExtra::row_spec(viewer, 0, + italic = FALSE, + extra_css = "border-bottom: 1px solid grey" + ) + + # Prepare final output without DAG-specific split + def <- list( + queries = dplyr::tibble(queries), + results = viewer + ) } - + # Return the final report output + def +} diff --git a/R/rd_recalculate.R b/R/rd_recalculate.R new file mode 100644 index 0000000..9d08bde --- /dev/null +++ b/R/rd_recalculate.R @@ -0,0 +1,253 @@ +#' Recalculate and Verify Calculated Fields in REDCap Data +#' +#' @description +#' `r lifecycle::badge('experimental')` +#' +#' Recalculates fields marked as calculated in the REDCap dictionary, compares them with the original values, and reports discrepancies. If any differences are found, new recalculated fields are added to the dataset and dictionary with `_recalc` appended to the names. +#' +#' @param project A list containing the REDCap data, dictionary, and event mapping (expected `redcap_data()` output). Overrides `data`, `dic`, and `event_form`. +#' @param data A `data.frame` or `tibble` with the REDCap dataset. +#' @param dic A `data.frame` with the REDCap dictionary. +#' @param event_form Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects. +#' @param exclude Optional. Character vector of field names to exclude from recalculation. +#' +#' @details +#' * Fields of type `calc` in the dictionary are recalculated. +#' * Recalculated values are compared with the original values. +#' * If differences exist, new fields `[field_name]_recalc` are added to the dataset and dictionary. +#' * Works for single-event projects; for longitudinal projects, `event_form` must be provided. +#' * Fields with incomplete branching logic or smart variables may fail to recalculate. +#' +#' @return A list with: +#' \describe{ +#' \item{data}{The dataset with new `_recalc` fields for any differing calculated fields.} +#' \item{dictionary}{Updated dictionary including the new `_recalc` fields.} +#' \item{event_form}{The `event_form` passed in (if applicable).} +#' \item{results}{Summary report of the recalculation process, including tables of discrepancies.} +#' } +#' +#' @examples +#' # Recalculate all calculated fields +#' \dontrun{ +#' results <- rd_recalculate( +#' data = covican$data, +#' dic = covican$dictionary, +#' event_form = covican$event_form +#' ) +#' } +#' +#' # Recalculate but exclude some variables +#' \dontrun{ +#' results <- rd_recalculate( +#' project = covican, +#' exclude = c("age", "screening_fail_crit") +#' ) +#' } +#' +#' @export +#' @importFrom rlang := +#' @importFrom stats na.omit + +rd_recalculate <- function(project = NULL, data = NULL, dic = NULL, event_form = NULL, exclude = NULL) { + results <- NULL + + # Handle potential overwriting when both `project` and other arguments are provided + if (!is.null(project)) { + env_vars <- check_proj(project, data, dic, event_form) + + list2env(env_vars, envir = environment()) + } + + # Ensure both `data` and `dic` are provided; stop if either is missing + if (is.null(data) | is.null(dic)) { + stop("Both `data` and `dic` (data and dictionary) arguments must be provided.") + } + + # Extract labels from the data to reapply later + labels <- labels <- purrr::map_chr(data, function(x) { + lab <- attr(x, "label") + if (!is.null(lab)) { + lab + } else { + "" + } + }) + + + # Identify if the project is longitudinal or includes repeated instruments + longitudinal <- "redcap_event_name" %in% names(data) + repeat_instrument <- "redcap_repeat_instrument" %in% names(data) && any(!is.na(data$redcap_repeat_instrument)) + + # Check if there are datetime variables stored as characters in the dataset + vars_date <- dic |> + dplyr::filter(grepl("^date_|^datetime_", .data$text_validation_type_or_show_slider_number)) |> + dplyr::pull(.data$field_name) + + # Warn if datetime variables need transformation + if (any(purrr::map(data |> dplyr::select(dplyr::all_of(vars_date)), class) == "character")) { + warning("The dataset contains date fields stored as character class, which may lead to incorrect or inconsistent date transcription results. Use the `rd_dates` function before this one to properly format these date fields.", call. = FALSE) + } + + # Proceed only if the project is not longitudinal or has event-form mapping, and is not repeated + if (!(longitudinal & is.null(event_form)) & !repeat_instrument) { + # Replace `NA` in branching logic fields with empty strings + if (any(is.na(dic$branching_logic_show_field_only_if))) { + dic <- dic |> + dplyr::mutate(branching_logic_show_field_only_if = dplyr::case_when( + is.na(branching_logic_show_field_only_if) ~ "", + .default = .data$branching_logic_show_field_only_if + )) + } + + + # Redefine rounding function to avoid issues in special cases + # round <- function(x, digits) { + # posneg <- sign(x) + # z <- abs(x)*10^digits + # z <- z + 0.5 + sqrt(.Machine$double.eps) + # z <- trunc(z) + # z <- z / 10 ^ digits + # z*posneg + # } + + # Process calculated fields: evaluate, transcribe logic, and compare results + calc <- tibble::tibble(dic) |> + dplyr::filter(.data$field_type == "calc", !.data$field_name %in% exclude) |> + dplyr::mutate( + calc = purrr::map(.data$field_name, function(x) { + val <- data[, x] + if (is.numeric(val)) { + as.numeric(val) + } else { + val + } + }), + rlogic = purrr::map2(.data$choices_calculations_or_slider_labels, .data$field_name, function(x, y) { + rlogic <- try(suppressWarnings(rd_rlogic(data = data, dic = dic, event_form = event_form, logic = x, var = y)), silent = TRUE) + if (!inherits(rlogic, "try-error")) { + rlogic + } else { + NULL + } + }), + trans = purrr::map_chr(.data$rlogic, function(x) { + if (!is.null(x)) { + x$rlogic + } else { + NA + } + }), + recalc = purrr::map(.data$rlogic, function(x) { + if (!is.null(x)) { + x$eval + } else { + NULL + } + }), + is_equal = purrr::map2_lgl(.data$calc, .data$recalc, function(x, y) { + if (!is.null(y)) { + if (is.numeric(x) & is.numeric(y)) { + identical(round(x, 3), round(y, 3)) + } else if (all(is.na(x)) & all(is.na(y))) { + TRUE + } else { + identical(x, y) + } + } else { + NA + } + }) + ) |> + dplyr::select(-"rlogic") + + + # Add recalculated fields to the dataset and dictionary + calc_change <- calc |> + dplyr::filter(!is.na(.data$trans) & !.data$is_equal) + + if (nrow(calc_change) > 0) { + for (i in seq_len(nrow(calc_change))) { + name <- stringr::str_glue("{calc_change$field_name[i]}_recalc") + + data <- data |> + tibble::add_column("{name}" := calc_change$recalc[[i]], .after = as.character(calc_change$field_name[i])) + + add_row <- dic |> + dplyr::filter(.data$field_name == calc_change$field_name[i]) |> + dplyr::mutate( + field_name = stringr::str_glue("{field_name}_recalc"), + field_label = stringr::str_glue("{field_label} (Recalculate)") + ) + + pos <- which(dic$field_name == calc_change$field_name[i]) + + dic <- dic |> tibble::add_row(!!!as.list(add_row), .after = pos) + } + } + + # Reapply labels to the modified dataset + data <- data |> + labelled::set_variable_labels(.labels = labels |> as.list(), .strict = FALSE) + + # Update results with this transformation + if (is.null(results)) { + results <- c(results, stringr::str_glue("Recalculating calculated fields and saving them as '[field_name]_recalc'. (rd_recalculate)\n")) + } else { + + if(grepl("^[A-Z]", results[1])) { + results[1] <- paste("1.", results[1]) + } + + last_val_res <- results |> + stringr::str_extract("^(\n)?\\d+\\.") |> + na.omit() |> + dplyr::last() |> + stringr::str_remove("\\.") |> + as.numeric() + + results <- c(results, stringr::str_glue("\n\n{last_val_res + 1}. Recalculating calculated fields and saving them as '[field_name]_recalc'. (rd_recalculate)\n")) + } + + # Generate a summary report + report1 <- calc |> + dplyr::mutate(n = 1) |> + dplyr::summarise( + trans = sum(!is.na(.data$trans)), + N = sum(.data$n), + no_trans = .data$N - .data$trans, + no_equal = sum(!.data$is_equal, na.rm = TRUE), + ) |> + dplyr::mutate( + text1 = stringr::str_glue("{no_trans} ({round(no_trans*100/N, 2)}%)"), + text2 = stringr::str_glue("{no_equal} ({round(no_equal*100/trans, 2)}%)") + ) |> + dplyr::select("Total calculated fields" = "N", "Non-transcribed fields" = "text1", "Recalculated different fields" = "text2") + + results <- c(results, "\n", knitr::kable(report1, "pipe", align = "ccc")) + + # Create a detailed field-level report + report2 <- calc |> + dplyr::mutate(trans2 = ifelse(!is.na(.data$trans), "Yes", "No")) |> + dplyr::arrange(.data$trans2, .data$is_equal) |> + dplyr::select("field_name", "Transcribed?" = "trans2", "Is equal?" = "is_equal") + + results <- c(results, "\n", knitr::kable(report2, "pipe", align = "ccc")) + + results <- stringr::str_glue("{results}") + } else { + # Stop if recalculation is not possible due to missing event-form mapping in longitudinal projects + stop( + "\nRecalculation cannot proceed because the project has more than one event, but the event-form correspondence has not been provided. Please specify the event-form mapping for accurate recalculation.\n", + call. = FALSE + ) + } + + # Return updated datasets and results + list( + data = data, + dictionary = dic, + event_form = event_form, + results = stringr::str_glue("{results}") + ) |> + purrr::compact() # Remove any NULL elements from the output list +} diff --git a/R/rd_rlogic.R b/R/rd_rlogic.R index 270a984..0e2e84f 100644 --- a/R/rd_rlogic.R +++ b/R/rd_rlogic.R @@ -1,269 +1,333 @@ #' Translate REDCap Logic to R Logic #' -#' This function allows you to convert REDCap logic into R logic. WARNING: Please note that if the REDCap logic involves smart variables, this function may not be able to transform it accurately. +#' @description +#' `r lifecycle::badge('stable')` +#' +#' Converts a REDCap logic expression into R-compatible logic. Processes one logic expression (`logic`) for one target variable (`var`) at a time. Supports common REDCap operators (`and`, `or`, `=`, `<`, `>`, etc.) and handles event-specific logic in longitudinal projects. Logic involving smart variables or repeated instruments may require manual review. +#' +#' @param project A list containing the REDCap data, dictionary, and event mapping (expected `redcap_data()` output). Overrides `data`, `dic`, and `event_form`. +#' @param data A `data.frame` or `tibble` with the REDCap dataset. +#' @param dic A `data.frame` with the REDCap dictionary. +#' @param event_form Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects. +#' @param logic A single REDCap logic string (e.g., `"if([exc_1]='1' or [inc_1]='0', 1, 0)"`). +#' @param var A single string specifying the target variable the logic applies to. +#' +#' @details +#' * Translates REDCap operators and functions into R equivalents: +#' - `=` → `==`, `<>` → `!=`, `and` → `&`, `or` → `|`. +#' - Converts functions like `if()`, `rounddown()`, `datediff()`, `sum()` to R equivalents. +#' * Handles date transformations and empty strings (`''`) → `NA`. +#' * Adjusts logic for longitudinal data using `event_form` if provided. +#' * Evaluates the translated R logic against the dataset and returns the results. +#' * Logic with repeated instruments, smart variables, or multiple events per variable may require manual inspection. +#' +#' @return A list with: +#' \describe{ +#' \item{rlogic}{The translated R-compatible logic as a string.} +#' \item{eval}{The evaluation of the translated logic on the provided dataset, filtered by event if applicable.} +#' } #' -#' @param ... List containing the data, dictionary and event mapping (if applicable) of the REDCap project. This should be the output of the `redcap_data` function. -#' @param data Data frame containing data from REDCap. If the list is specified, this argument is not required. -#' @param dic Data frame containing the dictionary read from REDCap. If the list is specified, this argument is not required. -#' @param event_form Data frame containing the correspondence of each event with each form. If the list is specified, this argument is not required. -#' @param logic String containing logic in REDCap format. -#' @param var String with the name of the variable containing the logic. -#' @return List containing the logic in R format and its evaluation. #' @examples -#' rd_rlogic(covican, -#' logic = "if([exc_1]='1' or [inc_1]='0' or [inc_2]='0' or [inc_3]='0',1,0)", -#' var = "screening_fail_crit") +#' # Translate a single REDCap logic expression for one variable +#' covican |> +#' rd_rlogic( +#' logic = "if([exc_1]='1' or [inc_1]='0' or [inc_2]='0' or [inc_3]='0', 1, 0)", +#' var = "screening_fail_crit" +#' ) +#' #' @export -rd_rlogic <- function(..., data = NULL, dic = NULL, event_form = NULL, logic, var){ +rd_rlogic <- function(project = NULL, data = NULL, dic = NULL, event_form = NULL, logic, var) { - project <- c(...) + # Handle potential overwriting when both `project` and other arguments are provided + if (!is.null(project)) { + env_vars <- check_proj(project, data, dic, event_form) - if(!is.null(project)){ - if(!is.null(data)){ - warning("Data has been specified twice so the function will not use the information in the data argument.") - } - - if(!is.null(dic)){ - warning("Dictionary has been specified twice so the function will not use the information in the dic argument.") - } - - data <- project$data - dic <- project$dictionary - - if("event_form" %in% names(project)){ - if(!is.null(event_form)){ - warning("Event has been specified twice so the function will not use the information in the event_form argument.") - } - event_form <- project$event_form - } + list2env(env_vars, envir = environment()) } - if(is.null(data) | is.null(dic)){ - stop("No data/dictionary was provided") + # Ensure both `data` and `dic` are provided; stop if either is missing + if (is.null(data) | is.null(dic)) { + stop("Both `data` and `dic` (data and dictionary) arguments must be provided.") } - #Check if the project is longitudinal (has more than one event) or not: + # Check if the project is longitudinal (more than one event present in the data) longitudinal <- ifelse("redcap_event_name" %in% names(data), TRUE, FALSE) - if(is.null(event_form) & longitudinal){ - stop("There is more than one event in the data and the event-form correspondence hasn't been specified") + # Check for repeated instruments + repeat_instrument <- "redcap_repeat_instrument" %in% names(data) && any(!is.na(data$redcap_repeat_instrument)) + + # Error: data is longitudinal, but event_form isn't provided + if (is.null(event_form) & longitudinal) { + stop("There is more than one event in the data, but the event-form correspondence hasn't been specified.") } - rlogic <- logic + # If user accidentally passes multiple logic expressions or multiple vars + if (length(logic) > 1) { + warning("`logic` contains more than one expression; rd_rlogic processes only one logic at a time. Using the first element.", call. = FALSE) + logic <- logic[[1]] + } + if (length(var) > 1) { + warning("`var` contains more than one variable name; rd_rlogic processes only one variable at a time. Using the first element.", call. = FALSE) + var <- var[[1]] + } - #We look first if there is some checkbox evaluated in the logic - if(grepl("\\)\\]",rlogic)){ - num_vars <- stringr::str_count(rlogic,"]") - for(i in 1:num_vars){ - rlogic <- gsub("\\[(.+)\\((\\d+)\\)\\]","[\\1___\\2]",rlogic) + rlogic <- logic # Initialize REDCap logic to be converted + + # Process checkboxes and other specific cases in REDCap logic + if (grepl("\\)\\]", rlogic)) { + num_vars <- stringr::str_count(rlogic, "]") + for (i in 1:num_vars) { + rlogic <- gsub("\\[(.+)\\((\\d+)\\)\\]", "[\\1___\\2]", rlogic) } } - #If we find [event-name][var] is the same as [var] - #If we find [var][current-instance] is the same as [var] - rlogic <- gsub("\\[event\\-name\\]\\[","[", rlogic) + # Modify event-name and current-instance occurrences + rlogic <- gsub("\\[event\\-name\\]\\[", "[", rlogic) rlogic <- gsub("\\]\\[current-instance\\]", "]", rlogic) - #Change event-name, user-dag-name, record-dag-name - rlogic <- gsub("\\[event\\-name\\]","[redcap_event_name]", rlogic) - rlogic <- gsub("\\[user\\-dag\\-name\\]","[redcap_data_access_group]", rlogic) - rlogic <- gsub("\\[record\\-dag\\-name\\]","[redcap_data_access_group]", rlogic) - - #Get the variables that are being evaluated + # Update REDCap specific variable names + rlogic <- gsub("\\[event\\-name\\]", "[redcap_event_name]", rlogic) + rlogic <- gsub("\\[user\\-dag\\-name\\]", "[redcap_data_access_group]", rlogic) + rlogic <- gsub("\\[record\\-dag\\-name\\]", "[redcap_data_access_group]", rlogic) - #Get all variables evaluated + # Get the variables evaluated in the REDCap logic rlogic_var <- unlist(stringr::str_extract_all(rlogic, "\\[[\\w,\\-]+\\]")) + rlogic_var <- gsub("^\\[|\\]$", "", rlogic_var) - #Check if each variable is present in the data or it's one of the events - if(longitudinal){ - check_lgl <- purrr::map_lgl(rlogic_var,function(x){ - out <- gsub("^\\[","",x) - out <- gsub("\\]$","",out) - out%in%names(data) | out%in%data$redcap_event_name - }) - }else{ - check_lgl <- purrr::map_lgl(rlogic_var,function(x){ - out <- gsub("^\\[","",x) - out <- gsub("\\]$","",out) - out%in%names(data) - }) + # Check if the variables are present in the data or events + if (longitudinal) { + check_lgl <- rlogic_var %in% names(data) | rlogic_var %in% data$redcap_event_name + } else { + check_lgl <- rlogic_var %in% names(data) } - #If there are some that are not in the dataframe it will give an error - - if(any(!check_lgl)){ - - stop("Redcap logic contains some redcap variable that it isn't found in the database (it can be a smart-variable)") - - }else{ - - #If all the variables are contained in the data we can transcribe the redcap logic to r logic - #When in redcap we had " now we have \". Change "" to '': - rlogic <- gsub('"', "'", rlogic) - - - #Change the redcap functions into r functions - rlogic <- gsub("if\\s?\\(", "ifelse(", rlogic) - rlogic <- gsub("rounddown(.*),0\\)", "floor\\1)", rlogic) - rlogic <- gsub("rounddown(.*),1\\)", "round\\1, 1)", rlogic) - rlogic <- gsub("rounddown(.*),2\\)", "round\\1, 2)", rlogic) - rlogic <- gsub("rounddown(.*),3\\)", "round\\1, 3)", rlogic) - rlogic <- gsub("rounddown(.*)\\)", "floor\\1)", rlogic) - rlogic <- gsub("datediff\\s?", "lubridate::time_length(lubridate::interval", rlogic) - rlogic <- gsub("sum\\((.*?)\\)","rowSums(cbind(\\1))", rlogic) - #Change dates (there can be dates specified in the logic) to date format - if(grepl("'dmy'", rlogic)){ - rlogic <- gsub("'(\\d\\d-\\d\\d-\\d\\d\\d\\d)'", "lubridate::dmy('\\1')", rlogic) - }else if(grepl("'mdy'", rlogic)){ - rlogic <- gsub("'(\\d\\d-\\d\\d-\\d\\d\\d\\d)'", "lubridate::mdy('\\1')", rlogic) - }else if(grepl("'ymd'", rlogic)){ - rlogic <- gsub("'(\\d\\d\\d\\d-\\d\\d-\\d\\d)'", "lubridate::ymd('\\1')", rlogic) - }else if(grepl("'ydm'", rlogic)){ - rlogic <- gsub("'(\\d\\d\\d\\d-\\d\\d-\\d\\d)'", "lubridate::ydm('\\1')", rlogic) - }else if(grepl("'myd'", rlogic)){ - rlogic <- gsub("'(\\d\\d-\\d\\d\\d\\d-\\d\\d)'", "lubridate::myd('\\1')", rlogic) - }else if(grepl("'dym'", rlogic)){ - rlogic <- gsub("'(\\d\\d-\\d\\d\\d\\d-\\d\\d)'", "lubridate::dym('\\1')", rlogic) + # Error: one of the variables is in a repeated instrument + if (repeat_instrument) { + rep_forms <- unique(na.omit(data$redcap_repeat_instrument)) + bad <- dic$field_name %in% rlogic_var & dic$form_name %in% rep_forms + if (any(bad)) { + vars <- paste0(dic$field_name[bad], " (form:", dic$form_name[bad], ")", collapse = ", ") + stop(sprintf( + "This function cannot translate logic involving variables that belong to repeated instruments. Review the following variables manually: %s", + vars + ), call. = FALSE) } + } - rlogic <- gsub("\\,\\s?true", "", rlogic) - rlogic <- gsub("\\,\\s?'y'\\,\\s?'dmy'", "), 'year'", rlogic) - rlogic <- gsub("\\,\\s?'d'\\,\\s?'dmy'", "), 'day'", rlogic) - rlogic <- gsub("\\,\\s?'m'\\,\\s?'dmy'", "), 'month'", rlogic) + # Error: any variable in logic is not found in the data + if (any(!check_lgl)) { + stop("REDCap logic contains variables that are not found in the database (possibly a smart variable).") + } - rlogic <- gsub("\\,\\s?'y'\\)", "), 'year')", rlogic) - rlogic <- gsub("\\,\\s?'d'\\)", "), 'day')", rlogic) - rlogic <- gsub("\\,\\s?'m'\\)", "), 'month')", rlogic) + # Proceed to transcribe REDCap logic to R logic + rlogic <- gsub('"', "'", rlogic) # Replace double quotes with single quotes for R compatibility + # Verify if any of the variables in the logic is now a factor in the dataset (example: [copd] + [hemato_neo], if we do this it generates a warning) + vars_calc <- rlogic |> + stringr::str_extract_all("(?<=\\[)[^\\]]+(?=\\]\\s*[+\\-*/])") |> + purrr::pluck(1) + factors <- data |> + dplyr::select(dplyr::where(is.factor)) |> + names() - #Change variables specification. If [][] we get the event with the first claudator. If not the event will be the same as the one of the calculated variable + vars_calc <- intersect(vars_calc, factors) - #Vector with all the [][] if found: - var_event <- unlist(stringr::str_extract_all(rlogic, "\\[[\\w,\\-]+\\]\\[[\\w,\\-]+\\]")) + if (length(vars_calc) > 0) { + data <- data |> + dplyr::mutate(dplyr::across( + dplyr::any_of(vars_calc), + ~ { + field <- dplyr::cur_column() - if(length(var_event) > 0){ + choices <- dic$choices_calculations_or_slider_labels[dic$field_name == field] - #Separate them - list_var_event <- purrr::map(var_event, function(x){ - x <- unlist(stringr::str_split(x, "\\]\\[")) - x <- gsub("\\[", "", x) - x <- gsub("\\]", "", x) - }) + parts <- strsplit(choices, "\\|")[[1]] + parts <- parts[grepl(",", parts, fixed = FALSE)] - #If there is one same variable evaluated in different events the logic can't be transcribed - n_events <- data.frame(do.call(rbind, list_var_event)) - names(n_events) <- c("events", "vars") - n_events <- n_events %>% - dplyr::group_by(.data$vars) %>% - dplyr::summarise(n = length(unique(.data$events))) + nums <- trimws(sub(",.*$", "", parts)) + labs <- trimws(sub("^[^,]*,\\s*", "", parts)) - if(any(n_events$n > 1)){ - stop("The logic can't be transcribed because the same variable is present in the logic specified for different events") - } + mapping <- setNames(as.numeric(nums), labs) - #Apply the previously defined function to get the value in the corresponding event and fill it for all the rows of data - for(i in 1:length(list_var_event)){ - data <- fill_data(list_var_event[[i]][1], list_var_event[[i]][2], data) - } + as.numeric(mapping[as.character(data[[field]])]) + } + )) + } - rlogic <- gsub("\\[\\w+\\]\\[", "[", rlogic) + # Convert REDCap functions to equivalent R functions + rlogic <- gsub("if\\s?\\(", "ifelse(", rlogic) + rlogic <- gsub("rounddown(.*),0\\)", "floor\\1)", rlogic) + rlogic <- gsub("rounddown(.*),1\\)", "round\\1, 1)", rlogic) + rlogic <- gsub("rounddown(.*),2\\)", "round\\1, 2)", rlogic) + rlogic <- gsub("rounddown(.*),3\\)", "round\\1, 3)", rlogic) + rlogic <- gsub("rounddown(.*)\\)", "floor\\1)", rlogic) + rlogic <- gsub("datediff\\s?", "lubridate::time_length(lubridate::interval", rlogic) + rlogic <- gsub("sum\\((.*?)\\)", "rowSums(cbind(\\1))", rlogic) + rlogic <- gsub("year\\((.*?)\\)", "lubridate::year(\\1)", rlogic) + + # Handle date formats in logic + if (grepl("'dmy'", rlogic)) { + rlogic <- gsub("'(\\d\\d-\\d\\d-\\d\\d\\d\\d)'", "lubridate::dmy('\\1')", rlogic) + } else if (grepl("'mdy'", rlogic)) { + rlogic <- gsub("'(\\d\\d-\\d\\d-\\d\\d\\d\\d)'", "lubridate::mdy('\\1')", rlogic) + } else if (grepl("'ymd'", rlogic)) { + rlogic <- gsub("'(\\d\\d\\d\\d-\\d\\d-\\d\\d)'", "lubridate::ymd('\\1')", rlogic) + } else if (grepl("'ydm'", rlogic)) { + rlogic <- gsub("'(\\d\\d\\d\\d-\\d\\d-\\d\\d)'", "lubridate::ydm('\\1')", rlogic) + } else if (grepl("'myd'", rlogic)) { + rlogic <- gsub("'(\\d\\d-\\d\\d\\d\\d-\\d\\d)'", "lubridate::myd('\\1')", rlogic) + } else if (grepl("'dym'", rlogic)) { + rlogic <- gsub("'(\\d\\d-\\d\\d\\d\\d-\\d\\d)'", "lubridate::dym('\\1')", rlogic) + } - } + # Remove 'true' value from the logic as it's not used in R + rlogic <- gsub("\\,\\s?true", "", rlogic) + + # Replace the date format specifications for 'dmy', 'mdy', etc., with 'year', 'day', 'month' as needed + rlogic <- gsub("\\,\\s?'y'\\,\\s?'dmy'", "), 'year'", rlogic) + rlogic <- gsub("\\,\\s?'d'\\,\\s?'dmy'", "), 'day'", rlogic) + rlogic <- gsub("\\,\\s?'m'\\,\\s?'dmy'", "), 'month'", rlogic) + + # Modify the closing parentheses to correctly align with 'year', 'day', 'month' for R + rlogic <- gsub("\\,\\s?'y'\\)", "), 'year')", rlogic) + rlogic <- gsub("\\,\\s?'d'\\)", "), 'day')", rlogic) + rlogic <- gsub("\\,\\s?'m'\\)", "), 'month')", rlogic) + + # Change variables specification. If [][] we get the event with the first claudator. If not, the event will be the same as the one of the calculated variable. - #Change variable specification from [] to data$ - - #Change first [.] = '' for is.na(data$.) and [.] <>'' for !is.na(data$.) - - rlogic <- gsub("\\[(\\w+)\\]\\s?<>\\s?''", "!is.na(data$\\1)", rlogic) - rlogic <- gsub("\\[(\\w+)\\]\\s?=\\s?''", "is.na(data$\\1)", rlogic) - rlogic <- gsub("\\[(\\w+)\\]","data$\\1",rlogic) - - # #Inside the interval function there will be date variables so we have to wrap them with as.Date. Let's take the part we want to change: - # if(grepl("interval\\(", rlogic)) { - # interval_str <- unlist(str_match_all(rlogic, "interval\\(.*?\\)")) - # interval_str2 <- map(interval_str, ~gsub("(data\\$\\w+)", "as.Date(\\1)", .x)) - # for(i in 1:length(interval_str2)) { - # rlogic <- stringi::stri_replace_all_fixed(rlogic, interval_str[[i]], interval_str2[[i]]) - # } - # } - - #Change the redcap operators into r operators - rlogic <- gsub("=","==",rlogic) - rlogic <- gsub("<==","<=",rlogic) - rlogic <- gsub(">==",">=",rlogic) - rlogic <- gsub("<>","!=",rlogic) - rlogic <- gsub(" and "," & ",rlogic) - rlogic <- gsub(" or "," | ",rlogic) - - #Remove '' after one of these symbols appear: <, >, <=, >= - rlogic <- gsub("\\s?<\\s?'([\\d\\.]+)'", " < \\1", rlogic, perl = TRUE) - rlogic <- gsub("\\s?>\\s?'([\\d\\.]+)'", " > \\1", rlogic, perl = TRUE) - rlogic <- gsub("\\s?<=\\s?'([\\d\\.]+)'", " <= \\1", rlogic, perl = TRUE) - rlogic <- gsub("\\s?>=\\s?'([\\d\\.]+)'", " >= \\1", rlogic, perl = TRUE) - - #Transform '' for missing: - rlogic <- gsub("''", "NA", rlogic) - - #Now that we have transcribed the logic we have to evaluate it in the event of the corresponding variable (if data contains more than one event): - if(!is.null(event_form)){ - - #Get the form where the variable is found through the dictionary: - form_var <- dic %>% - dplyr::filter(.data$field_name == var) %>% - dplyr::pull(.data$form_name) - - #Get the event through the event-form mapping (it can be more than one): - event_var <- event_form %>% - dplyr::filter(.data$form == form_var) %>% - dplyr::pull(.data$unique_event_name) + # Vector with all the [][] if found: + var_event <- unlist(stringr::str_extract_all(rlogic, "\\[[\\w,\\-]+\\]\\[[\\w,\\-]+\\]")) + # If there are variables in the format [][] (event + variable): + if (length(var_event) > 0) { + # Separate the event and variable names + list_var_event <- purrr::map(var_event, function(x) { + x <- unlist(stringr::str_split(x, "\\]\\[")) + x <- gsub("\\[", "", x) + x <- gsub("\\]", "", x) + }) + + # Check if the same variable is evaluated for different events (this logic can't be transcribed) + n_events <- data.frame(do.call(rbind, list_var_event)) + names(n_events) <- c("events", "vars") + n_events <- n_events |> + dplyr::group_by(.data$vars) |> + dplyr::summarise(n = length(unique(.data$events))) + + if (any(n_events$n > 1)) { + stop("The logic cannot be transcribed because the same variable is specified for different events.") } - #Redefine rounding function to match the one in redcap for rounding .5 decimals in the same way (2.5 ~ 3) - round = function(x, digits) { - posneg = sign(x) - z = abs(x)*10^digits - z = z + 0.5 + sqrt(.Machine$double.eps) - z = trunc(z) - z = z/10^digits - z*posneg + # Apply the previously defined function to get the value in the corresponding event and fill it for all the rows of data + for (i in seq_along(list_var_event)) { + data <- fill_data(list_var_event[[i]][1], list_var_event[[i]][2], data) } - #Calculate evaluating the logic - rlogic_eval <- try(eval(parse(text = rlogic)), silent = TRUE) + # Update rlogic by removing the event-specific variable format ([][] -> []) + rlogic <- gsub("\\[\\w+\\]\\[", "[", rlogic) + } - if(inherits(rlogic_eval, "try-error") | length(rlogic_eval) == 0){ + # Change variable specification from [] to data$ + + # Change first [.] = '' for is.na(data$.) and [.] <>'' for !is.na(data$.) + rlogic <- gsub("\\[(\\w+)\\]\\s?<>\\s?''", "!is.na(data$\\1)", rlogic) + rlogic <- gsub("\\[(\\w+)\\]\\s?=\\s?''", "is.na(data$\\1)", rlogic) + rlogic <- gsub("\\[(\\w+)\\]", "data$\\1", rlogic) + + # Optional: Inside the interval function, there might be date variables. We would need to wrap them with as.Date(). + # The code is commented out because it's not always needed, but you can enable it if needed. + # if(grepl("interval\\(", rlogic)) { + # interval_str <- unlist(str_match_all(rlogic, "interval\\(.*?\\)")) + # interval_str2 <- map(interval_str, ~gsub("(data\\$\\w+)", "as.Date(\\1)", .x)) + # for(i in 1:length(interval_str2)) { + # rlogic <- stringi::stri_replace_all_fixed(rlogic, interval_str[[i]], interval_str2[[i]]) + # } + # } + + # Change the REDCap operators into R operators + rlogic <- gsub("=", "==", rlogic) + rlogic <- gsub("<==", "<=", rlogic) + rlogic <- gsub(">==", ">=", rlogic) + rlogic <- gsub("<>", "!=", rlogic) + rlogic <- gsub(" and ", " & ", rlogic) + rlogic <- gsub(" or ", " | ", rlogic) + + # Remove '' (empty strings) after comparison operators like <, >, <=, >= + rlogic <- gsub("\\s?<\\s?'([\\d\\.]+)'", " < \\1", rlogic, perl = TRUE) + rlogic <- gsub("\\s?>\\s?'([\\d\\.]+)'", " > \\1", rlogic, perl = TRUE) + rlogic <- gsub("\\s?<=\\s?'([\\d\\.]+)'", " <= \\1", rlogic, perl = TRUE) + rlogic <- gsub("\\s?>=\\s?'([\\d\\.]+)'", " >= \\1", rlogic, perl = TRUE) + + # Transform '' (empty strings) into missing values (NA) + rlogic <- gsub("''", "NA", rlogic) + + # After transcribing the logic, we need to evaluate it based on the corresponding event of the variable. This is only necessary if the data contains more than one event: + if (!is.null(event_form)) { + # Get the form where the variable is found through the dictionary + form_var <- dic |> + dplyr::filter(.data$field_name == var) |> + dplyr::pull(.data$form_name) + + # Get the event(s) through the event-form mapping + event_var <- event_form |> + dplyr::filter(.data$form == form_var) |> + dplyr::pull(.data$unique_event_name) + } - stop("The logic can't be evaluated after the translation") + # Redefine the rounding function to match the one in REDCap for rounding .5 decimals similarly (e.g., 2.5 ~ 3) + # round <- function(x, digits) { + # posneg <- sign(x) + # z <- abs(x)*10^digits + # z <- z + 0.5 + sqrt(.Machine$double.eps) + # z <- trunc(z) + # z <- z/10^digits + # z*posneg + # } + + # Check for date fields in the logic that are still in character class + date_class <- dic |> + dplyr::filter(.data$field_name %in% rlogic_var) |> + dplyr::filter(grepl("^date_|^datetime_", .data$text_validation_type_or_show_slider_number)) |> + dplyr::pull(.data$field_name) + + if (any(purrr::map(data |> dplyr::select(dplyr::all_of(date_class)), class) == "character")) { + warning("The dataset contains date fields stored as character class, which may lead to incorrect evaluation results. To format these date fields, use the `rd_dates` function before proceeding.", call. = FALSE) + + # Evaluate the logic in the R format + rlogic_eval <- suppressWarnings(try(eval(parse(text = rlogic)), silent = TRUE)) + } else { + # Evaluate the logic in the R format + rlogic_eval <- try(eval(parse(text = rlogic)), silent = TRUE) + } - }else{ - #Only in the specified event (if data contains more than one event)! - if(!is.null(event_form)){ - return( + # If there's an error or the result is empty, stop the process + if (inherits(rlogic_eval, "try-error") | length(rlogic_eval) == 0) { + stop("The logic could not be evaluated after translation.") + } else { + # If there's more than one event, return the evaluation only for the specified event(s): + if (!is.null(event_form)) { + return( list( rlogic = rlogic, - eval = data %>% - dplyr::mutate(calc = rlogic_eval, - calc = ifelse(! .data$redcap_event_name %in% event_var, NA, .data$calc)) %>% + eval = data |> + dplyr::mutate( + calc = rlogic_eval, + calc = ifelse(!.data$redcap_event_name %in% event_var, NA, .data$calc) + ) |> dplyr::pull(.data$calc) ) + ) + } else { + # If there is only one event, return the result directly + return( + list( + rlogic = rlogic, + eval = rlogic_eval ) - }else{ - #If there is only one event: - return( - list( - rlogic = rlogic, - eval = rlogic_eval - ) - ) - } - - + ) } - } - } diff --git a/R/rd_split.R b/R/rd_split.R new file mode 100644 index 0000000..9314ed9 --- /dev/null +++ b/R/rd_split.R @@ -0,0 +1,419 @@ +#' Split a REDCap dataset by form or event +#' +#' @description +#' `r lifecycle::badge('experimental')` +#' +#' Splits a REDCap dataset into separate datasets by **form** or **event** using the data dictionary. Supports both longitudinal and non-longitudinal projects and can return wide or long formats for repeated measures. +#' +#' @param project A list containing the REDCap data, dictionary, and event mapping (expected `redcap_data()` output). Overrides `data`, `dic`, and `event_form`. +#' @param data A `data.frame` or `tibble` with the REDCap dataset. +#' @param dic A `data.frame` with the REDCap dictionary. +#' @param event_form Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects. +#' @param which Optional. A single form or event to extract. If not provided, all forms or events are returned. +#' @param by Character. Criteria to split the dataset: `"form"` (default) or `"event"`. +#' @param wide Logical. If `TRUE` (for form-based splits), repeated instances are returned in wide format. Defaults to `FALSE`. +#' +#' @details +#' * Handles checkbox variables and REDCap default variables (`_complete`, `_timestamp`) appropriately. +#' * For form-based splits in longitudinal projects, uses `event_form` to map variables to events. +#' * Wide format expands repeated instances into multiple columns per record. +#' * Filtering by `which` allows extracting a single form or event. +#' * Projects with repeated instruments are handled by filtering on the `redcap_repeat_instrument` variable. +#' +#' @return Depending on `which` and `wide`: +#' \describe{ +#' \item{data}{A `data.frame` or a list of `data.frames` representing the split datasets.} +#' \item{dictionary}{The original REDCap dictionary.} +#' \item{event_form}{The original event-form mapping (if applicable).} +#' \item{results}{A summary message of the splitting operation.} +#' } +#' +#' @examples +#' # Split by form and return wide format +#' result <- covican |> +#' rd_split(by = "form", wide = TRUE) +#' +#' print(result) +#' +#' # Split by event (long format) +#' result <- covican |> +#' rd_split(by = "event") +#' +#' print(result) +#' +#' @export + +rd_split <- function(project = NULL, data = NULL, dic = NULL, event_form = NULL, which = NULL, by = "form", wide = FALSE) { + + results <- NULL + + # Handle potential overwriting when both `project` and other arguments are provided + if (!is.null(project)) { + env_vars <- check_proj(project, data, dic, event_form) + list2env(env_vars, envir = environment()) + } + + # Ensure both `data` and `dic` are provided; stop if either is missing + if (is.null(data) | is.null(dic)) { + stop("Both `data` and `dic` (data and dictionary) arguments must be provided.") + } + + # Extract labels from the data to reapply later + labels <- purrr::map_chr(data, function(x) { + lab <- attr(x, "label") + if (!is.null(lab)) { + lab + } else { + "" + } + }) + + # Check if the project has repeated instruments + if ("redcap_repeat_instrument" %in% names(data)) { + repeat_instrument <- dplyr::case_when( + any(!is.na(data$redcap_repeat_instrument)) ~ TRUE, + TRUE ~ FALSE + ) + } else { + repeat_instrument <- FALSE + } + + # Identify basic REDCap variables present in the dataset + basic_redcap_vars <- c("record_id", "redcap_event_name", "redcap_repeat_instrument", "redcap_repeat_instance", "redcap_data_access_group", "redcap_event_name.factor", "redcap_repeat_instrument.factor", "redcap_data_access_group.factor", "redcap_survey_identifier") + + basic_redcap_vars <- intersect(basic_redcap_vars, names(data)) + + # Check functions needed before splitting + actions <- character() + + # Check for missing variables in the dataset compared to the dictionary + vars_more <- setdiff(dic$field_name, names(data)) + + # Handle cases where variables in the dictionary are missing in the dataset + if (length(vars_more) > 0) { + + # Special handling for "checkbox" variables + check_vars <- dic |> + dplyr::filter(.data$field_name %in% vars_more & .data$field_type == "checkbox") |> + dplyr::pull(.data$field_name) + + other_check_vars <- setdiff(vars_more, check_vars) + + if (length(other_check_vars) > 0) { + stop("There are variables in the dictionary that are not present in the dataset.\nPlease ensure that the dictionary matches the dataset. Transformation has been halted.", call. = FALSE) + } + + } + + # Check for extra variables in the dataset compared to the dictionary + vars_less <- setdiff(names(data), dic$field_name) |> + setdiff(basic_redcap_vars) # Exclude REDCap default variables not found in the dictionary + + # Handle cases where there are variables in the data that cannot be found in the dictionary + if (length(vars_less) > 0) { + + patt_vars <- grep("_complete$|_timestamp$", vars_less, value = TRUE) + + # Special handling for "_complete" and "_timestamp" patterns + if (length(patt_vars) > 0) { + mss <- dplyr::case_when( + any(grepl("_complete$", vars_less)) & any(grepl("_timestamp$", vars_less)) ~ "c('_complete', '_timestamp')", + any(grepl("_complete$", vars_less)) ~ "'_complete'", + any(grepl("_timestamp$", vars_less)) ~ "'_timestamp'" + ) + + # actions <- c(actions, stringr::str_glue("Transformation halted. Default REDCap variables ({mss}) are present in the dataset but not in the dictionary.\nTo proceed, use the `rd_delete_vars` function with `pattern = {mss}` to remove these variables before continuing.")) + actions <- c(actions, stringr::str_glue("Default REDCap variables ({mss}) detected in the dataset. Please, run: rd_delete_vars(..., pattern = {mss})")) + } + + fact_vars <- grep(".factor$", vars_less, value = TRUE) + + # Checkbox vars already identified in the previous step (vars_more) + less_check <- grep("___", vars_less, value = TRUE) + + other_less_vars <- setdiff(vars_less, c(patt_vars, fact_vars, less_check)) + + if (length(other_less_vars) > 0) { + # General message for other cases + stop("There are extra variables in the dataset not found in the dictionary.\nTransformation halted.", + call. = FALSE + ) + } + } + + + # single stop with full list (if anything found) + if (length(actions) > 0) { + header <- c( + "Detected issues that must be resolved BEFORE running rd_split():", + "" + ) + body <- unlist(lapply(seq_along(actions), function(i) paste0(i, ". ", actions[i]))) + footer <- c("", "Suggested order: list(data, dic, ...) |> rd_delete_vars(delete_pattern = ...) |> rd_split(...)") + stop(paste(c(header, body, footer), collapse = "\n"), call. = FALSE) + } + + if (by == "form") { + # Handle splitting by form + form <- unique(dic$form_name) + longitudinal <- "redcap_event_name" %in% names(data) + + if (longitudinal & is.null(event_form)) { + stop("The event-form correspondence is required to split the data by form in a longitudinal project. Please provide the `event_form` argument to proceed.", call. = FALSE) + } + + if (longitudinal) { + ndata <- tibble::tibble("form" = form) |> + dplyr::mutate( + events = purrr::map(.data$form, ~ event_form$unique_event_name[event_form$form == .x]), + vars = purrr::map(.data$form, ~{ + posible_vars <- dic$field_name[dic$form_name == .x] + posible_vars <- c(posible_vars, paste0(posible_vars, ".factor")) + + check_df <- tibble::tibble(check_data = names(data)[grep("___", names(data))]) |> + dplyr::mutate(check_dic = gsub("___.*$", "", check_data)) |> + dplyr::distinct_all() |> + dplyr::filter(check_dic %in% posible_vars) + + if (nrow(check_df) > 0) { + vars_dic <- c(unique(check_df$check_dic), paste0(unique(check_df$check_dic), ".factor")) + posible_vars <- setdiff(posible_vars, vars_dic) + posible_vars <- c(posible_vars, check_df$check_data) + } + + intersect(names(data), posible_vars) + } + ) + ) |> + dplyr::mutate(df = purrr::map2( + .data$events, + .data$vars, + ~ data |> + dplyr::filter(redcap_event_name %in% .x) |> + dplyr::select(dplyr::any_of(unique( + c(basic_redcap_vars, .y) + ))) + )) + } else { + ndata <- tibble::tibble("form" = form) |> + dplyr::mutate( + vars = purrr::map(.data$form, ~ { + posible_vars <- dic$field_name[dic$form_name == .x] + posible_vars <- c(posible_vars, paste0(posible_vars, ".factor")) + + check_df <- tibble::tibble(check_data = names(data)[grep("___", names(data))]) |> + dplyr::mutate(check_dic = gsub("___.*$", "", check_data)) |> + dplyr::distinct_all() |> + dplyr::filter(check_dic %in% posible_vars) + + if (nrow(check_df) > 0) { + vars_dic <- c(unique(check_df$check_dic), paste0(unique(check_df$check_dic), ".factor")) + posible_vars <- setdiff(posible_vars, vars_dic) + posible_vars <- c(posible_vars, check_df$check_data) + } + + intersect(names(data), posible_vars) + }), + vars = purrr::map(.data$vars, ~ unique(c(basic_redcap_vars, .x))) + ) |> + dplyr::mutate(df = purrr::map(.data$vars, ~ data |> + dplyr::select(dplyr::any_of(unique(c(basic_redcap_vars, .x)))))) + } + + if (repeat_instrument) { + form_check <- data |> + dplyr::distinct(dplyr::pick(dplyr::contains("redcap_repeat_instrument"))) + + ndata <- ndata |> + dplyr::left_join(form_check, by = dplyr::join_by("form" == "redcap_repeat_instrument")) |> + dplyr::relocate("form_factor" = "redcap_repeat_instrument.factor", .after = form) |> + dplyr::mutate(df = purrr::map2(.data$form_factor, .data$df, ~ { + if (is.na(.x)) { + .y |> + dplyr::filter(is.na(.data$redcap_repeat_instrument.factor)) |> + dplyr::select(-dplyr::starts_with("redcap_repeat_instrument")) + } else { + .y |> + dplyr::filter(.data$redcap_repeat_instrument.factor == .x) |> + dplyr::mutate(redcap_repeat_instrument = redcap_repeat_instrument.factor) |> + dplyr::select(-dplyr::any_of("redcap_repeat_instrument.factor")) + } + })) |> + dplyr::select(-"form_factor") + } + + if (wide) { + ndata <- ndata |> + dplyr::mutate(df = purrr::map(.data$df, ~{ + order_cols <- intersect(names(data), names(.x)) + + .x |> + dplyr::select(dplyr::any_of(c(basic_redcap_vars, order_cols))) + })) + + ndata <- ndata |> + dplyr::mutate( + max_repeated_instance = purrr::map_dbl( + .data$df, + ~.x |> + dplyr::group_by(.data$record_id) |> + dplyr::mutate(id = seq_along(.data$record_id), + max_id = n()) |> + dplyr::ungroup() |> + dplyr::pull(max_id) |> + max() + ), + df = if (longitudinal) { + purrr::pmap(list(.data$vars, .data$df, .data$events), function(x, y, z) { + + y <- y |> + dplyr::select(dplyr::all_of(c("record_id", x))) + + if(dplyr::n_distinct(z) > 1) { + + y <- y |> + dplyr::group_by(.data$record_id) |> + dplyr::mutate(id = seq_along(.data$record_id)) |> + dplyr::ungroup() |> + tidyr::pivot_wider(names_from = "id", values_from = -c("record_id", "id")) + } + + return(y) + }) + } else { + purrr::map2(.data$vars, .data$df, function(x, y) { + y |> + dplyr::select(dplyr::all_of(c("record_id", x))) + }) + } + ) |> + dplyr::relocate(.data$max_repeated_instance, .before = .data$vars) + } + } else if (by == "event") { + + # Handle splitting by event + var_event <- tibble::tibble("form_name" = event_form$form) |> + dplyr::mutate( + redcap_event_name = purrr::map(.data$form_name, ~ event_form$unique_event_name[event_form$form == .x]), + vars = purrr::map(.data$form_name, ~{ + posible_vars <- dic$field_name[dic$form_name == .x] + posible_vars <- c(posible_vars, paste0(posible_vars, ".factor")) + + check_df <- tibble::tibble(check_data = names(data)[grep("___", names(data))]) |> + dplyr::mutate(check_dic = gsub("___.*$", "", check_data)) |> + dplyr::distinct_all() |> + dplyr::filter(check_dic %in% posible_vars) + + if (nrow(check_df) > 0) { + vars_dic <- c(unique(check_df$check_dic), paste0(unique(check_df$check_dic), ".factor")) + posible_vars <- setdiff(posible_vars, vars_dic) + posible_vars <- c(posible_vars, check_df$check_data) + } + + intersect(names(data), posible_vars) + } + ) + ) |> + tidyr::unnest(.data$redcap_event_name) |> + tidyr::unnest(.data$vars) |> + dplyr::distinct(.data$redcap_event_name, field_name = .data$vars) |> + dplyr::filter(.data$field_name != "record_id") |> + tibble::as_tibble() + + var_event_add <- data.frame(redcap_event_name = NA, field_name = basic_redcap_vars) + var_event <- rbind(var_event_add, var_event) + + list_events <- stats::na.exclude(unique(var_event$redcap_event_name)) + + ndata <- tibble::tibble("events" = list_events) |> + dplyr::mutate( + vars = purrr::map( + .data$events, + ~ var_event |> + dplyr::filter(.data$redcap_event_name == .x) |> + dplyr::pull("field_name") + ), + df = purrr::map2( + .data$events, + .data$vars, + ~ data |> + dplyr::filter(.data$redcap_event_name == .x) |> + dplyr::select(dplyr::all_of(c(basic_redcap_vars, .y))) + ) + ) + + } else { + stop("Invalid `by` argument. Please specify either 'form' or 'event'.") + } + + # Order columns + if (!wide) { + ndata <- ndata |> + dplyr::mutate(df = purrr::map(.data$df, ~{ + order_cols <- intersect(names(data), names(.x)) + + .x |> + dplyr::select(dplyr::any_of(c(basic_redcap_vars, order_cols))) + })) + } + + # Handle the `which` argument if provided + if (!is.null(which)) { + if (length(which) > 1) { + warning("The `which` argument is designed to specify a single form or event. Multiple inputs were provided; only the first will be used.") + + which <- which[1] + } + + if (by == "form") { + if(!which %in% form){ + stop("The form specified in the `which` argument was not found in this project.\n", + "Please select one of the available REDCap forms:\n", paste0("-", form, "\n"), call. = FALSE) + } + } + + if (by == "event") { + if(!which %in% list_events){ + stop("The event specified in the `which` argument was not found in this project.\n", + "Please select one of the available REDCap events:\n", paste0("-", list_events, "\n"), call. = FALSE) + } + } + + + ndata <- ndata |> + dplyr::filter((if (by == "form") .data$form else .data$events) == which) |> + dplyr::pull(.data$df) |> + purrr::pluck(1) + } else { + ndata <- ndata |> + dplyr::select(-"vars") + } + + # Update results with the this transformation + if (is.null(results)) { + results <- c(results, stringr::str_glue("Final arrangment of the data by {by}. (rd_split)\n")) + } else { + + if(grepl("^[A-Z]", results[1])) { + results[1] <- paste("1.", results[1]) + } + + last_val_res <- results |> + stringr::str_extract("^(\n)?\\d+\\.") |> + na.omit() |> + dplyr::last() |> + stringr::str_remove("\\.") |> + as.numeric() + + results <- c(results, stringr::str_glue("\n\n{last_val_res + 1}. Final arrangment of the data by {by}. (rd_split)\n")) + } + + # Return the modified data, dictionary, event_form, and results + list( + data = ndata, + dictionary = dic, + event_form = event_form, + results = stringr::str_glue("{results}") + ) |> + purrr::compact() # Remove any NULL elements from the output list +} diff --git a/R/rd_transform.R b/R/rd_transform.R index 5f58204..5c356be 100644 --- a/R/rd_transform.R +++ b/R/rd_transform.R @@ -1,109 +1,107 @@ #' Transformation of the Raw Data #' -#' This function transforms the raw REDCap data read by the `redcap_data` function. It returns the transformed data and dictionary, along with a summary of the results of each step. -#' @param ... Output of the `redcap_data` function, which is a list containing the data frames of the data, dictionary and event_form (if needed) of the REDCap project. -#' @param data Data frame containing the data read from REDCap. If the list is specified, this argument is not necessary. -#' @param dic Data frame containing the dictionary read from REDCap. If the list is specified, this argument is not necessary. -#' @param event_form Data frame containing the correspondence of each event with each form. If the list is specified, this argument is not necessary. -#' @param checkbox_labels Character vector with the names for the two options of every checkbox variable. Default is `c('No', 'Yes')`. -#' @param checkbox_na Logical indicating if checkboxes values with branching logic should be set to missing only when the branching logic is missing (`FALSE`), or also when the branching logic isn't satisfied (`TRUE`). The default is `FALSE`. -#' @param exclude_recalc Character vector with the names of variables that should not be recalculated. Useful for projects with time-consuming recalculations of certain calculated fields. -#' @param exclude_to_factor Character vector with the names of variables that should not be transformed to factors. -#' @param delete_vars Character vector specifying the variables to exclude. -#' @param delete_pattern Character vector specifying the regex pattern for variables to be excluded. By default, variables ending with `_complete` and `_timestamp` will be removed. +#' @description +#' `r lifecycle::badge('stable')` +#' +#' Transforms the raw REDCap data read by the `redcap_data` function. The function runs in one-step pipeline all functions dedicated to processing the data and returns the transformed data and dictionary, along with a summary of each step done. +#' +#' @param project A list containing the REDCap data, dictionary, and event mapping (expected `redcap_data()` output). Overrides `data`, `dic`, and `event_form`. +#' @param data A `data.frame` or `tibble` with the REDCap dataset. +#' @param dic A `data.frame` with the REDCap dictionary. +#' @param event_form Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects. +#' @param checkbox_labels Character vector of length 2 for labels of unchecked/checked values. Default: `c("No", "Yes")`. +#' @param na_logic Controls how missing values are set based on the branching logic of a checkbox. Must be one of `"none"` (do nothing), `"missing"` (set to `NA` only when the logic evaluation is `NA`), or `"eval"` (set to `NA` when the logic evaluates to `FALSE`). Defaults to `"none"`. +#' @param exclude_recalc Optional. Character vector of field names to exclude from recalculation. +#' @param exclude_factor Optional character vector of variable names (use original names **without** the `.factor` suffix) to exclude from conversion. +#' @param delete_vars Optional. A character vector of variable names to remove from both the dataset and dictionary. +#' @param delete_pattern Optional. A character vector of regular expression patterns. Variables matching these patterns will be removed from the dataset and dictionary. #' @param final_format Character string indicating the final format of the data. Options are `raw`, `by_event` or `by_form`. `raw` (default) returns the transformed data in its original structure, `by_event` returns it as a nested data frame by event, and `by_form` returns it as a nested data frame by form. -#' @param which_event Character string indicating a specific event to return if the final format is `by_event`. -#' @param which_form Character string indicating a specific form to return if the final format is `by_form`. -#' @param wide Logical indicating if the data split by form (if selected) should be in a wide format (`TRUE`) or a long format (`FALSE`). -#' @return A list with the transformed dataset, dictionary, event_form, and the results of each transformation step. +#' @param which_event Character. If `final_format = "by_event"`, return only this event. +#' @param which_form Character. If `final_format = "by_form"`, return only this form. +#' @param wide Logical. If `TRUE` (for form-based splits), repeated instances are returned in wide format. Defaults to `FALSE`. +#' +#' @return A list with elements: +#' \describe{ +#' \item{data}{Transformed data (data.frame or nested list when split).} +#' \item{dictionary}{Updated dictionary data.frame.} +#' \item{event_form}{Event–form mapping (if applicable).} +#' \item{results}{Character summary of transformation steps performed.} +#' } #' #' @examples -#' # Basic transformation -#' rd_transform(covican) +#' # Minimal usage (project object or data + dictionary) +#' trans <- rd_transform(covican) +#' +#' # Custom checkbox labels +#' trans <- rd_transform(covican, +#' checkbox_labels = c("Not present", "Present")) #' -#' # For customization of checkbox labels (example) -#' rd_transform(covican, -#' checkbox_labels = c("Not present", "Present")) +#' # Return only a single form (wide) +#' trans <- rd_transform(covican, +#' final_format = "by_form", +#' which_form = "laboratory_findings", +#' wide = TRUE) #' #' @export -rd_transform <- function(..., data = NULL, dic = NULL, event_form = NULL, checkbox_labels = c("No", "Yes"), checkbox_na = FALSE, exclude_recalc = NULL, exclude_to_factor = NULL, delete_vars = NULL, delete_pattern = c("_complete", "_timestamp"), final_format = "raw", which_event = NULL, which_form = NULL, wide = NULL){ - - project <- c(...) +rd_transform <- function(project = NULL, data = NULL, dic = NULL, event_form = NULL, checkbox_labels = c("No", "Yes"), na_logic = "none", exclude_recalc = NULL, exclude_factor = NULL, delete_vars = NULL, delete_pattern = NULL, final_format = "raw", which_event = NULL, which_form = NULL, wide = NULL) { results <- NULL ind <- 1 - if(!is.null(project)){ - if(!is.null(data)){ - warning("Data has been specified twice so the function will not use the information in the data argument.") - } - - if(!is.null(dic)){ - warning("Dictionary has been specified twice so the function will not use the information in the dic argument.") - } + # validate na_logic against allowed choices + na_logic <- match.arg(na_logic, choices = c("none", "missing", "eval")) - data <- project$data - dic <- project$dictionary - dic_ori <- dic + # Handle potential overwriting when both `project` and other arguments are provided + if (!is.null(project)) { + env_vars <- check_proj(project, data, dic, event_form) - if("event_form" %in% names(project)){ - if(!is.null(event_form)){ - warning("The event-form has been specified twice so the function will not use the information in the event_form argument.") - } - event_form <- project$event_form - } + list2env(env_vars, envir = environment()) } - if(is.null(data) | is.null(dic)){ - stop("No data/dictionary was provided") + # Ensure both `data` and `dic` are provided; stop if either is missing + if (is.null(data) | is.null(dic)) { + stop("Both `data` and `dic` (data and dictionary) arguments must be provided.") } - #Check if the project is longitudinal (has more than one event) or not: + # Check if the project is longitudinal (has more than one event) or not: longitudinal <- ifelse("redcap_event_name" %in% names(data), TRUE, FALSE) - if(final_format == "by_event" & is.null(event_form)){ + if (final_format == "by_event" & is.null(event_form)) { stop("To split the data by event the event_form has to be provided", call. = FALSE) } - #If the project is not longitudinal 'by_form' can be used without event_form: - if(final_format == "by_form" & is.null(event_form) & longitudinal){ + # If the project is not longitudinal 'by_form' can be used without event_form: + if (final_format == "by_form" & is.null(event_form) & longitudinal) { stop("To split the data by form the event_form has to be provided in a longitudinal project", call. = FALSE) } - if(!is.null(which_event) & final_format != "by_event"){ + if (!is.null(which_event) & final_format != "by_event") { stop("Which event has been specified but the final format is not to split the data by event", call. = FALSE) } - if(!is.null(which_form) & final_format != "by_form"){ + if (!is.null(which_form) & final_format != "by_form") { stop("Which form has been specified but the final format is not to split the data by form", call. = FALSE) } - if(!is.null(wide) & final_format != "by_form"){ + if (!is.null(wide) & final_format != "by_form") { stop("The argument wide has been specified but the final format is not to split the data by form", call. = FALSE) } - if(!final_format %in% c("raw", "by_event", "by_form")){ + if (!final_format %in% c("raw", "by_event", "by_form")) { stop("final_format argument has to be one of the following: 'raw', 'by_event', 'by_form'", call. = FALSE) } - #If the project is longitudinal and the event hasn't been specified: - if(longitudinal & is.null(event_form)){ + # If the project is longitudinal and the event hasn't been specified: + if (longitudinal & is.null(event_form)) { warning("The project contains more than one event. For a complete transformation is recommended to include the event-form correspondence.") } - #Check if the project has repeated instruments - if("redcap_repeat_instrument" %in% names(data)) { - repeat_instrument <- dplyr::case_when( - any(!is.na(data$redcap_repeat_instrument)) ~ TRUE, - TRUE ~ FALSE - ) - } else { - repeat_instrument <- FALSE - } + # Check if the project has repeated instruments + repeat_instrument <- "redcap_repeat_instrument" %in% names(data) && any(!is.na(data$redcap_repeat_instrument)) - message("Transformation in progress...") + message("\u23F3 Transformation in progress...") labels <- purrr::map_chr(data, function(x) { lab <- attr(x, "label") @@ -114,9 +112,9 @@ rd_transform <- function(..., data = NULL, dic = NULL, event_form = NULL, checkb } }) - #Change the labelled class of each column but don't remove the label: - data <- data %>% - dplyr::mutate_all(function(x){ + # Change the labelled class of each column but don't remove the label: + data <- data |> + dplyr::mutate_all(function(x) { class(x) <- setdiff(class(x), "labelled") x }) @@ -125,341 +123,216 @@ rd_transform <- function(..., data = NULL, dic = NULL, event_form = NULL, checkb results <- c(results, stringr::str_glue("{ind}. Removing selected variables\n")) ind <- ind + 1 - if(!is.null(delete_vars)){ - - for(i in 1:length(delete_vars)) { - data <- data %>% - dplyr::select(!delete_vars[i]) - - if (paste0(delete_vars[i], ".factor") %in% names(data)) { - data <- data %>% - dplyr::select(!paste0(delete_vars[i], ".factor")) - } - - dic <- dic %>% - dplyr::filter(.data$field_name != delete_vars[i]) - - } + if (!is.null(delete_vars)) { + del_vars <- suppressWarnings(rd_delete_vars(data = data, dic = dic, vars = delete_vars)) + data <- del_vars$data + dic <- del_vars$dictionary } # Delete variables that contain specific patterns results <- c(results, stringr::str_glue("\n\n{ind}. Deleting variables that contain some patterns\n")) ind <- ind + 1 - if(!is.null(delete_pattern)){ - - for(i in 1:length(delete_pattern)){ - - if(delete_pattern[i] == "_complete"){ - - data <- data %>% - dplyr::select(!tidyselect::ends_with(c("_complete", "_complete.factor"))) - - dic <- dic %>% - dplyr::filter(!grepl("_complete$", .data$field_name)) - - }else if(delete_pattern[i] == "_timestamp"){ - - data <- data %>% - dplyr::select(!tidyselect::ends_with(c("_timestamp", "timestamp.factor"))) - - dic <- dic %>% - dplyr::filter(!grepl("_timestamp$", .data$field_name)) - - }else{ - - data <- data %>% - dplyr::select(-dplyr::matches(delete_pattern[i])) - - dic <- dic %>% - dplyr::filter(!grepl(delete_pattern[i], .data$field_name)) - } - - } + if (!is.null(delete_pattern)) { + del_pattern <- suppressWarnings(rd_delete_vars(data = data, dic = dic, pattern = delete_pattern)) + data <- del_pattern$data + dic <- del_pattern$dictionary } - #Change the format of dates - #Identify dates that have the tag "date_"/"datetime_"/"datetime_seconds_" in redcap. It will have always the format "Y-M-D" in any case - var_date <- dic %>% - dplyr::filter(grepl("^date_", .data$text_validation_type_or_show_slider_number)) %>% + # Change the format of dates + # Identify dates that have the tag "date_"/"datetime_"/"datetime_seconds_" in redcap. It will have always the format "Y-M-D" in any case + var_date <- dic |> + dplyr::filter(grepl("^date_", .data$text_validation_type_or_show_slider_number)) |> dplyr::pull(.data$field_name) - var_date_valid <- dplyr::select(data, dplyr::all_of(var_date)) |> - purrr::keep(~ inherits(.x, "Date")) |> - names() - - var_date <- setdiff(var_date, var_date_valid) - - var_datetime <- dic %>% - dplyr::filter(grepl("^datetime_", .data$text_validation_type_or_show_slider_number)) %>% + var_datetime <- dic |> + dplyr::filter(grepl("^datetime_", .data$text_validation_type_or_show_slider_number)) |> dplyr::pull(.data$field_name) - var_datetime_valid <- dplyr::select(data, dplyr::all_of(var_datetime)) |> - purrr::keep(~ inherits(.x, "POSIXct")) |> - names() + data <- rd_dates(data = data, dic = dic)$data - var_datetime <- setdiff(var_datetime, var_datetime_valid) - - data <- data %>% - dplyr::mutate_at(var_date, as.Date) %>% - dplyr::mutate_at(var_datetime, function(x) { - x <- dplyr::case_when( - x == "" ~ NA, - TRUE ~ x - ) - as.POSIXct(x, origin = "1970-01-01", tz = "UTC") - }) - - dic <- dic %>% - dplyr::mutate(branching_logic_show_field_only_if = dplyr::case_when(is.na(branching_logic_show_field_only_if) ~ "", - TRUE ~ branching_logic_show_field_only_if)) + dic <- dic |> + dplyr::mutate(branching_logic_show_field_only_if = dplyr::case_when( + is.na(branching_logic_show_field_only_if) ~ "", + TRUE ~ branching_logic_show_field_only_if + )) if (!repeat_instrument) { - #Recalculate calculated fields (previous to transforming factors and other preprocessing) - #It wil create duplicate variables of each calculated field with "_recalc" in the end and the recalculated value + # Recalculate calculated fields (previous to transforming factors and other preprocessing) + # It wil create duplicate variables of each calculated field with "_recalc" in the end and the recalculated value - results <- c(results, stringr::str_glue("\n\n{ind}. Recalculating calculated fields and saving them as '[field_name]_recalc'\n")) + results <- c(results, stringr::str_glue("\n\n{ind}. Recalculating calculated fields and saving them as '[field_name]_recalc'")) ind <- ind + 1 - #If the project is longitudinal and the event hasn't been specified no recalculation is possible - if(longitudinal & is.null(event_form)){ - + # If the project is longitudinal and the event hasn't been specified no recalculation is possible + if (longitudinal & is.null(event_form)) { results <- c(results, "\nNo recalculation is possible as the project has more than one event and the event-form correspondence has not been specified\n") - - }else{ - - recalc <- recalculate(data, dic, event_form, exclude_recalc) + } else { + recalc <- rd_recalculate(data = data, dic = dic, event_form = event_form, exclude = exclude_recalc) data <- recalc$data - dic <- recalc$dic - - results <- c(results, recalc$results) + dic <- recalc$dictionary + results <- c(results, recalc$results[-1]) } } - if (!repeat_instrument) { - if(checkbox_na){ - results <- c(results, stringr::str_glue("\n\n{ind}. Transforming checkboxes: changing their values to No/Yes and changing their names to the names of its options. For checkboxes that have a branching logic, when the logic isn't satisfied or it's missing their values will be set to missing\n\n")) - }else{ - results <- c(results, stringr::str_glue("\n\n{ind}. Transforming checkboxes: changing their values to No/Yes and changing their names to the names of its options. For checkboxes that have a branching logic, when the logic is missing their values will be set to missing\n\n")) + # Message depends on na_logic option + if (na_logic == "eval") { + results <- c(results, stringr::str_glue("\n\n{ind}. Transforming checkboxes: changing their values to No/Yes and changing their names to the names of its options. For checkboxes that have a branching logic, when the logic isn't satisfied or it's missing their values will be set to missing")) + } else if (na_logic == "missing") { + results <- c(results, stringr::str_glue("\n\n{ind}. Transforming checkboxes: changing their values to No/Yes and changing their names to the names of its options. For checkboxes that have a branching logic, when the logic is missing their values will be set to missing")) + } else { + results <- c(results, stringr::str_glue("\n\n{ind}. Transforming checkboxes: changing their values to No/Yes and changing their names to the names of its options.")) } } else { - results <- c(results, stringr::str_glue("\n\n{ind}. Transforming checkboxes: changing their values to No/Yes and changing their names to the names of its options.\n")) + results <- c(results, stringr::str_glue("\n\n{ind}. Transforming checkboxes: changing their values to No/Yes and changing their names to the names of its options.")) } ind <- ind + 1 - #Identify checkbox variables: - var_check<-names(data)[grep("___",names(data))] - - #Remove .factor: - var_check_factors <- var_check[grep(".factor$",var_check)] - - if (length(var_check_factors) > 0) { - data <- data %>% - dplyr::select(-tidyselect::all_of(var_check_factors)) - - var_check <- var_check[!grepl(".factor$",var_check)] - } else { - if (length(var_check) > 0){ - data <- data %>% - dplyr::mutate(dplyr::across( - tidyselect::all_of(var_check), - ~ dplyr::case_when(.x == "Unchecked" ~ 0, - .x == "Checked" ~ 1, - TRUE ~ NA) - )) - } - } - - #If there is some checkbox: - if(length(var_check) > 0){ - - #If the event_form is not provided and the project is longitudinal - if(is.null(event_form) & longitudinal) { - - results <- c(results, "\nBranching logic evaluation is not possible as the project has more than one event and the event-form correspondence has not been specified\n") - + # If there is some checkbox: + if (length(names(data)[grep("___", names(data))]) > 0) { + # If the event_form is not provided and the project is longitudinal + if (is.null(event_form) & longitudinal) { + results <- c(results, "\nBranching logic evaluation is not possible as the project has more than one event and the event-form correspondence has not been specified\n") } else { - if (!repeat_instrument) { + # Transform missings of checkboxes with branching logic: + trans <- rd_checkbox(data = data, dic = dic, event_form = event_form, checkbox_labels = checkbox_labels, checkbox_names = TRUE, na_logic = na_logic) - #Transform missings of checkboxes with branching logic: - trans <- transform_checkboxes(data = data, dic = dic, event_form = event_form, checkbox_na = checkbox_na) + results <- c(results, trans$results[-1]) data <- trans$data - - results <- c(results, trans$results) + dic <- trans$dictionary } - } - - #Transform them to No/Yes: - - data <- data %>% - dplyr::mutate(dplyr::across( - tidyselect::all_of(var_check), - ~ factor(.x, levels = 0:1, labels = checkbox_labels) - )) - - # Reapply the original labels after transforming the checkboxes to factors - data <- data |> - labelled::set_variable_labels(.labels = labels |> as.list(), .strict = FALSE) - - #Change the variable names and their branching logic: - - data_dic <- checkbox_names(data, dic, labels, checkbox_labels) - - data <- data_dic$data - dic <- data_dic$dic - - - }else{ - + } else { results <- c(results, "\nNo checkboxes are found in the data\n") - } - #Replace original variables with their factor version except for redcap_event_name and redcap_data_access_group - #If we dont want to convert another additional variable to factor we can specify it with the exclude argument: + # Replace original variables with their factor version except for redcap_event_name and redcap_data_access_group + # If we dont want to convert another additional variable to factor we can specify it with the exclude argument: - factors <- names(data)[grep("\\.factor$",names(data))] + factors <- names(data)[grep("\\.factor$", names(data))] if (length(factors) > 0) { results <- c(results, stringr::str_glue("\n\n{ind}. Replacing original variables for their factor version")) ind <- ind + 1 - data_dic <- to_factor(data, dic, exclude = exclude_to_factor) # This step also transforms the branching logic of the factors + data_dic <- rd_factor(data = data, dic = dic, exclude = exclude_factor) data <- data_dic$data - dic <- data_dic$dic + dic <- data_dic$dictionary } - #Fix variables that instead of missing have an empty field (text variables, etc.): - data <- data %>% - #Fix characters: - dplyr::mutate_if(is.character, ~ gsub("^$", NA, .x)) %>% - #Fix factors: - dplyr::mutate_if(is.factor,function(x){levels(x)[levels(x)==""] <- NA; x}) + # Fix variables that instead of missing have an empty field (text variables, etc.): + data <- data |> + # Fix characters: + dplyr::mutate_if(is.character, ~ gsub("^$", NA, .x)) |> + # Fix factors: + dplyr::mutate_if(is.factor, function(x) { + levels(x)[levels(x) == ""] <- NA + x + }) if (!repeat_instrument) { # Transform the branching logic from the dictionary which is in REDCap logic (raw) into R logic results <- c(results, stringr::str_glue("\n\n{ind}. Converting every branching logic in the dictionary into R logic")) ind <- ind + 1 - pos <- which(!dic$branching_logic_show_field_only_if %in% "") - logics <- NULL - - for (i in pos) { + dic_trans <- rd_dictionary(data = data, dic = dic, event_form = event_form) - evaluation <- try(rd_rlogic(data = data, dic = dic, event_form = event_form, logic = dic$branching_logic_show_field_only_if[i], var = dic$field_name[i])$rlogic, silent = T) + dic <- dic_trans$dictionary - if (!inherits(evaluation, "try-error")) { - - dic$branching_logic_show_field_only_if[i] <- rd_rlogic(data = data, dic = dic, event_form = event_form, logic = dic$branching_logic_show_field_only_if[i], var = dic$field_name[i])$rlogic - - } else { - - logics <- rbind(logics, dic$field_name[i]) - - } - } - - if (!is.null(logics)) { - - tabla <- tibble::tibble("Variables" = logics) - results <- c(results, "\n", knitr::kable(tabla, "pipe", align = c("ccc"), caption = "Variables with unconverted branching logic")) - - } + results <- c(results, dic_trans$results[-1]) } - #Arrange our dataset by record_id and event (will keep the same order of events as in redcap) - if(longitudinal) { - if("redcap_event_name.factor" %in% names(data)) { - data <- data %>% + # Arrange our dataset by record_id and event (will keep the same order of events as in redcap) + if (longitudinal) { + if ("redcap_event_name.factor" %in% names(data)) { + data <- data |> dplyr::arrange(factor(.data$record_id, levels = unique(.data$record_id)), .data$redcap_event_name.factor) } else { - data <- data %>% + data <- data |> dplyr::arrange(factor(.data$record_id, levels = unique(.data$record_id)), .data$redcap_event_name) } } - - # Reapply labels to the modified dataset + + # Apply labels to data data <- data |> labelled::set_variable_labels(.labels = labels |> as.list(), .strict = FALSE) - #If an event_form is specified or if the project has only one event and by_form has been specified - if(!is.null(event_form) | (final_format == "by_form" & !longitudinal)){ - - if(!is.null(event_form)){ - var_noevent <- dic$field_name[! dic$form_name %in% event_form$form] - - if(length(var_noevent) > 0){ + # If an event_form is specified or if the project has only one event and by_form has been specified + if (!is.null(event_form) | (final_format == "by_form" & !longitudinal)) { + if (!is.null(event_form)) { + var_noevent <- dic$field_name[!dic$form_name %in% event_form$form] + if (length(var_noevent) > 0) { results <- c(results, stringr::str_glue("\n\n{ind}. Erasing variables from forms that are not linked to any event")) ind <- ind + 1 var_noevent <- var_noevent[var_noevent %in% names(data)] - data <- data %>% + data <- data |> dplyr::select(-var_noevent) - dic <- dic %>% - dplyr::filter(! .data$field_name %in% var_noevent) + dic <- dic |> + dplyr::filter(!.data$field_name %in% var_noevent) } - } - #Final arrangment - - if(final_format == "by_event"){ + # Final arrangment - results <- c(results,stringr::str_glue("\n\n{ind}. Final arrangment of the data by event")) + if (final_format == "by_event") { + results <- c(results, stringr::str_glue("\n\n{ind}. Final arrangment of the data by event")) ind <- ind + 1 - if(is.null(which_event)){ + if (is.null(which_event)) { + split <- rd_split(data = data, dic = dic, event_form = event_form, by = "event") - data <- split_event(data, dic, event_form) - - }else{ - - data <- split_event(data,dic,event_form,which=which_event) + data <- split$data + } else { + split <- rd_split(data = data, dic = dic, event_form = event_form, by = "event", which = which_event) + data <- split$data } - - }else if(final_format == "by_form"){ - + } else if (final_format == "by_form") { results <- c(results, stringr::str_glue("{ind}. Final arrangment of the data by form")) ind <- ind + 1 - if(is.null(wide)){ + if (is.null(wide)) { wide <- FALSE } - if(is.null(which_form)){ + if (is.null(which_form)) { + if (longitudinal) { + split <- rd_split(data = data, dic = dic, event_form = event_form, by = "form", which = NULL, wide = wide) - if(longitudinal){ - data <- split_form(data, dic, event_form, which = NULL, wide) - }else{ - data <- split_form(data, dic, which = NULL, wide) + data <- split$data + } else { + split <- rd_split(data = data, dic = dic, by = "form", which = NULL, wide = wide) + + data <- split$data } + } else { + if (longitudinal) { + split <- rd_split(data = data, dic = dic, event_form = event_form, by = "form", which = which_form, wide = wide) - }else{ - if(longitudinal){ - data <- split_form(data, dic, event_form, which=which_form, wide) - }else{ - data <- split_form(data, dic, which=which_form, wide) + data <- split$data + } else { + split <- rd_split(data = data, dic = dic, by = "form", which = which_form, wide = wide) + + data <- split$data } } - } - if(!is.null(event_form)) { + if (!is.null(event_form)) { list( data = data, dictionary = dic, @@ -473,11 +346,8 @@ rd_transform <- function(..., data = NULL, dic = NULL, event_form = NULL, checkb results = stringr::str_glue("{results}") ) } - - - }else { - - if(!is.null(event_form)) { + } else { + if (!is.null(event_form)) { list( data = data, dictionary = dic, @@ -491,8 +361,5 @@ rd_transform <- function(..., data = NULL, dic = NULL, event_form = NULL, checkb results = stringr::str_glue("{results}") ) } - } - - } diff --git a/R/redcap_data.R b/R/redcap_data.R index 8fedf71..8c3bf29 100644 --- a/R/redcap_data.R +++ b/R/redcap_data.R @@ -1,93 +1,104 @@ #' Read REDCap data #' #' @description -#' This function allows users to read datasets from a REDCap project into R for analysis, either by exporting the data or via an API connection. +#' `r lifecycle::badge('stable')` #' -#' The REDCap API serves as an interface for communication with REDCap and the server without requiring interaction through the REDCap interface. +#' Import REDCap data into R either from REDCap's exported R file or directly via the REDCap API. The function returns a list with the dataset, the project dictionary (metadata) and, for longitudinal projects, the instrument–event mapping (`event_form`) when available. #' -#' [Important] To read exported data from REDCap, please follow these steps: +#' @details +#' Two import modes are supported: +#' * **Exported files** — use `data_path` (REDCap R export) and `dic_path` (dictionary CSV/XLSX). +#' * **API** — use `uri` and `token` to pull data and metadata directly from REDCap. #' -#' - Use REDCap's 'Export Data' function. +#' If the project is longitudinal, provide `event_path` (instrument–event mapping) +#' or the function will attempt to fetch it from the API when using API mode. #' -#' - Select the 'R Statistical Software' format. +#' **Steps for using exported data in REDCap:** +#' 1. Use the REDCap *Export Data* function and choose *R Statistical Software* format. +#' 2. REDCap generates: +#' - A CSV file with observations. +#' - An R script to format variables for import. +#' 3. Ensure the exported files, dictionary, and event mapping (if any) are in the same directory. #' -#' - REDCap will then generate two files: #' -#' - A CSV file containing all observations of the REDCap project. +#' @note To use other package functions effectively, include the `dic_path` argument to load the project dictionary. #' -#' - An R file with the necessary code to complete each variable's information and import them. +#' @param data_path Path to exported R file (use with `dic_path`). +#' @param dic_path Path to the dictionary file (CSV or XLSX; use with `data_path`).. +#' @param event_path Path to the event-form mapping file (CSV or XLSX) for longitudinal projects (downloadable via the `Designate Instruments for My Events` tab within the `Project Setup` section of REDCap). +#' @param uri REDCap API base URI (use with `token`). +#' @param token REDCap API token (use with `uri`). +#' @param filter_field Optional character vector of field names to request from the API. +#' @param survey_fields Logical; include survey-related fields when pulling via API. Default `FALSE`. #' -#' - Ensure these files, along with the dictionary and event-mapping, are in the same directory. -#' -#' @note For further use of the package, it's recommended to use the `dic_path` argument to read the dictionary, as all other functions require it for proper functioning. -#' -#' @param data_path Character string specifying the path of the R file from which the dataset will be read. -#' @param dic_path Character string with the path of the dictionary. -#' @param event_path Character string specifying the path of the file containing the correspondence between each event and each form (downloadable via the `Designate Instruments for My Events` tab within the `Project Setup` section of REDCap). -#' @param uri The URI (Uniform Resource Identification) of the REDCap project. -#' @param token Character vector containing the generated token. -#' @param filter_field Character vector specifying the fields of the REDCap project desired to be imported into R (via API connection only). -#' @param survey_fields Logical indicating whether the function should download all the survey-related fields of the REDCap project (via API connection only). -#' @return A list containing the dataset and the dictionary of the REDCap project. If `event_path` is specified, it will also contain a third element with the correspondence of the events and forms of the project. +#' @return A list with: +#' - `data`: Imported dataset. +#' - `dictionary`: Variable dictionary (project metadata). +#' - `event_form`: Event-form mapping for longitudinal projects (if applicable). #' +#' @note +#' * Use either exported-files mode (`data_path` + `dic_path`) **or** API mode (`uri` + `token`) — not both. +#' * For exported files, REDCap's R export is required for `data_path`. Dictionary and event files must be CSV or XLSX. #' #' @examples #' \dontrun{ -#' # Exported files from REDCap -#' -#' dataset <- redcap_data(data_path = "C:/Users/username/example.r", -#' dic_path = "C:/Users/username/example_dictionary.csv", -#' event_path = "C:/Users/username/events.csv") -#' -#' # API connection -#' -#' dataset_api <- redcap_data(uri = "https://redcap.idibell.cat/api/", -#' token = "55E5C3D1E83213ADA2182A4BFDEA") # This token is fictitious +#' # From exported files +#' out <- redcap_data( +#' data_path = "project_export.r", +#' dic_path = "project_dictionary.csv", +#' event_path = "instrument_event_map.csv" +#' ) #' +#' # From API +#' out_api <- redcap_data( +#' uri = "https://redcap.example.org/api/", +#' token = "REPLACE_WITH_TOKEN" +#' ) #' } +#' #' @export +#' @importFrom stats setNames -redcap_data <- function(data_path = NA, dic_path = NA, event_path = NA, uri = NA, token = NA, filter_field = NULL, survey_fields = FALSE) - { +redcap_data <- function(data_path = NA, dic_path = NA, event_path = NA, uri = NA, token = NA, filter_field = NULL, survey_fields = FALSE) { + + event_form <- NULL + + # Save the current working directory and ensure it is restored on exit oldwd <- getwd() on.exit(setwd(oldwd)) # Warning: data_path, dic_path and another argument are specified. if (all(!c(data_path, dic_path) %in% NA) & any(!c(token, uri) %in% NA)) { - stop("Too many arguments, if you want to read exported data from REDCap use only the arguments data_path and dic_path", call. = FALSE) + stop("Too many arguments. Use `data_path` and `dic_path` for exported data or `uri` and `token` for API connection.", call. = FALSE) } # Warning: token, uri and another argument are specified. if (all(!c(token, uri) %in% NA) & any(!c(data_path, dic_path) %in% NA)) { - stop("Too many arguments, if you want to read data from REDCap through an API connection use only the arguments uri and token.", call. = FALSE) + stop("Too many arguments. Use `uri` and `token` for API connection or `data_path` and `dic_path` for exported data.", call. = FALSE) } # Warning: either uri or token is specified alone if ((!is.na(uri) & is.na(token)) | (is.na(uri) & !is.na(token))) { - stop("If you want to read data from REDCap through an API connection, both 'uri' and 'token' arguments must be provided.", call. = FALSE) + stop("Both `uri` and `token` are required for API connection.", call. = FALSE) } - # Read data, dictionary and event-form mapping in case of exported data. + # Process data from exported files if (all(!c(data_path, dic_path) %in% NA) & all(c(token, uri) %in% NA)) { - - # Evaluate the extension of the data_path - + # Check the extension of the R data file if (!grepl("\\.R$", data_path) & !grepl("\\.r$", data_path)) { - stop("Unsupported file format. Only R files are supported. Please specify the downloaded R file from REDCap within this argument.") + stop("Unsupported file format. `data_path` must be an R file exported from REDCap.", call. = FALSE) } - # Read data + # Import the data using the R file tmp_env <- new.env() - file.lines <- scan(data_path, what = character(), skip = 2, sep = '\n', quiet = TRUE) - file.lines.collapsed <- paste(file.lines, collapse = '\n') + file.lines <- scan(data_path, what = character(), skip = 2, sep = "\n", quiet = TRUE) + file.lines.collapsed <- paste(file.lines, collapse = "\n") command <- paste0("dirname(parent.frame(2)$", "data_path", ")") setwd(eval(parse(text = command))) source(textConnection(file.lines.collapsed), local = tmp_env, encoding = "UTF-8") data <- get("data", envir = tmp_env) - if (names(data)[1] != "record_id") { - names(data)[1] <- "record_id" - } - + + # Saving labels before changes labels <- purrr::map_chr(data, function(x) { lab <- attr(x, "label") if (!is.null(lab)) { @@ -97,40 +108,36 @@ redcap_data <- function(data_path = NA, dic_path = NA, event_path = NA, uri = NA } }) - # Read dictionary - setwd(oldwd) + # Ensure the primary identifier column is correctly named + if (names(data)[1] != "record_id") { + names(data)[1] <- "record_id" + } - # Evaluate the extension of the dictionary_path + # Load the dictionary and validate its format + setwd(oldwd) extension_dic <- tools::file_ext(dic_path) - if (extension_dic == "xlsx") { - # Read XLSX file - dic <- openxlsx::read.xlsx(dic_path, colNames = F, detectDates = T, sheet = 1) - + dic <- openxlsx::read.xlsx(dic_path, colNames = FALSE, detectDates = TRUE, sheet = 1) } else if (extension_dic == "csv") { - # Read CSV file dic <- utils::read.csv(dic_path, encoding = "UTF-8", header = FALSE) - } else { - - stop("Unsupported file format. Only XLSX and CSV are supported.") - + stop("Unsupported dictionary format. Only CSV and XLSX are supported.", call. = FALSE) } - # Changing names of the first column and first observation - names(dic) <- dic[1,] - dic <- dic[-1,] + # Process the dictionary: clean names + names(dic) <- dic[1, ] + dic <- dic[-1, ] names(dic) <- janitor::make_clean_names(names(dic)) names(dic)[1] <- "field_name" if (dic[1, 1] != "record_id") { - dic[1,1] <- "record_id" + dic[1, 1] <- "record_id" } # Remove descriptive variables from dictionary if ("descriptive" %in% dic$field_type) { - dic <- dic %>% + dic <- dic |> dplyr::filter(!.data$field_type %in% "descriptive") } @@ -138,186 +145,207 @@ redcap_data <- function(data_path = NA, dic_path = NA, event_path = NA, uri = NA # Indicator of longitudinal projects longitudinal <- ifelse("redcap_event_name" %in% names(data), TRUE, FALSE) - #Read event file + # Read event file if (!is.na(event_path)) { - setwd(oldwd) # Evaluate the extension extension <- tools::file_ext(event_path) if (extension == "xlsx") { - # Read XLSX file - event_form <- openxlsx::read.xlsx(event_path, detectDates = T, sheet = 1) - + event_form <- openxlsx::read.xlsx(event_path, detectDates = TRUE, sheet = 1) } else if (extension == "csv") { - # Read CSV file event_form <- utils::read.csv(event_path, encoding = "UTF-8") - } else { - - stop("Unsupported file format. Only XLSX and CSV are supported.") - + stop("Unsupported event mapping format. Only CSV and XLSX are supported.", call. = FALSE) } - data_def <- list(data = data, dictionary = dic, event_form = event_form) + # Error if the exported event_form file is not the correct one! (using events instead of instrument-event) + if ("event_name" %in% names(event_form)) { + stop("Invalid file provided in `event_path`.\n\nPlease download the instrument-event mapping file from the 'Designate Instruments for My Events' tab of your REDCap project and try again.", + call. = FALSE + ) + } - }else{ - #If no event is specified and the project is longitudinal + # Output + data_def <- list(data = data, dictionary = dic, event_form = event_form) + } else { + # If no event is specified and the project is longitudinal if (longitudinal) { - warning("The project contains more than one event. You might want to load the event-form correspondence using the argument event_path.") + warning("The project is longitudinal. Consider providing `event_path` for event-form correspondence.", call. = FALSE) } data_def <- list(data = data, dictionary = dic) } - } - # Read data, dictionary and event-form mapping in case of an API connection. + # Process data from API connection if (all(!c(token, uri) %in% NA) & all(c(data_path, dic_path) %in% NA)) { + # Message: Begin data import process + message("Importing data from REDCap API...") - # Message - message("Importing in progress...") - - # First read the labels + # Read labels from REDCap ## Error SSL peer certificate (Github issue #6) - tryCatch({labels <- suppressMessages(REDCapR::redcap_read(redcap_uri = uri, token = token, verbose = FALSE, raw_or_label = "label", raw_or_label_headers = "label", export_data_access_groups = TRUE, export_survey_fields = survey_fields, fields = filter_field)$data)}, - error = function(e) { - if(grepl("REDCap's PHP code is likely trying to process too much text in one bite", e$message) & !is.null(filter_field)) { - stop("The `record_id` or equivalent variable is missing on the `filter_field` argument.", call. = F) - } else if (grepl("SSL peer certificate", e$message)) { - stop("Unable to establish a secure connection due to an SSL certificate problem.\nConsider adding the following line of code to bypass SSL certificate verification: httr::with_config(httr::config(ssl_verifypeer = FALSE), ... <- readcap_data(...)).\n", call. = F) - } else { - stop(e) + tryCatch( + { + labels <- suppressMessages(REDCapR::redcap_read(redcap_uri = uri, token = token, verbose = FALSE, raw_or_label = "label", raw_or_label_headers = "label", export_data_access_groups = TRUE, export_survey_fields = survey_fields, fields = filter_field)$data) + }, + error = function(e) { + if (grepl("REDCap's PHP code is likely trying to process too much text in one bite", e$message) & !is.null(filter_field)) { + stop("The `record_id` or equivalent variable is missing on the `filter_field` argument.", call. = FALSE) + } else if (grepl("SSL peer certificate", e$message)) { + stop("Unable to establish a secure connection.\nConsider bypassing SSL verification:\nhttr::with_config(httr::config(ssl_verifypeer = FALSE), ... <- readcap_data(...)).", call. = FALSE) + } else { + stop(e) + } } - }) + ) + # Ensure labels were retrieved and assign a default column name if (nrow(labels) > 0) { names(labels)[1] <- "record_id" } else { - stop("Data retrieval is currently unavailable. Please check the status of the REDCap server, confirm the existence of records within the project and verify that you have the necessary data export and API permissions to perform this operation.", call. = F) + stop("Data retrieval is currently unavailable. Please check the status of the REDCap server, confirm the existence of records within the project and verify that you have the necessary data export and API permissions to perform this operation.", call. = FALSE) } # Save the factor version of the default variables of redcap - redcap_names <- names(labels %>% - dplyr::select(dplyr::any_of(c("Event Name", "Repeat Instrument", "Data Access Group")))) + redcap_names <- names(labels |> + dplyr::select(dplyr::any_of(c("Event Name", "Repeat Instrument", "Data Access Group")))) - default_names <- data.frame(fac = redcap_names) %>% - dplyr::mutate(corres = dplyr::case_when(fac %in% "Event Name" ~ "redcap_event_name.factor", - fac %in% "Repeat Instrument" ~ "redcap_repeat_instrument.factor", - fac %in% "Data Access Group" ~ "redcap_data_access_group.factor")) + default_names <- data.frame(fac = redcap_names) |> + dplyr::mutate(corres = dplyr::case_when( + fac %in% "Event Name" ~ "redcap_event_name.factor", + fac %in% "Repeat Instrument" ~ "redcap_repeat_instrument.factor", + fac %in% "Data Access Group" ~ "redcap_data_access_group.factor" + )) rename_redcap <- default_names$fac names(rename_redcap) <- default_names$corres - main_vars <- labels %>% - dplyr::mutate_at(redcap_names[!redcap_names %in% "Repeat Instrument"], - ~if (all(is.na(.))) . else forcats::fct_inorder(.)) %>% - dplyr::rename(dplyr::all_of(rename_redcap)) %>% + main_vars <- labels |> + dplyr::mutate_at( + redcap_names[!redcap_names %in% "Repeat Instrument"], + ~ if (all(is.na(.))) . else forcats::fct_inorder(.) + ) |> + dplyr::rename(dplyr::all_of(rename_redcap)) |> dplyr::select("record_id", default_names$corres) - # Remove the "...number" suffixes from the labels + # Clean up label names by removing suffixes labels <- gsub("\\.{3}\\d+$", "", names(labels)) - # Message + # Message: Intermediate status update message("Almost done...") - # Read data using the API connection - - data_api <- REDCapR::redcap_read(redcap_uri = uri, token = token, verbose = FALSE, raw_or_label = "raw", export_data_access_groups = TRUE, export_survey_fields = survey_fields, fields = filter_field)$data - + # Fetch main data using the REDCap API + data_api <- REDCapR::redcap_read( + redcap_uri = uri, + token = token, + verbose = FALSE, + raw_or_label = "raw", + export_data_access_groups = TRUE, + export_survey_fields = survey_fields, + fields = filter_field + )$data + + # Ensure data retrieval was successful if (nrow(data_api) > 0) { names(data_api)[1] <- "record_id" } else { - stop("Observational data retrieval is currently unavailable. Please verify the status of the REDCap server or confirm the existence of records within the project.", call. = F) + stop("Observational data retrieval is currently unavailable. Please verify the status of the REDCap server or confirm the existence of records within the project.", call. = FALSE) } - # Read dictionary using the API connection - dic_api <- REDCapR::redcap_metadata_read(redcap_uri = uri, token = token, verbose = FALSE)$data + # Fetch metadata dictionary using the REDCap API + dic_api <- REDCapR::redcap_metadata_read( + redcap_uri = uri, + token = token, + verbose = FALSE + )$data + # Ensure dictionary has appropriate names names(dic_api)[1] <- "field_name" - if (dic_api[1, 1] != "record_id") { - dic_api[1,1] <- "record_id" + dic_api[1, 1] <- "record_id" } - ## Making sure the names of both dictionaries(exported data and API connection) match + # Making sure the names of both dictionaries(exported data and API connection) match names(dic_api)[names(dic_api) %in% c("select_choices_or_calculations", "branching_logic", "question_number")] <- c("choices_calculations_or_slider_labels", "branching_logic_show_field_only_if", "question_number_surveys_only") - - # Apply labels to data_api - data_api <- purrr::map2(data_api, as.list(labels), ~{ + # Apply labels to the main dataset + data_api <- purrr::map2(data_api, as.list(labels), ~ { if (!is.null(.y)) { attr(.x, "label") <- .y } .x - }) %>% + }) |> as.data.frame() - # Remove descriptive variables from dictionary + # Filter descriptive fields from dictionary if ("descriptive" %in% dic_api$field_type) { - dic_api <- dic_api %>% + dic_api <- dic_api |> dplyr::filter(!.data$field_type %in% "descriptive") } - # If filter_field is described, filter the variables in the dictionary + # Filter dictionary fields based on filter_field if provided if (!all(filter_field %in% NA)) { - dic_api <- dic_api %>% + dic_api <- dic_api |> dplyr::filter(.data$field_name %in% filter_field) } - # Identify checkboxes fields and convert them to factor using the dictionary as guide + # Process checkbox fields into factors if (sum(dic_api$field_type %in% "checkbox") > 0) { - var_check <- names(data_api)[grep("___", names(data_api))] - data_api <- data_api %>% + data_api <- data_api |> dplyr::mutate(dplyr::across(dplyr::all_of(var_check), ~ factor(., levels = c("0", "1"), labels = c("Unchecked", "Checked")), .names = "{col}.factor")) - } - # Identify radio buttons and dropdown fields and convert them to factor using the dictionary as guide + # Process radio and dropdown fields into factors if (sum(dic_api$field_type %in% c("radio", "dropdown")) > 0) { - - var_radio <- dic_api %>% - dplyr::filter(.data$field_type %in% c("radio", "dropdown")) %>% - dplyr::select("field_name", "field_type", "choices_calculations_or_slider_labels") %>% - dplyr::mutate(factor = purrr::map(.data$choices_calculations_or_slider_labels, ~stringr::str_split(.x, "\\|") %>% unlist %>% trimws), - levels = purrr::map(factor, ~gsub(",.*", "", .x)), - labels = purrr::map(factor, ~gsub("^[^,]*,\\s*", "", .x))) + var_radio <- dic_api |> + dplyr::filter(.data$field_type %in% c("radio", "dropdown")) |> + dplyr::select("field_name", "field_type", "choices_calculations_or_slider_labels") |> + dplyr::mutate( + factor = purrr::map(.data$choices_calculations_or_slider_labels, ~ stringr::str_split(.x, "\\|") |> + unlist() |> + trimws()), + levels = purrr::map(factor, ~ gsub(",.*", "", .x)), + labels = purrr::map(factor, ~ gsub("^[^,]*,\\s*", "", .x)) + ) for (i in var_radio$field_name) { tryCatch( - {data_api[[stringr::str_glue("{i}.factor")]] <- factor(data_api[[i]], - levels = c(var_radio$levels[[which(var_radio$field_name %in% i)]]), - labels = c(var_radio$labels[[which(var_radio$field_name %in% i)]]))}, + { + data_api[[stringr::str_glue("{i}.factor")]] <- factor(data_api[[i]], + levels = c(var_radio$levels[[which(var_radio$field_name %in% i)]]), + labels = c(var_radio$labels[[which(var_radio$field_name %in% i)]]) + ) + }, error = function(e) { - warning(stringr::str_glue("The following variable could not be replicated in its factor version: {i}. Please manually create a factor version of this variable named '{i}.factor' to properly execute the rd_transform() function."), call. = F) + warning(stringr::str_glue("The following variable could not be replicated in its factor version: {i}. Please manually create a factor version of this variable named '{i}.factor' to properly execute the rd_transform() function."), call. = FALSE) } ) } } - # Join the main_vars to the imported data + # Merge main_vars with imported data - data_api <- data_api %>% - dplyr::bind_cols(main_vars %>% dplyr::select(-"record_id")) + data_api <- data_api |> + dplyr::bind_cols(main_vars |> dplyr::select(-"record_id")) - # Indicator of longitudinal projects + # Determine if project is longitudinal longitudinal <- ifelse("redcap_event_name" %in% names(data_api), TRUE, FALSE) - # Read event file + # Handle event path or fetch event-form correspondence via API if (!is.na(event_path)) { - # Warning: event_path not necessary while using API connection - warning("The event_path argument is not necessary as the event-form correspondence can be automatically read with the API connection") + warning("The event_path argument is not required when using an API connection.") setwd(oldwd) @@ -325,60 +353,97 @@ redcap_data <- function(data_path = NA, dic_path = NA, event_path = NA, uri = NA extension <- tools::file_ext(event_path) if (extension == "xlsx") { - # Read XLSX file - event_form <- openxlsx::read.xlsx(event_path, detectDates = T, sheet = 1) - + event_form <- openxlsx::read.xlsx(event_path, detectDates = TRUE, sheet = 1) } else if (extension == "csv") { - # Read CSV file event_form <- utils::read.csv(event_path, encoding = "UTF-8") - } else { - stop("Unsupported file format. Only XLSX and CSV formats are supported.") + } + # Error if the exported event_form file is not the correct one! (using events instead of instrument-event) + if ("event_name" %in% names(event_form)) { + stop("Invalid file provided in `event_path`.\n\nPlease download the instrument-event mapping file from the 'Designate Instruments for My Events' tab of your REDCap project and try again.", + call. = FALSE + ) } - data_def <- list(data = data_api, - dictionary = dic_api, - event_form = event_form) + # Output + data_def <- list( + data = data_api, + dictionary = dic_api, + event_form = event_form + ) } else { - # If the event file is not specified, the function reads it using the API connection (in case of longitudinal projects) if (longitudinal) { - event_form <- as.data.frame(REDCapR::redcap_event_instruments(redcap_uri = uri, token = token, verbose = FALSE)$data) - data_def <- list(data = data_api, - dictionary = dic_api, - event_form = event_form) - + data_def <- list( + data = data_api, + dictionary = dic_api, + event_form = event_form + ) } else { - - data_def <- list(data = data_api, - dictionary = dic_api) - + data_def <- list( + data = data_api, + dictionary = dic_api + ) } - } - # Message - message("Done!") + # Message: Completion + message("API data import completed.") } - - # Specifying the "UTF-8" encoding to each character column of the data - for (i in 1:length(data_def$data)) { + + # Apply UTF-8 encoding to character columns + for (i in seq_along(data_def$data)) { if (is.character(data_def$data[, i])) { suppressWarnings(data_def$data[, i] <- stringr::str_conv(data_def$data[, i], "UTF-8")) } } - + + # Transform empty values into missing values (NA) + data_def$data <- data_def$data |> + # Fix characters: + dplyr::mutate_if(is.character, ~ gsub("^$", NA, .x)) |> + # Fix factors: + dplyr::mutate_if(is.factor, function(x) { + levels(x)[levels(x) == ""] <- NA + x + }) + + # Remove variables with no corresponding event + if (!is.null(event_form)) { + var_noevent <- data_def$dictionary |> + dplyr::filter(!.data$form_name %in% event_form$form) |> + dplyr::pull(.data$field_name) + + if (length(var_noevent) > 0) { + + vars_str <- paste(var_noevent, collapse = ", ") + + warning( + sprintf("The following variable%s were removed since they are not linked to any event: %s", + ifelse(length(var_noevent) > 1, "s", ""), vars_str), + call. = FALSE + ) + + var_noevent <- intersect(var_noevent, names(data)) + + data_def$data <- data_def$data |> + dplyr::select(-dplyr::any_of(var_noevent)) + + data_def$dictionary <- data_def$dictionary |> + dplyr::filter(!.data$field_name %in% var_noevent) + } + } + # Reapply labels to the modified dataset data_def$data <- data_def$data |> labelled::set_variable_labels(.labels = labels |> as.list(), .strict = FALSE) - # Output + # Return the result return(data_def) - } diff --git a/R/suplementary_package.R b/R/suplementary_package.R index 463e4fc..3ba036d 100644 --- a/R/suplementary_package.R +++ b/R/suplementary_package.R @@ -1,3 +1,7 @@ +# -------------------------------------------------------------- +# All credits for this functionality go to the Tidyverse package +# GitHub: https://github.com/tidyverse +# -------------------------------------------------------------- #' @import cli inform_startup <- function(msg, ...) { @@ -11,79 +15,73 @@ inform_startup <- function(msg, ...) { rlang::inform(msg, ..., class = "packageStartupMessage") } -core <- c("dplyr", "janitor", "magrittr", "openxlsx", "purrr", "REDCapR", "rlang", "stringr", "tibble", "tidyr", "tidyselect", "utils", "stringi", "labelled") +core <- c("REDCapR", "openxlsx", "labelled", "dplyr", "janitor", "purrr", "rlang", "stringr", "forcats", "tibble", "tidyr", "tidyselect", "utils", "stringi", "cli", "lifecycle") - core_unloaded <- function() { - search <- paste0("package:", core) - core[!search %in% search()] - } +core_unloaded <- function() { + search <- paste0("package:", core) + core[!search %in% search()] +} - # Attach the package from the same package library it was - same_library <- function(pkg) { - loc <- - if (pkg %in% loadedNamespaces()) - dirname(getNamespaceInfo(pkg, "path")) - library( - pkg, - lib.loc = loc, - character.only = TRUE, - warn.conflicts = FALSE - ) - } +# Attach the package from the same package library it was +same_library <- function(pkg) { + loc <- if (pkg %in% loadedNamespaces()) dirname(getNamespaceInfo(pkg, "path")) + library(pkg, lib.loc = loc, character.only = TRUE, warn.conflicts = FALSE) +} - REDCapDM_attach <- function() { - to_load <- core_unloaded() +REDCapDM_attach <- function() { + to_load <- core_unloaded() - suppressPackageStartupMessages(lapply(to_load, same_library)) + suppressPackageStartupMessages(lapply(to_load, same_library)) - invisible(to_load) - } + invisible(to_load) +} - REDCapDM_attach_message <- function(to_load) { - if (length(to_load) == 0) { - return(NULL) - } - - header <- cli::rule( - left = cli::style_bold("Attaching core REDCapDM packages"), - right = paste0("REDCapDM ", package_version_h("REDCapDM")) - ) - - to_load <- sort(to_load) - versions <- vapply(to_load, package_version_h, character(1)) - - packages <- paste0( - cli::col_green(cli::symbol$tick), - " ", - cli::col_blue(format(to_load)), - " ", - cli::ansi_align(versions, max(cli::ansi_nchar(versions))) - ) - - if (length(packages) %% 2 == 1) { - packages <- append(packages, "") - } - col1 <- seq_len(length(packages)) - info <- paste0(packages[col1], " ", packages[-col1]) - - paste0(header, "\n", paste(info, collapse = "\n")) +REDCapDM_attach_message <- function(to_load) { + if (length(to_load) == 0) { + return(NULL) } - package_version_h <- function(pkg) { - highlight_version(utils::packageVersion(pkg)) + header <- cli::rule( + left = cli::style_bold("Attaching core REDCapDM packages"), + right = paste0("REDCapDM ", package_version_h("REDCapDM")) + ) + + to_load <- sort(to_load) + versions <- vapply(to_load, package_version_h, character(1)) + + packages <- paste0( + cli::col_green(cli::symbol$tick), + " ", + cli::col_blue(format(to_load)), + " ", + cli::ansi_align(versions, max(cli::ansi_nchar(versions))) + ) + + if (length(packages) %% 2 == 1) { + packages <- append(packages, "") } + col1 <- seq_len(length(packages) / 2) + info <- paste0(packages[col1], " ", packages[-col1]) - highlight_version <- function(x) { - x <- as.character(x) + paste0(header, "\n", paste(info, collapse = "\n")) +} - is_dev <- function(x) { - x <- suppressWarnings(as.numeric(x)) - ! is.na(x) & x >= 9000 - } +package_version_h <- function(pkg) { + highlight_version(utils::packageVersion(pkg)) +} - pieces <- strsplit(x, ".", fixed = TRUE) - pieces <- - lapply(pieces, function(x) - ifelse(is_dev(x), cli::col_red(x), x)) - vapply(pieces, paste, collapse = ".", FUN.VALUE = character(1)) +highlight_version <- function(x) { + x <- as.character(x) + + is_dev <- function(x) { + x <- suppressWarnings(as.numeric(x)) + !is.na(x) & x >= 9000 } + + pieces <- strsplit(x, ".", fixed = TRUE) + pieces <- + lapply(pieces, function(x) { + ifelse(is_dev(x), cli::col_red(x), x) + }) + vapply(pieces, paste, collapse = ".", FUN.VALUE = character(1)) +} diff --git a/R/utils-pipe.R b/R/utils-pipe.R deleted file mode 100644 index fd0b1d1..0000000 --- a/R/utils-pipe.R +++ /dev/null @@ -1,14 +0,0 @@ -#' Pipe operator -#' -#' See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. -#' -#' @name %>% -#' @rdname pipe -#' @keywords internal -#' @export -#' @importFrom magrittr %>% -#' @usage lhs \%>\% rhs -#' @param lhs A value or the magrittr placeholder. -#' @param rhs A function call using the magrittr semantics. -#' @return The result of calling `rhs(lhs)`. -NULL diff --git a/R/utils-suplement.R b/R/utils-suplement.R new file mode 100644 index 0000000..e9e0cad --- /dev/null +++ b/R/utils-suplement.R @@ -0,0 +1,108 @@ +############### Other functions############### + +## Fill_data ---- + +#' Fill Rows with Values from One Event +#' @description +#' This function fills all rows in the dataset with the value of a particular variable in a specified event. It is an auxiliary function used in the `rd_rlogic` function. +#' @param which_event String specifying the name of the event. +#' @param which_var String specifying the name of the variable. +#' @param data Dataset containing the REDCap data. + +fill_data <- function(which_event, which_var, data) { + + if (!which_event %in% data$redcap_event_name) { + stop("The logic can't be evaluated after the translation", call. = FALSE) + } + + fill_values <- data |> + dplyr::select("record_id", "redcap_event_name", dplyr::all_of(which_var)) |> + dplyr::rename(var = dplyr::all_of(which_var)) |> + dplyr::group_by(.data$record_id) |> + dplyr::mutate(var = dplyr::case_when(.data$redcap_event_name != which_event ~ NA, TRUE ~ .data$var)) |> + tidyr::fill("var", .direction = "downup") |> + dplyr::pull("var") + + data[[which_var]] <- fill_values + + data +} + + +## Check_proj ---- + +#' Handle Project Arguments +#' +#' This helper function processes the `project` argument in the several other functions. +#' It extracts data, dictionary, event form, and results from the project object while handling +#' potential duplication and providing warnings when arguments are provided redundantly. +#' +#' @param project A list or object containing `data`, `dictionary`, and optionally `event_form` and `results`. +#' @param data A data frame (optional) that may be overridden if provided in the `project` object. +#' @param dic A data dictionary (optional) that may be overridden if provided in the `project` object. +#' @param event_form An optional event-form object that may be overridden if provided in the `project`. +#' +#' +check_proj <- function(project, data = NULL, dic = NULL, event_form = NULL) { + # Ensure 'project' is a list + if (!is.list(project)) { + stop("The 'project' argument must be a list.", call. = FALSE) + } + + # Check for `data` duplication + if (!is.null(data)) { + warning("Data has been provided twice. The function will ignore the `data` argument.") + } + + # Check for `dic` duplication + if (!is.null(dic)) { + warning("Dictionary has been provided twice. The function will ignore the `dic` argument.") + } + + # Extract data and dictionary from the project + data <- if (!is.null(project$data)) project$data else if (!is.null(project$dat)) project$dat else NULL + dic <- if (!is.null(project$dictionary)) project$dictionary else if (!is.null(project$dic)) project$dic else NULL + + # Handle `event_form` duplication + if ("event_form" %in% names(project)) { + if (!is.null(event_form)) { + warning("Event-form has been provided twice. The function will ignore the `event_form` argument.") + } + event_form <- project$event_form + } + + # Extract results from the project if present + if ("results" %in% names(project)) { + results <- project$results + } else { + results <- NULL + } + + # Return updated arguments as a list + list( + data = data, dic = dic, event_form = event_form, results = results + ) +} + + +#' Round Numbers to a Specified Number of Digits ---- +#' +#' This function rounds numeric values to the specified number of decimal digits, +#' mimicking the behavior of the base R `round()` function but implemented manually. +#' +#' @param x A numeric vector to be rounded. +#' @param digits Integer indicating the number of decimal places to round to. +#' +#' @return A numeric vector rounded to the specified number of digits. +#' @examples +#' round(3.14159, 2) +#' round(c(-2.718, 3.14159), 1) +#' +round <- function(x, digits) { + posneg <- sign(x) + z <- abs(x) * 10^digits + z <- z + 0.5 + sqrt(.Machine$double.eps) + z <- trunc(z) + z <- z / 10^digits + z * posneg +} diff --git a/R/utils-transform.R b/R/utils-transform.R index dbe315d..b5f5ffa 100644 --- a/R/utils-transform.R +++ b/R/utils-transform.R @@ -10,10 +10,12 @@ #' @param event_form Data frame containing the correspondence of each event with each form. #' @param exclude_recalc Character vector with the names of the variables that should not be recalculated. Useful for projects with time-consuming recalculations for certain calculated fields. #' @importFrom rlang := -#' + ############Calculated functions############ recalculate <- function(data, dic, event_form = NULL, exclude_recalc = NULL){ + lifecycle::deprecate_warn("1.0.0", "recalculate()", "rd_recalculate()") + #Redefine rounding function (the round original function is troublesome for some special cases) round = function(x, digits) { posneg = sign(x) @@ -25,8 +27,8 @@ recalculate <- function(data, dic, event_form = NULL, exclude_recalc = NULL){ } #Calculate for each calculated field the transcribed logic and if possible to transcribe recalculate it - calc <- tibble::tibble(dic) %>% - dplyr::filter(.data$field_type == "calc", !.data$field_name %in% exclude_recalc) %>% + calc <- tibble::tibble(dic) |> + dplyr::filter(.data$field_type == "calc", !.data$field_name %in% exclude_recalc) |> dplyr::mutate( calc = purrr::map(.data$field_name, function(x) { val <- data[, x] @@ -71,12 +73,12 @@ recalculate <- function(data, dic, event_form = NULL, exclude_recalc = NULL){ NA } }) - ) %>% + ) |> dplyr::select(-"rlogic") #Add this recalculated variables to data and dictionary and return both datasets - calc_change <- calc %>% + calc_change <- calc |> dplyr::filter(!is.na(.data$trans)) if(nrow(calc_change) > 0){ @@ -85,11 +87,11 @@ recalculate <- function(data, dic, event_form = NULL, exclude_recalc = NULL){ name <- stringr::str_glue("{calc_change$field_name[i]}_recalc") - data <- data %>% + data <- data |> tibble::add_column("{name}" := calc_change$recalc[[i]], .after = as.character(calc_change$field_name[i])) - add_row <- dic %>% - dplyr::filter(.data$field_name == calc_change$field_name[i]) %>% + add_row <- dic |> + dplyr::filter(.data$field_name == calc_change$field_name[i]) |> dplyr::mutate( field_name = stringr::str_glue("{field_name}_recalc"), field_label = stringr::str_glue("{field_label} (Recalculate)") @@ -103,24 +105,24 @@ recalculate <- function(data, dic, event_form = NULL, exclude_recalc = NULL){ #Summary of the results - report1 <- calc %>% - dplyr::mutate(n = 1) %>% + report1 <- calc |> + dplyr::mutate(n = 1) |> dplyr::summarise( trans = sum(!is.na(.data$trans)), N = sum(.data$n), no_trans = .data$N - .data$trans, no_equal = sum(!.data$is_equal, na.rm = TRUE), - ) %>% + ) |> dplyr::mutate(text1 = stringr::str_glue("{no_trans} ({round(no_trans*100/N, 2)}%)"), text2 = stringr::str_glue("{no_equal} ({round(no_equal*100/trans, 2)}%)") - ) %>% + ) |> dplyr::select("Total calculated fields" = "N", "Non-transcribed fields" = "text1", "Recalculated different fields" = "text2") results <- knitr::kable(report1, "pipe", align = "ccc") - report2 <- calc %>% - dplyr::mutate(trans2 = ifelse(!is.na(.data$trans), "Yes", "No")) %>% - dplyr::arrange(.data$trans2, .data$is_equal) %>% + report2 <- calc |> + dplyr::mutate(trans2 = ifelse(!is.na(.data$trans), "Yes", "No")) |> + dplyr::arrange(.data$trans2, .data$is_equal) |> dplyr::select("field_name", "Transcribed?" = "trans2", "Is equal?" = "is_equal") results <- c(results, "\n", knitr::kable(report2, "pipe", align = "ccc")) @@ -149,6 +151,8 @@ recalculate <- function(data, dic, event_form = NULL, exclude_recalc = NULL){ transform_checkboxes <- function(data, dic, event_form = NULL, checkbox_na = FALSE){ + lifecycle::deprecate_warn("1.0.0", "transform_checkboxes()", "rd_checkbox()") + vars <- dic$field_name[dic$field_type=="checkbox"] results <- results1 <- results2 <- NULL caption <- "Checkbox variables advisable to be reviewed" @@ -236,6 +240,8 @@ transform_checkboxes <- function(data, dic, event_form = NULL, checkbox_na = FAL checkbox_names <- function(data, dic, labels, checkbox_labels = c("No", "Yes")){ + lifecycle::deprecate_warn("1.0.0", "checkbox_names()", "rd_checkbox()") + correspondence <- NULL #Identify checkbox variables: @@ -253,18 +259,18 @@ checkbox_names <- function(data, dic, labels, checkbox_labels = c("No", "Yes")){ label <- gsub("\\)","",label) #Add rows with the name of all the variables for all the options - new_row <- dic %>% + new_row <- dic |> dplyr::filter(.data$field_name==names_trim[i]) #We have to repeat the original row n times (the length of svar_check) - new_row <- purrr::map_dfr(seq_len(length(svar_check)), ~new_row) %>% + new_row <- purrr::map_dfr(seq_len(length(svar_check)), ~new_row) |> dplyr::mutate( field_name=svar_check, field_label=label, choices_calculations_or_slider_labels=stringr::str_glue("0, {checkbox_labels[1]} | 1, {checkbox_labels[2]}")) - dic <- dic %>% - tibble::add_row(new_row, .before = which(dic$field_name==names_trim[i])) %>% + dic <- dic |> + tibble::add_row(new_row, .before = which(dic$field_name==names_trim[i])) |> #Remove the original checkbox variable that was present in the beginning dplyr::filter(!.data$field_name%in%names_trim[i]) @@ -294,7 +300,7 @@ checkbox_names <- function(data, dic, labels, checkbox_labels = c("No", "Yes")){ TRUE ~ names(data) ) - dic <- dic %>% + dic <- dic |> dplyr::mutate( field_name = dplyr::case_when( field_name == svar_check[j] ~ out[j], @@ -307,27 +313,27 @@ checkbox_names <- function(data, dic, labels, checkbox_labels = c("No", "Yes")){ # Transforming the branching logic that contain checkboxes correspondence <- as.data.frame(correspondence) - cats <- dic %>% - dplyr::select("field_name", "choices_calculations_or_slider_labels") %>% + cats <- dic |> + dplyr::select("field_name", "choices_calculations_or_slider_labels") |> dplyr::filter(.data$field_name %in% correspondence$out) - cats <- cats %>% - dplyr::mutate(choices_calculations_or_slider_labels = strsplit(.data$choices_calculations_or_slider_labels, "\\|")) %>% + cats <- cats |> + dplyr::mutate(choices_calculations_or_slider_labels = strsplit(.data$choices_calculations_or_slider_labels, "\\|")) |> tidyr::unnest(.data$choices_calculations_or_slider_labels) - cats <- cats %>% - tidyr::separate(.data$choices_calculations_or_slider_labels, c("num", "cat"), ", ", extra = "merge") %>% - dplyr::filter(.data$cat != "") %>% + cats <- cats |> + tidyr::separate(.data$choices_calculations_or_slider_labels, c("num", "cat"), ", ", extra = "merge") |> + dplyr::filter(.data$cat != "") |> dplyr::mutate(num = trimws(.data$num), cat = trimws(.data$cat)) cats <- merge(cats, correspondence, by.x = "field_name", by.y = "out") - cats <- cats %>% + cats <- cats |> dplyr::mutate(factor = paste0("[", .data$field_name, "]='", .data$cat, "'"), V1 = stringi::stri_replace_all_fixed(cats$V1, c("(", ")"), c("\\(", "\\)"), vectorize_all = F), redcap = paste0("\\[", .data$V1, "\\] ?=? ?'?", .data$num, "'?"), - redcap2 = paste0("\\[", .data$V1, "\\] ?? ?'?", .data$num, "'?")) %>% - dplyr::select(-"V1") %>% + redcap2 = paste0("\\[", .data$V1, "\\] ?? ?'?", .data$num, "'?")) |> + dplyr::select(-"V1") |> dplyr::arrange(dplyr::desc(.data$redcap)) replace <- cats$factor @@ -336,7 +342,7 @@ checkbox_names <- function(data, dic, labels, checkbox_labels = c("No", "Yes")){ replace2 <- cats$factor names(replace2) <- cats$redcap2 - dic <- dic %>% + dic <- dic |> dplyr::mutate(branching_logic_show_field_only_if = stringr::str_replace_all(.data$branching_logic_show_field_only_if, replace), branching_logic_show_field_only_if = stringr::str_replace_all(.data$branching_logic_show_field_only_if, replace2)) @@ -361,13 +367,15 @@ checkbox_names <- function(data, dic, labels, checkbox_labels = c("No", "Yes")){ split_event <- function(data,dic,event_form,which=NULL){ + lifecycle::deprecate_warn("1.0.0", "split_event()", "rd_split()") + #We create event-variable correspondence from the variables in the dictionary: - var_event <- event_form %>% - dplyr::select("form_name"="form","redcap_event_name"="unique_event_name") %>% - dplyr::right_join(dic[, c("form_name","field_name","field_type","branching_logic_show_field_only_if")], by = "form_name", multiple = "all") %>% + var_event <- event_form |> + dplyr::select("form_name"="form","redcap_event_name"="unique_event_name") |> + dplyr::right_join(dic[, c("form_name","field_name","field_type","branching_logic_show_field_only_if")], by = "form_name", multiple = "all") |> #Remove variables that are not in the database (the descriptive type) - dplyr::filter(.data$field_type!="descriptive", .data$field_name != "record_id") %>% - tibble::as_tibble() %>% + dplyr::filter(.data$field_type!="descriptive", .data$field_name != "record_id") |> + tibble::as_tibble() |> dplyr::select("redcap_event_name", "field_name") #Let's add the basic variables from redcap that are found in the data but not in the dictionary: @@ -414,19 +422,19 @@ split_event <- function(data,dic,event_form,which=NULL){ list_events <- stats::na.exclude(unique(var_event$redcap_event_name)) - ndata <- tibble::tibble("events"=list_events) %>% + ndata <- tibble::tibble("events"=list_events) |> dplyr::mutate( vars = purrr::map( .data$events, - ~ var_event %>% - dplyr::filter(.data$redcap_event_name == .x) %>% + ~ var_event |> + dplyr::filter(.data$redcap_event_name == .x) |> dplyr::pull("field_name") ), df = purrr::map2( .data$events, .data$vars, - ~ data %>% - dplyr::filter(.data$redcap_event_name == .x) %>% + ~ data |> + dplyr::filter(.data$redcap_event_name == .x) |> dplyr::select(tidyselect::all_of(c(basic_redcap_vars, .y))) ) ) @@ -452,6 +460,8 @@ split_event <- function(data,dic,event_form,which=NULL){ split_form <- function(data, dic, event_form = NULL, which = NULL, wide=FALSE){ + lifecycle::deprecate_warn("1.0.0", "split_form()", "rd_split()") + #Check if the project is longitudinal or not: longitudinal <- ifelse("redcap_event_name" %in% names(data), TRUE, FALSE) @@ -469,6 +479,16 @@ split_form <- function(data, dic, event_form = NULL, which = NULL, wide=FALSE){ repeat_instrument <- FALSE } + #Check if the project has repeated instruments + if("redcap_repeat_instrument" %in% names(data)) { + repeat_instrument <- dplyr::case_when( + any(!is.na(data$redcap_repeat_instrument)) ~ TRUE, + TRUE ~ FALSE + ) + } else { + repeat_instrument <- FALSE + } + #Find basic REDCap variables found in the database basic_redcap_vars <- c("record_id","redcap_event_name","redcap_repeat_instrument", "redcap_repeat_instrument.factor","redcap_repeat_instance","redcap_data_access_group","redcap_event_name.factor", "redcap_data_access_group.factor", "redcap_survey_identifier") @@ -476,7 +496,7 @@ split_form <- function(data, dic, event_form = NULL, which = NULL, wide=FALSE){ #Previous to begin with the transformation let's find if there're the same variables in the data base than in the dictionary #But first we have to remove from the dictionary the descriptive variables that are found in the dictionary but not in the data - dic <- dic %>% + dic <- dic |> dplyr::filter(.data$field_type!="descriptive") vars_more <- dic$field_name[!dic$field_name%in%names(data)] @@ -509,29 +529,29 @@ split_form <- function(data, dic, event_form = NULL, which = NULL, wide=FALSE){ form <- unique(dic$form_name) if(longitudinal){ - ndata <- tibble::tibble("form"=form) %>% + ndata <- tibble::tibble("form"=form) |> dplyr::mutate( events = purrr::map(.data$form, ~ event_form$unique_event_name[event_form$form == .x]), vars = purrr::map(.data$form, ~ dic$field_name[dic$form_name == .x]) - ) %>% + ) |> #Collect variables from every event dplyr::mutate(df = purrr::map2( .data$events, .data$vars, - ~ data %>% - dplyr::filter(redcap_event_name %in% .x) %>% + ~ data |> + dplyr::filter(redcap_event_name %in% .x) |> dplyr::select(tidyselect::all_of(unique( c(basic_redcap_vars, .y) ))) )) }else{ - ndata <- tibble::tibble("form"=form) %>% + ndata <- tibble::tibble("form"=form) |> dplyr::mutate(vars = purrr::map(.data$form, ~dic$field_name[dic$form_name == .x]), #Add to vars the basic REDCap variables not found in the dictionary: vars = purrr::map(.data$vars, ~unique(c(basic_redcap_vars, .x))) - ) %>% + ) |> #Collect variables from every event - dplyr::mutate(df = purrr::map(.data$vars, ~ data %>% + dplyr::mutate(df = purrr::map(.data$vars, ~ data |> dplyr::select(tidyselect::all_of(unique(c(basic_redcap_vars, .x)))))) } @@ -558,18 +578,41 @@ split_form <- function(data, dic, event_form = NULL, which = NULL, wide=FALSE){ } + if(repeat_instrument) { + form_check <- data |> + dplyr::distinct(dplyr::pick(dplyr::contains("redcap_repeat_instrument"))) + + ndata <- ndata |> + dplyr::left_join(form_check, by = dplyr::join_by("form" == "redcap_repeat_instrument")) |> + dplyr::relocate("form_factor" = "redcap_repeat_instrument.factor", .after = form) |> + dplyr::mutate(df = purrr::map2(.data$form_factor, .data$df, ~ { + if (is.na(.x)) { + .y |> + dplyr::filter(is.na(.data$redcap_repeat_instrument.factor)) |> + dplyr::select(-dplyr::starts_with("redcap_repeat_instrument")) + } else { + .y |> + dplyr::filter(.data$redcap_repeat_instrument.factor == .x) |> + dplyr::mutate(redcap_repeat_instrument = redcap_repeat_instrument.factor) |> + dplyr::select(-redcap_repeat_instrument.factor) + } + })) |> + dplyr::select(-"form_factor") + } + + if(wide){ #We will add it with the order that repeated measures happen for every patient. There will be a row for each record-id. - ndata <- ndata %>% + ndata <- ndata |> dplyr::mutate( - df = purrr::map2(.data$vars, .data$df, ~ .y %>% - dplyr::select(tidyselect::all_of(c("record_id", .x))) %>% - dplyr::group_by(.data$record_id) %>% - dplyr::mutate(id = 1:length(.data$record_id)) %>% - dplyr::ungroup() %>% + df = purrr::map2(.data$vars, .data$df, ~ .y |> + dplyr::select(tidyselect::all_of(c("record_id", .x))) |> + dplyr::group_by(.data$record_id) |> + dplyr::mutate(id = 1:length(.data$record_id)) |> + dplyr::ungroup() |> tidyr::pivot_wider(names_from = "id", values_from = -c("record_id", "id")) ) ) @@ -600,10 +643,12 @@ split_form <- function(data, dic, event_form = NULL, which = NULL, wide=FALSE){ to_factor <- function(data, dic, exclude = NULL){ + lifecycle::deprecate_warn("1.0.0", "to_factor()", "rd_factor()") + #We need redcap_event_name to have the original values so we exclude of the conversion the variable redcap_event_name.factor. Also for redcap_data_access_group if present keep <- c("redcap_event_name.factor", "redcap_data_access_group.factor", "redcap_repeat_instrument.factor") - keep_factors <- data %>% + keep_factors <- data |> dplyr::select(keep[keep %in% names(data)]) data$redcap_event_name.factor <- NULL @@ -616,41 +661,41 @@ to_factor <- function(data, dic, exclude = NULL){ #Exclude those variables that we don't want to convert to factors factors <- factors[!factors %in% exclude] - data <- data %>% + data <- data |> #Assign to the non factor variable the factor one and remove the later - dplyr::mutate(dplyr::across(tidyselect::all_of(factors), ~ get(stringr::str_glue("{dplyr::cur_column()}.factor")))) %>% - dplyr::select(-tidyselect::ends_with(".factor")) %>% - tibble::add_column("redcap_event_name.factor" = keep_factors$redcap_event_name.factor, .after = "redcap_event_name") %>% + dplyr::mutate(dplyr::across(tidyselect::all_of(factors), ~ get(stringr::str_glue("{dplyr::cur_column()}.factor")))) |> + dplyr::select(-tidyselect::ends_with(".factor")) |> + tibble::add_column("redcap_event_name.factor" = keep_factors$redcap_event_name.factor, .after = "redcap_event_name") |> tibble::add_column("redcap_repeat_instrument.factor" = keep_factors$redcap_repeat_instrument.factor, .after = "redcap_repeat_instrument") if (length(factors) > 0) { # Transform branching logics in the dictionary for variables that are currently factors - cat_factors <- dic %>% - dplyr::select("field_name", "choices_calculations_or_slider_labels") %>% + cat_factors <- dic |> + dplyr::select("field_name", "choices_calculations_or_slider_labels") |> dplyr::filter(.data$field_name %in% factors) - cat_factors <- cat_factors %>% + cat_factors <- cat_factors |> dplyr::mutate( choices_calculations_or_slider_labels = strsplit(.data$choices_calculations_or_slider_labels, "\\|") - ) %>% + ) |> tidyr::unnest(.data$choices_calculations_or_slider_labels) - cat_factors <- cat_factors %>% + cat_factors <- cat_factors |> tidyr::separate(.data$choices_calculations_or_slider_labels, c("num", "cat"), ", ", - extra = "merge") %>% - dplyr::filter(.data$cat != "") %>% + extra = "merge") |> + dplyr::filter(.data$cat != "") |> dplyr::mutate(num = trimws(.data$num), cat = trimws(.data$cat)) - cat_factors <- cat_factors %>% + cat_factors <- cat_factors |> dplyr::mutate( redcap = paste0("\\[", .data$field_name, "\\] ?=? ?'?", .data$num, "'?"), redcap2 = paste0("\\[", .data$field_name, "\\] ?? ?'?", .data$num, "'?"), factor = paste0("[", .data$field_name, "]='", .data$cat, "'"), factor2 = paste0("[", .data$field_name, "]<>'", .data$cat, "'"), - ) %>% + ) |> dplyr::arrange(.data$field_name, dplyr::desc(.data$num)) replace <- cat_factors$factor @@ -659,7 +704,7 @@ to_factor <- function(data, dic, exclude = NULL){ replace2 <- cat_factors$factor2 names(replace2) <- cat_factors$redcap2 - dic <- dic %>% + dic <- dic |> dplyr::mutate(branching_logic_show_field_only_if = stringr::str_replace_all(.data$branching_logic_show_field_only_if, replace), branching_logic_show_field_only_if = stringr::str_replace_all(.data$branching_logic_show_field_only_if, replace2)) @@ -668,7 +713,7 @@ to_factor <- function(data, dic, exclude = NULL){ if("redcap_data_access_group" %in% names(data)){ - list(data = data %>% + list(data = data |> tibble::add_column("redcap_data_access_group.factor" = keep_factors$redcap_data_access_group.factor, .after = "redcap_data_access_group"), dic = dic) }else{ @@ -676,41 +721,3 @@ to_factor <- function(data, dic, exclude = NULL){ } } -#' Fill Rows with Values from One Event -#' @description -#' This function fills all rows in the dataset with the value of a particular variable in a specified event. It is an auxiliary function used in the `rd_rlogic` function. -#' @param which_event String specifying the name of the event. -#' @param which_var String specifying the name of the variable. -#' @param data Dataset containing the REDCap data. - -fill_data <- function(which_event, which_var, data){ - - if(which_event %in% data$redcap_event_name){ - - fill_values <- data %>% - dplyr::select("record_id", "redcap_event_name", tidyselect::all_of(which_var)) %>% - dplyr::rename(var = which_var) %>% - dplyr::group_by(.data$record_id) %>% - dplyr::mutate( - var = dplyr::case_when( - .data$redcap_event_name != which_event ~ NA, - TRUE ~ .data$var - ), - #Only the first value if the event is repeated - var = stats::na.exclude(unique(.data$var))[1] - ) %>% - tidyr::fill("var", .direction = "downup") %>% - dplyr::pull("var") - - data[,which_var] <- fill_values - - data - - }else{ - - stop("The logic can't be evaluated after the translation") - - } - -} - diff --git a/R/zzz.R b/R/zzz.R index 17d6aae..3a773fc 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,4 +1,9 @@ +# -------------------------------------------------------------- +# All credits for this functionality go to the Tidyverse package +# GitHub: https://github.com/tidyverse +# -------------------------------------------------------------- + .onAttach <- function(...) { attached <- REDCapDM_attach() - inform_startup(REDCapDM_attach_message(attached)) + inform_startup(REDCapDM_attach_message(attached)) } diff --git a/README.md b/README.md index f88b3d7..d770adf 100644 --- a/README.md +++ b/README.md @@ -2,15 +2,14 @@ ======= -[![CRAN status](https://www.r-pkg.org/badges/version/REDCapDM)](https://cran.r-project.org/package=REDCapDM)    [![R-CMD-check](https://github.com/bruigtp/REDCapDM/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/bruigtp/REDCapDM/actions/workflows/R-CMD-check.yaml)    [![](https://cranlogs.r-pkg.org/badges/REDCapDM)](https://cran.r-project.org/package=REDCapDM)    [![](https://cranlogs.r-pkg.org/badges/grand-total/REDCapDM)](https://cran.r-project.org/package=REDCapDM) +[![CRAN status](https://www.r-pkg.org/badges/version/REDCapDM)](https://cran.r-project.org/package=REDCapDM)    [![R-CMD-check](https://github.com/bruigtp/REDCapDM/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/bruigtp/REDCapDM/actions/workflows/R-CMD-check.yaml)    +[![Codecov test coverage](https://codecov.io/gh/bruigtp/REDCapDM/graph/badge.svg)](https://app.codecov.io/gh/bruigtp/REDCapDM) +[![](https://cranlogs.r-pkg.org/badges/REDCapDM)](https://cran.r-project.org/package=REDCapDM)    [![](https://cranlogs.r-pkg.org/badges/grand-total/REDCapDM)](https://cran.r-project.org/package=REDCapDM) -`REDCapDM` is an R package that allows users to manage data exported directly from REDCap or through an API connection. This package includes several functions designed for preprocessing data, generating reports on queries like outliers or missing values, and performing a follow-up of each identified query. 'REDCap' (Research Electronic Data CAPture; ) is a web application developed at Vanderbilt University, designed for creating and managing online surveys and databases. The REDCap API serves as an interface allowing external applications to connect to REDCap remotely, and is used to programmatically retrieve or modify project data or settings within REDCap, such as importing or exporting data. - -The [REDCapDM website](https://bruigtp.github.io/REDCapDM/articles/REDCapDM.html) has a description of the package functions as well as access to the package vignettes. - -Here you can access the published article in BMC Medical Research Methodology: [REDCapDM: An R package with a set of data management tools for a REDCap project](https://doi.org/10.1186/s12874-024-02178-6) +The R package [**REDCapDM**](https://bruigtp.github.io/REDCapDM/articles/REDCapDM.html) has been developed with the objective of facilitating the management of data for projects using the REDCap platform. It is capable of supporting both direct data export and access via the REDCap API. REDCapDM offers a comprehensive variety of functions, including the ability to preprocess data, generate detailed query reports for issues such as outliers or missing values, and track the resolution of each identified query. +[**REDCap**](https://projectredcap.org) (Research Electronic Data CAPture) is a widely-used web application developed at Vanderbilt University for creating and managing online surveys and databases. It includes an API (Application Programming Interface) that serves as an interface allowing external applications to connect to REDCap remotely, and is used to programmatically retrieve or modify project data or settings within REDCap, such as importing or exporting data. ### Installation @@ -28,13 +27,50 @@ install.packages("remotes") # Run this line if the 'remotes' package isn't insta remotes::install_github("bruigtp/REDCapDM") ``` -## Getting help + +### Getting Started + +To learn more about the package’s functionality, visit the [**REDCapDM website**](https://bruigtp.github.io/REDCapDM/articles/REDCapDM.html). The site includes detailed descriptions of the package's functions and access to vignettes that demonstrate how to use REDCapDM effectively in your projects. + + +### Getting help If you encounter a clear bug, please file an issue with a minimal reproducible example on -[GitHub](https://github.com/bruigtp/REDCapDM/issues). +[**GitHub: Issues**](https://github.com/bruigtp/REDCapDM/issues). + + +### Published Work + +For an in-depth exploration of REDCapDM, refer to the published article in *BMC Medical Research Methodology*: +[**REDCapDM: An R package with a set of data management tools for a REDCap project**](https://doi.org/10.1186/s12874-024-02178-6) + +### Citation + +``` text +> citation("REDCapDM") + +To cite package ‘REDCapDM’ in publications use: + + Carmezim J, Satorra P, Peñafiel J, García E, Pallarès N, Santos N, Tebé C (2024). “REDCapDM: An R package with a + set of data management tools for a REDCap project.” _BMC Medical Research Methodology_, *24*(1), 55. + doi:10.1186/s12874-024-02178-6 . + +A BibTeX entry for LaTeX users is + + @Article{, + title = {REDCapDM: An R package with a set of data management tools for a REDCap project}, + author = {João Carmezim and Pau Satorra and Judith Peñafiel and Esther García and Natàlia Pallarès and Naiara Santos and Cristian Tebé}, + journal = {BMC Medical Research Methodology}, + year = {2024}, + volume = {24}, + number = {1}, + pages = {55}, + doi = {10.1186/s12874-024-02178-6}, + } +``` -## About +### About Package: REDCapDM diff --git a/REDCapDM.Rproj b/REDCapDM.Rproj index b9909b1..f2f0905 100644 --- a/REDCapDM.Rproj +++ b/REDCapDM.Rproj @@ -4,7 +4,7 @@ RestoreWorkspace: No SaveWorkspace: No AlwaysSaveHistory: No -EnableCodeIndexing: Yes +EnableCodeIndexing: No UseSpacesForTab: Yes NumSpacesForTab: 2 Encoding: UTF-8 @@ -19,3 +19,6 @@ BuildType: Package PackageUseDevtools: Yes PackageInstallArgs: --no-multiarch --with-keep.source PackageRoxygenize: rd,collate,namespace,vignette + +QuitChildProcessesOnExit: Yes +DisableExecuteRprofile: Yes diff --git a/_pkgdown.yml b/_pkgdown.yml index f4225a7..4a6384a 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -1,4 +1,4 @@ -url: https://brui.github.io/REDCapDM +url: https://bruigtp.github.io/REDCapDM template: bootstrap: 5 bootswatch: minty @@ -8,36 +8,3 @@ template: link-color: "#fa8011" link-hover-color: "#f8a85f" dropdown-link-hover-bg: "#bb5b04" - -reference: -- title: "Import data" - desc: "Function to easily import data from a REDCap project into R for analysis." - contents: - - redcap_data -- title: "Process data" - desc: "Functions to process the REDCap data once it's imported into R" - contents: - - rd_transform - - rd_rlogic - - rd_insert_na -- title: "Query generation" - desc: "Functions involved in the query generation to validate the REDCap data" - contents: - - rd_query - - rd_event - - check_queries - - rd_export -- title: "Built-in dataset" - desc: "Dataset that is included in the package for testing" - contents: - - covican -- title: "Auxiliar functions" - desc: "Auxiliar functions involved in the REDCap data processing" - contents: - - checkbox_names - - fill_data - - recalculate - - split_event - - split_form - - to_factor - - transform_checkboxes diff --git a/man/REDCapDM-package.Rd b/man/REDCapDM-package.Rd index 39ffcbd..8fa7462 100644 --- a/man/REDCapDM-package.Rd +++ b/man/REDCapDM-package.Rd @@ -1,37 +1,52 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/REDCapDM_PACKAGE.R +% Please edit documentation in R/REDCapDM-package.R \name{REDCapDM-package} \alias{REDCapDM-package} \alias{REDCapDM} -\title{Managing REDCap Data: The R package REDCapDM} +\title{Managing REDCap Data: The R package REDCapDM / REDCapDM: A Toolkit for Managing REDCap Data in R} \description{ -The REDCapDM package facilitates the importing of data from REDCap into R through either an API connection or directly from exported files. It includes a range of data processing and transformation functions, and supports the creation and management of queries to address any discrepancies or uncertainties within the dataset. - -REDCapDM functions: - -- `redcap_data`: reads data exported directly from REDCap or via an API connection. - -- `rd_transform`: processes the raw dataset. - -- `rd_rlogic`: translates REDCap logic into R logic. - -- `rd_insert_na`: manually inserts a missing value for specified variables using a filter. - -- `rd_query`: identifies discrepancies in the dataset (queries). - -- `rd_event`: identifies missing events in each record of the dataset. - -- `check_queries`: compares a current report of queries with an older one to determine which queries have been modified, which remain unchanged, and which are new. +The \strong{REDCapDM} package provides tools to import, process, and manage REDCap data within R. +It supports data retrieval through the REDCap API or directly from exported files and includes a robust +set of functions for data transformation, validation, and discrepancy management. Designed for efficient +workflow integration, \strong{REDCapDM} simplifies the handling of REDCap datasets, making it easier to ensure +data quality and consistency. + +Key Features: +\itemize{ +\item \strong{Flexible Data Import}: Import data directly from REDCap using API connections or process exported REDCap files. +\item \strong{Data Transformation}: Streamline the cleaning and preparation of raw datasets for analysis. +\item \strong{Query Management}: Identify and track data discrepancies, missing events, and manage resolution reports. +} -- `rd_export`: exports a report of identified queries to an .xlsx file. +Core Functions: +\itemize{ +\item \code{redcap_data}: Reads data exported from REDCap or retrieved through the REDCap API into R. +\item \code{rd_transform}: One-step pipeline to clean and preprocess the raw REDCap data. +\itemize{ +\item \code{rd_dates}: Standardize date and datetime fields. +\item \code{rd_delete_vars}: Remove specified variables (by name or pattern). +\item \code{rd_recalculate}: Recompute calculated fields and compare with REDCap values. +\item \code{rd_factor}: Replace numeric multiple-choice columns with their factor version. +\item \code{rd_checkbox}: Expand checkbox responses with custom labels and rename 'var___1' columns (REDCap style) to 'var_option'. +\item \code{rd_split}: Splits a REDCap dataset by form or event. +\item \code{rd_insert_na}: Manually set specified variables to missing based on a logical filter. +\item \code{rd_rlogic}: Translate REDCap branching or calculation logic into R syntax. +\item \code{rd_dictionary}: Update dictionary (translation of REDCap logic into R syntax) to reflect transformed data and logic. +} +\item \code{rd_query}: Identifies discrepancies (queries) in the dataset for validation. +\item \code{rd_event}: Detects missing events in longitudinal datasets. +\item \code{check_queries}: Compares historical and current query reports to track changes and additions. +\item \code{rd_export}: Exports a summary report of identified queries to an Excel (.xlsx) file. +} } \examples{ \dontrun{ # Install REDCapDM from CRAN: -install.packages('REDCapR') +install.packages("REDCapDM") -# Install REDCapDM from GitHub: -remotes::install_github('bruigtp/REDCapDM') +# Install the latest version of REDCapDM from GitHub: +remotes::install_github("bruigtp/REDCapDM") } + } \keyword{internal} diff --git a/man/check_proj.Rd b/man/check_proj.Rd new file mode 100644 index 0000000..962f77e --- /dev/null +++ b/man/check_proj.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-suplement.R +\name{check_proj} +\alias{check_proj} +\title{Handle Project Arguments} +\usage{ +check_proj(project, data = NULL, dic = NULL, event_form = NULL) +} +\arguments{ +\item{project}{A list or object containing \code{data}, \code{dictionary}, and optionally \code{event_form} and \code{results}.} + +\item{data}{A data frame (optional) that may be overridden if provided in the \code{project} object.} + +\item{dic}{A data dictionary (optional) that may be overridden if provided in the \code{project} object.} + +\item{event_form}{An optional event-form object that may be overridden if provided in the \code{project}.} +} +\description{ +This helper function processes the \code{project} argument in the several other functions. +It extracts data, dictionary, event form, and results from the project object while handling +potential duplication and providing warnings when arguments are provided redundantly. +} diff --git a/man/check_queries.Rd b/man/check_queries.Rd index f280315..3c97056 100644 --- a/man/check_queries.Rd +++ b/man/check_queries.Rd @@ -4,30 +4,100 @@ \alias{check_queries} \title{Check for Changes Between Two Query Reports} \usage{ -check_queries(old, new, report_title = NULL) +check_queries(old, new, report_title = NULL, return_viewer = TRUE) } \arguments{ -\item{old}{Previous version of the queries report.} +\item{old}{Data frame containing the previous (older) query report. Must include +\code{Identifier}, \code{Description} and \code{Query} columns (character or factor).} -\item{new}{New version of the queries report. This object is used to determine the status of each query.} +\item{new}{Data frame containing the newer query report. Must include +\code{Identifier}, \code{Description} and \code{Query} columns (character or factor). +If \code{new} contains a \code{Code} column, it will be removed at the start of processing.} -\item{report_title}{Character string specifying the title of the report.} +\item{report_title}{Optional single string used as the caption for the HTML summary table. +Defaults to \code{"Comparison report"} when not supplied or when \code{NA}.} + +\item{return_viewer}{Logical; if \code{TRUE} (default) an HTML table (knitr/kable + kableExtra) +summarizing the counts per state is produced and returned in the \code{results} element of the +returned list. If \code{FALSE}, no HTML viewer is produced (useful for non-interactive runs).} } \value{ -A list consisting of a dataframe containing each individual query from both reports and a column showing the status of the queries (new, solved, miscorrected or pending) compared to the previous query report. In addition to this dataframe, there is also a summary of the total number of queries per category. +A list with two elements: +\describe{ +\item{\code{queries}}{A data frame containing all queries present in either \code{old} or \code{new}. +A factor column \code{Modification} indicates the state for each row (levels: \code{Pending}, +\code{Solved}, \code{Miscorrected}, \code{New}). The function also reassigns \code{Code} +values so codes are consistent per \code{Identifier}.} +\item{\code{results}}{If \code{return_viewer = TRUE}, an HTML \code{knitr::kable} (styled with +\code{kableExtra}) summarising totals per state. If \code{return_viewer = FALSE}, this is \code{NULL}.} +} } \description{ -This function compares an old report of queries with a new one. It allows you to identify which queries are new, which have been modified, and which remain unchanged. +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +Compare an older query report (\code{old}) with a newer one (\code{new}) and classify each +query into one of four statuses: +\itemize{ +\item \strong{Pending} — the same query is present in both reports (no change detected), +\item \strong{Solved} — the query was present in the old report but is absent from the new report, +\item \strong{New} — the query appears in the new report but was not present in the old report, +\item \strong{Miscorrected} — a special case where a query in the new report is marked as \code{New} +but shares the same \code{Identifier} and \code{Description} as an existing record (suggesting a +re-issued or modified query for the same identifier). +} + +The function returns a detailed comparison table of queries with a \code{Modification} factor (one of the four statuses) and an HTML summary table showing counts per status. +} +\details{ +Requirements: +\itemize{ +\item Both \code{old} and \code{new} must be data frames. +\item Both data frames must contain at least the following character columns: +\code{Identifier}, \code{Description}, and \code{Query}. +\item A \code{Code} column is optional; if present it will be preserved and considered +for sorting and output. If \code{Code} exists in \code{new}, it is removed at the +beginning of the routine to avoid conflicts with re-assigned codes. +} + +The function merges the two reports, constructs composite keys used for comparison, classifies each row into a modification state, detects and re-labels \code{Miscorrected} cases, reassigns a \code{Code} per \code{Identifier} to keep codes consistent, and returns a detailed dataset plus an optional HTML summary viewer. } +\section{Notes and edge cases}{ + +\itemize{ +\item \strong{Column types:} If \code{Identifier}, \code{Description} or \code{Query} are +factors, they will be used in the comparison — it is recommended to convert them to +character prior to calling \code{check_queries()} to avoid factor-level mismatches. +\item \strong{Sorting:} When \code{Identifier} values contain a dash (e.g. \code{"100-20"}), +the function attempts to split into numeric \code{center} and \code{id} parts for +logical ordering. Otherwise \code{Identifier} is coerced to numeric for ordering. +\item \strong{Miscorrected detection:} A \code{Miscorrected} label is assigned when more +than one row shares the same \code{Identifier + Description} composite and a row is +otherwise classified as \code{New} — this signals a likely re-issued or modified query +for an existing identifier. +} +} + \examples{ -# Example of a query -data_old <- rd_query(covican, - variables = "copd", - expression = "is.na(x)", - event = "baseline_visit_arm_1") -data_new <- rbind(data_old$queries[1:5,], c("100-20",rep("abc",8))) - -# Control of queries -check <- check_queries(old = data_old$queries, - new = data_new) +# Minimal reproducible example +old <- data.frame( + Identifier = c("100-1", "100-2", "200-1"), + Description = c("age check", "weight check", "lab miss"), + Query = c("is.na(age)", "is.na(weight)", "missing lab result"), + Code = c("100-1-1", "100-2-1", "200-1-1"), + stringsAsFactors = FALSE +) + +new <- data.frame( + Identifier = c("100-1", "200-1", "300-1"), + Description = c("age check", "lab miss", "new query"), + Query = c("is.na(age)", "missing lab result (clarify)", "is.na(x)"), + stringsAsFactors = FALSE +) + +res <- check_queries(old = old, new = new, report_title = "My Query Comparison") +# detailed table +head(res$queries) +# HTML summary (if in an RMarkdown or interactive viewer) +res$results + } diff --git a/man/checkbox_names.Rd b/man/checkbox_names.Rd index 4fc592c..54b12fa 100644 --- a/man/checkbox_names.Rd +++ b/man/checkbox_names.Rd @@ -13,7 +13,7 @@ checkbox_names(data, dic, labels, checkbox_labels = c("No", "Yes")) \item{labels}{Named character vector with the names of the variables in the data and their corresponding REDCap labels.} -\item{checkbox_labels}{Character vector specifying the names for the two options of each checkbox variable. The default is `c('No', 'Yes')`.} +\item{checkbox_labels}{Character vector specifying the names for the two options of each checkbox variable. The default is \code{c('No', 'Yes')}.} } \description{ This function updates the names of checkboxes in the dataset and dictionary to reflect the names of their options. diff --git a/man/covican.Rd b/man/covican.Rd index 9b94a11..da1d007 100644 --- a/man/covican.Rd +++ b/man/covican.Rd @@ -6,31 +6,31 @@ \title{Subset of COVICAN's Database} \format{ A data frame with 342 rows and 56 columns - \describe{ - \item{record_id:}{Identifier of each record. This information does not match the real data.} - \item{redcap_event_name:}{Auto-generated name of the events} - \item{redcap_data_access_group:}{Auto-generated name of each center. This information does not match the real data.} - \item{inc_1:}{Inclusion criteria of 'Patients older than 18 years' (0 = No ; 1 = Yes)} - \item{inc_2:}{Inclusion criteria of 'Cancer patients' (0 = No ; 1 = Yes)} - \item{inc_3:}{Inclusion criteria of 'Diagnosed of COVID-19' (0 = No ; 1 = Yes)} - \item{exc_1:}{Exclusion criteria of 'Solid tumour remission >1 year' (0 = No ; 1 = Yes)} - \item{screening_fail_crit:}{Indicator of non-compliance with inclusion and exclusion criteria (0 = compliance ; 1 = non-compliance)} - \item{d_birth:}{Date of birth (y-m-d). This date does not correspond to the original.} - \item{d_admission:}{Date of first visit (y-m-d). This date does not correspond to the original.} - \item{age:}{Age in years} - \item{dm:}{Indicator of diabetes (0 = No ; 1 = Yes)} - \item{type_dm:}{Type of diabetes (1 = No complications ; 2 = End-organ diabetes-related disease)} - \item{copd:}{Indicator of chronic obstructive pulmonary disease (0 = No ; 1 = Yes)} - \item{fio2:}{Fraction of inspired oxygen in percentage} - \item{available_analytics:}{Indicator of blood test available (0 = No ; 1 = Yes)} - \item{potassium:}{Potassium in mmol/L} - \item{resp_rate:}{Respiratory rate in bpm} - \item{leuk_lymph:}{Indicator of leukemia or lymphoma (0 = No ; 1 = Yes)} - \item{acute_leuk:}{Indicator of acute leukemia (0 = No ; 1 = Yes)} - \item{type_underlying_disease[...]:}{Checkbox with the type of underlying disease (0 = Haematological cancer ; 1 = Solid tumour)} - \item{underlying_disease_hemato[...]:}{Checkbox with the type of underlying disease (1 = Acute myeloid leukemia ; 2 = Myelodysplastic syndrome ; 3 = Chronic myeloid leukaemia ; 4 = Acute lymphoblastic leukaemia ; 5 = Hodgkin lymphoma ; 6 = Non Hodgkin lymphoma ; 7 = Multiple myeloma ; 8 = Myelofibrosis ; 9 = Aplastic anaemia ; 10 = Chronic lymphocytic leukaemia ; 11 = Amyloidosis ; 12 = Other)} - \item{urine_culture:}{Indicator of urine culture: (0 = Not done ; 1 = Done)} - \item{[...].factor:}{Labels of the different variables} +\describe{ +\item{record_id:}{Identifier of each record. This information does not match the real data.} +\item{redcap_event_name:}{Auto-generated name of the events} +\item{redcap_data_access_group:}{Auto-generated name of each center. This information does not match the real data.} +\item{inc_1:}{Inclusion criteria of 'Patients older than 18 years' (0 = No ; 1 = Yes)} +\item{inc_2:}{Inclusion criteria of 'Cancer patients' (0 = No ; 1 = Yes)} +\item{inc_3:}{Inclusion criteria of 'Diagnosed of COVID-19' (0 = No ; 1 = Yes)} +\item{exc_1:}{Exclusion criteria of 'Solid tumour remission >1 year' (0 = No ; 1 = Yes)} +\item{screening_fail_crit:}{Indicator of non-compliance with inclusion and exclusion criteria (0 = compliance ; 1 = non-compliance)} +\item{d_birth:}{Date of birth (y-m-d). This date does not correspond to the original.} +\item{d_admission:}{Date of first visit (y-m-d). This date does not correspond to the original.} +\item{age:}{Age in years} +\item{dm:}{Indicator of diabetes (0 = No ; 1 = Yes)} +\item{type_dm:}{Type of diabetes (1 = No complications ; 2 = End-organ diabetes-related disease)} +\item{copd:}{Indicator of chronic obstructive pulmonary disease (0 = No ; 1 = Yes)} +\item{fio2:}{Fraction of inspired oxygen in percentage} +\item{available_analytics:}{Indicator of blood test available (0 = No ; 1 = Yes)} +\item{potassium:}{Potassium in mmol/L} +\item{resp_rate:}{Respiratory rate in bpm} +\item{leuk_lymph:}{Indicator of leukemia or lymphoma (0 = No ; 1 = Yes)} +\item{acute_leuk:}{Indicator of acute leukemia (0 = No ; 1 = Yes)} +\item{type_underlying_disease\link{...}:}{Checkbox with the type of underlying disease (0 = Haematological cancer ; 1 = Solid tumour)} +\item{underlying_disease_hemato\link{...}:}{Checkbox with the type of underlying disease (1 = Acute myeloid leukemia ; 2 = Myelodysplastic syndrome ; 3 = Chronic myeloid leukaemia ; 4 = Acute lymphoblastic leukaemia ; 5 = Hodgkin lymphoma ; 6 = Non Hodgkin lymphoma ; 7 = Multiple myeloma ; 8 = Myelofibrosis ; 9 = Aplastic anaemia ; 10 = Chronic lymphocytic leukaemia ; 11 = Amyloidosis ; 12 = Other)} +\item{urine_culture:}{Indicator of urine culture: (0 = Not done ; 1 = Done)} +\item{\link{...}.factor:}{Labels of the different variables} } } \usage{ @@ -40,7 +40,7 @@ data(covican) A random sample of the COVICAN study. An international, multicentre cohort study of cancer patients with COVID-19 to describe the epidemiology, risk factors, and clinical outcomes of co-infections and superinfections in onco-haematological patients with COVID-19. } \note{ -List with three data frames: the first one with the data, the second one with the dictionary (`codebook`) of the REDCap project and the last one with the instrument-event mappings of the REDCap project. +List with three data frames: the first one with the data, the second one with the dictionary (\code{codebook}) of the REDCap project and the last one with the instrument-event mappings of the REDCap project. } \references{ Gudiol, C., Durà-Miralles, X., Aguilar-Company, J., Hernández-Jiménez, P., Martínez-Cutillas, M., Fernandez-Avilés, F., Machado, M., Vázquez, L., Martín-Dávila, P., de Castro, N., Abdala, E., Sorli, L., Andermann, T. M., Márquez-Gómez, I., Morales, H., Gabilán, F., Ayaz, C. M., Kayaaslan, B., Aguilar-Guisado, M., Herrera, F. Royo-Cebrecos C, Peghin M, González-Rico C, Goikoetxea J, Salgueira S, Silva-Pinto A, Gutiérrez-Gutiérrez B, Cuellar S, Haidar G, Maluquer C, Marin M, Pallarès N, Carratalà J. (2021). Co-infections and superinfections complicating COVID-19 in cancer patients: A multicentre, international study. The Journal of infection, 83(3), 306–313. https://doi.org/10.1016/j.jinf.2021.07.014 diff --git a/man/figures/Thumbs.db b/man/figures/Thumbs.db index 8c40742..0c68428 100644 Binary files a/man/figures/Thumbs.db and b/man/figures/Thumbs.db differ diff --git a/man/figures/lifecycle-deprecated.svg b/man/figures/lifecycle-deprecated.svg new file mode 100644 index 0000000..b61c57c --- /dev/null +++ b/man/figures/lifecycle-deprecated.svg @@ -0,0 +1,21 @@ + + lifecycle: deprecated + + + + + + + + + + + + + + + lifecycle + + deprecated + + diff --git a/man/figures/lifecycle-experimental.svg b/man/figures/lifecycle-experimental.svg new file mode 100644 index 0000000..5d88fc2 --- /dev/null +++ b/man/figures/lifecycle-experimental.svg @@ -0,0 +1,21 @@ + + lifecycle: experimental + + + + + + + + + + + + + + + lifecycle + + experimental + + diff --git a/man/figures/lifecycle-stable.svg b/man/figures/lifecycle-stable.svg new file mode 100644 index 0000000..9bf21e7 --- /dev/null +++ b/man/figures/lifecycle-stable.svg @@ -0,0 +1,29 @@ + + lifecycle: stable + + + + + + + + + + + + + + + + lifecycle + + + + stable + + + diff --git a/man/figures/lifecycle-superseded.svg b/man/figures/lifecycle-superseded.svg new file mode 100644 index 0000000..db8d757 --- /dev/null +++ b/man/figures/lifecycle-superseded.svg @@ -0,0 +1,21 @@ + + lifecycle: superseded + + + + + + + + + + + + + + + lifecycle + + superseded + + diff --git a/man/fill_data.Rd b/man/fill_data.Rd index 54aa4f9..03e7813 100644 --- a/man/fill_data.Rd +++ b/man/fill_data.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils-transform.R +% Please edit documentation in R/utils-suplement.R \name{fill_data} \alias{fill_data} \title{Fill Rows with Values from One Event} @@ -14,5 +14,5 @@ fill_data(which_event, which_var, data) \item{data}{Dataset containing the REDCap data.} } \description{ -This function fills all rows in the dataset with the value of a particular variable in a specified event. It is an auxiliary function used in the `rd_rlogic` function. +This function fills all rows in the dataset with the value of a particular variable in a specified event. It is an auxiliary function used in the \code{rd_rlogic} function. } diff --git a/man/pipe.Rd b/man/pipe.Rd deleted file mode 100644 index 1f8f237..0000000 --- a/man/pipe.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils-pipe.R -\name{\%>\%} -\alias{\%>\%} -\title{Pipe operator} -\usage{ -lhs \%>\% rhs -} -\arguments{ -\item{lhs}{A value or the magrittr placeholder.} - -\item{rhs}{A function call using the magrittr semantics.} -} -\value{ -The result of calling `rhs(lhs)`. -} -\description{ -See \code{magrittr::\link[magrittr:pipe]{\%>\%}} for details. -} -\keyword{internal} diff --git a/man/rd_checkbox.Rd b/man/rd_checkbox.Rd new file mode 100644 index 0000000..1a4fa7c --- /dev/null +++ b/man/rd_checkbox.Rd @@ -0,0 +1,72 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rd_checkbox.R +\name{rd_checkbox} +\alias{rd_checkbox} +\title{Transform Checkbox Variables in a REDCap Project} +\usage{ +rd_checkbox( + project = NULL, + data = NULL, + dic = NULL, + event_form = NULL, + checkbox_labels = c("No", "Yes"), + checkbox_names = TRUE, + na_logic = "none" +) +} +\arguments{ +\item{project}{A list containing the REDCap data, dictionary, and event mapping (expected \code{redcap_data()} output). Overrides \code{data}, \code{dic}, and \code{event_form}.} + +\item{data}{A \code{data.frame} or \code{tibble} with the REDCap dataset.} + +\item{dic}{A \code{data.frame} with the REDCap dictionary.} + +\item{event_form}{Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects.} + +\item{checkbox_labels}{Character vector of length 2 for labels of unchecked/checked values. Default: \code{c("No", "Yes")}.} + +\item{checkbox_names}{Logical. If \code{TRUE} (default), checkbox columns are renamed using choice labels.} + +\item{na_logic}{Controls how missing values are set based on branching logic. Must be one of \code{"none"} (do nothing), \code{"missing"} (set to \code{NA} only when the logic evaluation is \code{NA}), or \code{"eval"} (set to \code{NA} when the logic evaluates to \code{FALSE}). Defaults to \code{"none"}.} +} +\value{ +A list with: +\describe{ +\item{data}{Transformed dataset with checkbox fields as factors and optionally renamed.} +\item{dictionary}{Updated dictionary with checkbox fields expanded and optionally renamed.} +\item{event_form}{The \code{event_form} passed in (if applicable).} +\item{results}{Summary of transformations and any fields needing review.} +} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +This function is used to process checkbox variables in a REDCap dataset. By default, it changes their default categories ("Unchecked" and "Checked") to new ones ("No" and "Yes). Optionally, the function can also evaluate the branching logic for checkbox fields and adjust the data and dictionary accordingly. +} +\details{ +\itemize{ +\item Checkbox columns are expected in REDCap wide format (\code{field___code}). +\item Branching logic evaluation requires \code{event_form} for longitudinal projects. +\item Names are cleaned and truncated to 60 characters; uniqueness is enforced. +\item Fields that cannot be evaluated are listed in \code{results}. +} +} +\examples{ +# Basic usage with a project object +res <- rd_checkbox(covican) + +# With custom labels +res <- rd_checkbox(data = covican$data, + dic = covican$dictionary, + checkbox_labels = c("Not present", "Present")) + +# Keep original checkbox names +res <- rd_checkbox(covican, checkbox_names = FALSE) + +# Longitudinal project with NA logic +res <- rd_checkbox(data = covican$data, + dic = covican$dictionary, + event_form = covican$event_form,, + na_logic = "eval") + +} diff --git a/man/rd_dates.Rd b/man/rd_dates.Rd new file mode 100644 index 0000000..4cc28b0 --- /dev/null +++ b/man/rd_dates.Rd @@ -0,0 +1,44 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rd_dates.R +\name{rd_dates} +\alias{rd_dates} +\title{Transform Dates and Datetimes in REDCap Data} +\usage{ +rd_dates(project = NULL, data = NULL, dic = NULL, event_form = NULL) +} +\arguments{ +\item{project}{A list containing the REDCap data, dictionary, and event mapping (expected \code{redcap_data()} output). Overrides \code{data}, \code{dic}, and \code{event_form}.} + +\item{data}{A \code{data.frame} or \code{tibble} with the REDCap dataset.} + +\item{dic}{A \code{data.frame} with the REDCap dictionary.} + +\item{event_form}{Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects.} +} +\value{ +A list with the following elements: +\describe{ +\item{data}{The transformed dataset with date and datetime fields formatted as \code{Date} and \code{POSIXct}.} +\item{dictionary}{The original REDCap dictionary passed to the function.} +\item{event_form}{The original event-form mapping (if applicable).} +\item{results}{A summary of the transformations performed.} +} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Converts date and datetime fields in a REDCap dataset to appropriate R classes. +} +\details{ +The function performs the following tasks: +\itemize{ +\item Detects date and datetime fields from the REDCap dictionary (\verb{date_*} and \verb{datetime_*} validation types). +\item Converts date fields to \code{Date} class. +\item Converts datetime fields to \code{POSIXct} class, treating empty strings as \code{NA}. +} +} +\examples{ +result <- rd_dates(covican) +transformed_data <- result$data + +} diff --git a/man/rd_delete_vars.Rd b/man/rd_delete_vars.Rd new file mode 100644 index 0000000..0a1529c --- /dev/null +++ b/man/rd_delete_vars.Rd @@ -0,0 +1,65 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rd_delete_vars.R +\name{rd_delete_vars} +\alias{rd_delete_vars} +\title{Delete Variables from REDCap Dataset and Dictionary} +\usage{ +rd_delete_vars( + project = NULL, + data = NULL, + dic = NULL, + event_form = NULL, + vars = NULL, + pattern = NULL +) +} +\arguments{ +\item{project}{A list containing the REDCap data, dictionary, and event mapping (expected \code{redcap_data()} output). Overrides \code{data}, \code{dic}, and \code{event_form}.} + +\item{data}{A \code{data.frame} or \code{tibble} with the REDCap dataset.} + +\item{dic}{A \code{data.frame} with the REDCap dictionary.} + +\item{event_form}{Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects.} + +\item{vars}{Optional. A character vector of variable names to remove from both the dataset and dictionary.} + +\item{pattern}{Optional. A character vector of regular expression patterns. Variables matching these patterns will be removed from the dataset and dictionary.} +} +\value{ +A list containing: +\describe{ +\item{data}{The updated dataset with specified variables removed.} +\item{dictionary}{The updated REDCap dictionary.} +\item{event_form}{The original event-form mapping (if applicable).} +\item{results}{A summary message describing the variable removal operation.} +} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Deletes selected variables from a REDCap dataset and its dictionary, keeping them consistent and preserving variable labels. +} +\details{ +\itemize{ +\item Ensure that at least one of \code{vars} or \code{pattern} is specified. +\item Removes specified variables and their factor versions (e.g., \code{variable.factor}) from the dataset. +\item Removes matching variables from the dictionary. +\item Warns about factor versions of variables matching patterns, recommending use of \code{rd_factor()} if necessary. +} +} +\examples{ +# Delete specific variables by name +result <- rd_delete_vars( + project = covican, + vars = c("potassium", "leuk_lymph") +) + +# Delete variables matching patterns +result <- rd_delete_vars( + data = covican$data, + dic = covican$dictionary, + pattern = c("_complete$", "_other$") +) + +} diff --git a/man/rd_dictionary.Rd b/man/rd_dictionary.Rd new file mode 100644 index 0000000..3f0a930 --- /dev/null +++ b/man/rd_dictionary.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rd_dictionary.R +\name{rd_dictionary} +\alias{rd_dictionary} +\title{Transform the data dictionary and handle branching logic} +\usage{ +rd_dictionary(project = NULL, data = NULL, dic = NULL, event_form = NULL) +} +\arguments{ +\item{project}{A list containing the REDCap data, dictionary, and event mapping (expected \code{redcap_data()} output). Overrides \code{data}, \code{dic}, and \code{event_form}.} + +\item{data}{A \code{data.frame} or \code{tibble} with the REDCap dataset.} + +\item{dic}{A \code{data.frame} with the REDCap dictionary.} + +\item{event_form}{Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects.} +} +\value{ +A list with the following elements: +\describe{ +\item{data}{The original dataset passed to the function.} +\item{dictionary}{The updated data dictionary with modified branching logic and calculations.} +\item{event_form}{The original event-form mapping (if applicable).} +\item{results}{A summary of the transformations, including any variables with unconverted branching logic.} +} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Updates a REDCap data dictionary by converting branching logic and calculation expressions into valid R expressions. This ensures that conditional display rules and calculated fields in the dictionary can be programmatically evaluated with the dataset. Any variables that cannot be converted are reported in the results. +} +\details{ +The function performs the following tasks: +\itemize{ +\item Evaluates and transforms branching logic expressions into valid R expressions using \code{rd_rlogic}. +\item Evaluates and converts calculation expressions for fields of type \code{calc}. +\item Generates a results summary table listing any variables that could not be converted. +} +} +\examples{ +\dontrun{ +result <- rd_dictionary(covican) +print(result$results) +updated_dic <- result$dictionary +} + +} diff --git a/man/rd_event.Rd b/man/rd_event.Rd index 4f73233..9a6d5e3 100644 --- a/man/rd_event.Rd +++ b/man/rd_event.Rd @@ -2,12 +2,13 @@ % Please edit documentation in R/rd_event.R \name{rd_event} \alias{rd_event} -\title{Identification of Missing Event(s)} +\title{Identify Missing Events in REDCap Data} \usage{ rd_event( - ..., + project = NULL, data = NULL, dic = NULL, + event_form = NULL, event, filter = NA, query_name = NA, @@ -18,35 +19,66 @@ rd_event( ) } \arguments{ -\item{...}{List containing the data, dictionary and event mapping (if required) of the REDCap project. This should be the output of the `redcap_data` function.} +\item{project}{A list containing the REDCap data, dictionary, and event mapping (expected \code{redcap_data()} output). Overrides \code{data}, \code{dic}, and \code{event_form}.} -\item{data}{Data frame containing the data read from REDCap. If the list is specified, this argument is not required.} +\item{data}{A \code{data.frame} or \code{tibble} with the REDCap dataset.} -\item{dic}{Data frame containing the dictionary read from REDCap. If the list is specified, this argument is not required.} +\item{dic}{A \code{data.frame} with the REDCap dictionary.} -\item{event}{Character vector with the name of the REDCap event(s) to be analyzed.} +\item{event_form}{Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects.} -\item{filter}{A filter to be applied to the dataset. This argument can be used to identify the missing events on a subset of the dataset.} +\item{event}{Character vector with one or more REDCap event names to check for missing records.} -\item{query_name}{Description of the query. It can be the same for all variables, or you can define a different one for each variable. By default, the function defines it as `The event [event] is missing' for each event`.} +\item{filter}{Optional. A single character string containing a filter expression to subset the dataset before checking for missing events. Example: \code{"age >= 18"}.} -\item{addTo}{Data frame corresponding to a previous query data frame to which you can add the new query data frame. By default, the function always generates a new data frame without taking into account previous reports.} +\item{query_name}{Optional character vector describing each query. Defaults to a standard format: \verb{The event (event_name) is missing}.} -\item{report_title}{Character string specifying the title of the report.} +\item{addTo}{Optional data frame from a previous query report to which the new results can be appended.} -\item{report_zeros}{Logical. If `TRUE`, the function returns a report containing variables with zero queries.} +\item{report_title}{Optional string specifying the title of the final report. Defaults to \code{"Report of queries"}.} -\item{link}{List of project information used to create a web link for each missing event.} +\item{report_zeros}{Logical, include variables with zero queries in the report. Default is \code{FALSE}.} + +\item{link}{Optional list containing project information (\code{domain}, \code{redcap_version}, \code{proj_id}, \code{event_id}) to generate clickable links for each query.} } \value{ -A list with a data frame of 9 columns (10 columns if the link argument is specified) to help the user identify each missing event and a table with the total number of missing events per event analyzed. +A named list with two elements: +\describe{ +\item{\code{queries}}{A data frame listing records missing the specified events. +Columns: \code{Identifier}, \code{DAG}, \code{Event}, \code{Instrument}, +\code{Field}, \code{Repetition}, \code{Description}, \code{Query}, \code{Code}, +and optionally \code{Link}. If no queries are found this will be an empty +data frame with the expected columns.} +\item{\code{results}}{An HTML table (knitr::kable styled with kableExtra) summarising +the number of missing records per event. Returned as \code{knitr::kable} (HTML).} +} } \description{ -When working with a longitudinal REDCap project, the exported data has a structure where each row represents one event per record. However, by default REDCap does not export events for which there is no information available. -This function allows you to identify which records do not contain information about a particular event. +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +Helps identify records in a REDCap longitudinal project that are missing one or more specified events. Because REDCap typically omits empty events from exports, an event that contains no data for a record will not appear. This function finds those absent events and returns a per-record query table and a summarized HTML report. } \examples{ -example <- rd_event(covican, - event = "follow_up_visit_da_arm_1") -example +# Minimal reproducible example +data0 <- data.frame( + record_id = c("100-1", "100-2", "200-1"), + redcap_event_name = c("baseline_arm_1", "baseline_arm_1", "follow_up_arm_1"), + redcap_event_name.factor = factor(c("Baseline", "Baseline", "Follow-up")), + stringsAsFactors = FALSE +) + +# Suppose we want to check that every record has the follow-up event +res <- rd_event( + data = data0, + dic = data.frame(), # placeholder dictionary + event = "follow_up_arm_1", + report_zeros = TRUE +) + +# Records missing the event: +res$queries + +# HTML summary (in RMarkdown or Viewer) +res$results + } diff --git a/man/rd_export.Rd b/man/rd_export.Rd index 1ea7e41..d545706 100644 --- a/man/rd_export.Rd +++ b/man/rd_export.Rd @@ -2,10 +2,10 @@ % Please edit documentation in R/rd_export.R \name{rd_export} \alias{rd_export} -\title{Exporting Query Dataset} +\title{Export Queries to an Excel File} \usage{ rd_export( - ..., + project = NULL, queries = NULL, column = NULL, sheet_name = NULL, @@ -14,21 +14,34 @@ rd_export( ) } \arguments{ -\item{...}{List containing the data frame of queries. This list must be the output of the `rd_query` or `rd_event` functions.} +\item{project}{A list containing the dataframe of queries and results (expected \code{rd_query} or \code{rd_event} output). Overrides \code{queries}.} -\item{queries}{Data frame containing the identified queries. If the list is specified, this argument is not required.} +\item{queries}{A data frame of identified queries.} -\item{column}{Character element specifying the column containing the link for each query.} +\item{column}{Name of the column containing URLs to convert into hyperlinks. If \code{NULL}, hyperlinks are added only if a \code{Link} column exists.} -\item{sheet_name}{Character element specifying the sheet name of the resulting xlsx file.} +\item{sheet_name}{Name of the Excel sheet in the resulting \code{.xlsx} file. Default: \code{"Sheet1"}.} -\item{path}{Character element specifying the file path to save the xlsx file. If `NULL`, the file will be created in the current working directory.} +\item{path}{File path for saving the \code{.xlsx} file. If \code{NULL}, the file is saved as \code{"example.xlsx"} in the working directory.} -\item{password}{String with the password to protect the worksheet and prevent others from making changes.} +\item{password}{Optional password to protect the worksheet from edits.} } \value{ -An .xlsx file containing all the queries and, if available, hyperlinks to each of them. +An \code{.xlsx} file written to the specified path. } \description{ -This function exports a query report, generated using the `rd_query` or `rd_event` functions, to an .xlsx file. +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Export a query dataset (e.g., from \code{rd_query} or \code{rd_event}) to an \code{.xlsx} file. The function can optionally convert a column of URLs into Excel hyperlinks and apply password protection to the worksheet. +} +\examples{ +\dontrun{ +rd_export( + queries = my_queries, + column = "Link", + sheet_name = "My Queries", + path = "queries.xlsx" +) +} + } diff --git a/man/rd_factor.Rd b/man/rd_factor.Rd new file mode 100644 index 0000000..8a9abb1 --- /dev/null +++ b/man/rd_factor.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rd_factor.R +\name{rd_factor} +\alias{rd_factor} +\title{Convert Variables to Factors in a REDCap Dataset} +\usage{ +rd_factor( + project = NULL, + data = NULL, + dic = NULL, + event_form = NULL, + exclude = NULL +) +} +\arguments{ +\item{project}{A list containing the REDCap data, dictionary, and event mapping (expected \code{redcap_data()} output). Overrides \code{data}, \code{dic}, and \code{event_form}.} + +\item{data}{A \code{data.frame} or \code{tibble} with the REDCap dataset.} + +\item{dic}{A \code{data.frame} with the REDCap dictionary.} + +\item{event_form}{Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects.} + +\item{exclude}{Optional character vector of variable names (use original names \strong{without} the \code{.factor} suffix) to exclude from conversion.} +} +\value{ +A list with the following elements: +\describe{ +\item{data}{The transformed dataset with \code{.factor} columns applied as factors.} +\item{dictionary}{The dictionary used (unchanged).} +\item{event_form}{The event-form mapping used (if applicable).} +\item{results}{A brief text summary of the transformation.} +} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Converts variables in a REDCap dataset with associated \code{.factor} columns into actual factor variables, while allowing the exclusion of specific variables. Ensures consistency with the dataset and preserves variable labels. +} +\details{ +The function looks for columns ending in \code{.factor} and replaces the original variable values with those \code{.factor} values (converted to factors). It preserves variable labels. The \code{exclude} argument must contain base variable names (no \code{.factor} suffix); if any \code{.factor} names are passed to \code{exclude} the function will throw an informative error. The columns \code{redcap_event_name}, \code{redcap_repeat_instrument} and \code{redcap_data_access_group} (and their \code{.factor} counterparts) are handled specially to avoid altering event or access-group data. +} +\examples{ +\dontrun{ +result <- rd_factor(covican) +result <- rd_factor(covican, exclude = c("available_analytics", "urine_culture")) +transformed_data <- result$data +} + +} diff --git a/man/rd_insert_na.Rd b/man/rd_insert_na.Rd index d217cc9..8e36aac 100644 --- a/man/rd_insert_na.Rd +++ b/man/rd_insert_na.Rd @@ -4,31 +4,60 @@ \alias{rd_insert_na} \title{Insert Missing Values Using a Filter} \usage{ -rd_insert_na(..., data = NULL, dic = NULL, event_form = NULL, vars, filter) +rd_insert_na( + project = NULL, + data = NULL, + dic = NULL, + event_form = NULL, + vars, + filter +) } \arguments{ -\item{...}{List containing the data, the dictionary and the event if it's needed. Should be the output of the function `redcap_data`.} +\item{project}{A list containing the REDCap data, dictionary, and event mapping (expected \code{redcap_data()} output). Overrides \code{data}, \code{dic}, and \code{event_form}.} -\item{data}{Data frame containing data from REDCap. If the list is specified, this argument is not needed.} +\item{data}{A \code{data.frame} or \code{tibble} with the REDCap dataset.} -\item{dic}{Data frame containing the dictionary read from REDCap. If the list is specified, this argument is not needed.} +\item{dic}{A \code{data.frame} with the REDCap dictionary.} -\item{event_form}{Data frame containing the correspondence of each event with each form. If the list is specified, this argument is not needed.} +\item{event_form}{Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects.} -\item{vars}{Character vector containing the names of the variables to be transformed.} +\item{vars}{Character vector of variable names to set to \code{NA}.} -\item{filter}{Character vector containing the logic to be evaluated directly. If each logic is TRUE, the corresponding variable in `vars` is set to missing.} +\item{filter}{A single logical expression (as string). Rows where the filter evaluates to \code{TRUE} will have the corresponding \code{vars} set to \code{NA}.} } \value{ -Transformed data with the specified variables converted. +A list with: +\describe{ +\item{data}{The dataset with \code{NA} inserted where the filter applies.} +\item{dictionary}{The unchanged dictionary.} +\item{event_form}{The \code{event_form} passed in (if applicable).} +\item{results}{Summary message of the changes applied.} +} } \description{ -This function allows you to manually insert a missing value into certain variables (`vars`) if the specified filter/s (`filter`) are satisfied. It's particularly useful for checkboxes without a gatekeeper question in the branching logic. Note that the variable is only transformed in the events where both the variable and the filter evaluation are present, so they must have at least one event in common. +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +Sets selected variables to \code{NA} when a filter condition is satisfied. Useful for managing checkboxes or other fields without explicit gatekeeper questions. +} +\details{ +\itemize{ +\item Each variable is only updated in rows/events where both the variable and filter are present. +\item For longitudinal projects, \code{event_form} must be provided for proper event-level filtering. +\item Only one filter expression is allowed. +\item Variables and filter columns must exist in both \code{data} and \code{dictionary}. +} } \examples{ -table(is.na(covican$data$potassium)) -data <- rd_insert_na(covican, - vars = "potassium", - filter = "age < 65") +# Set 'potassium' to NA where age < 65 +\dontrun{ +data <- rd_insert_na( + data = covican$data, + dic = covican$dictionary, + vars = "potassium", + filter = "age < 65" +) table(data$potassium) } + +} diff --git a/man/rd_query.Rd b/man/rd_query.Rd index 8cc84a7..5f823e6 100644 --- a/man/rd_query.Rd +++ b/man/rd_query.Rd @@ -5,7 +5,7 @@ \title{Identification of Queries} \usage{ rd_query( - ..., + project = NULL, variables = NA, expression = NA, negate = FALSE, @@ -25,67 +25,96 @@ rd_query( ) } \arguments{ -\item{...}{List containing the data, dictionary and event mapping (if required) of the REDCap project. This should be the output of the `redcap_data` function.} +\item{project}{A list containing the REDCap data, dictionary, and event mapping (expected \code{redcap_data()} output). Overrides \code{data}, \code{dic}, and \code{event_form}.} -\item{variables}{Character vector containing the names of the database variables to be checked.} +\item{variables}{Character vector of variable names to check for queries.} -\item{expression}{Character vector of expressions to apply to the selected variables.} +\item{expression}{Character vector of R expressions to evaluate for each variable.} -\item{negate}{Logical value indicating whether the defined expression should be negated. Default value is `FALSE`.} +\item{negate}{Logical, if \code{TRUE}, identifies values that \strong{do not} meet the condition. Default is \code{FALSE}.} -\item{event}{The name of the REDCap event to analyze. If there are events in your REDCap project, you should use this argument to name the event to which the defined variables belong.} +\item{event}{Required for longitudinal projects to avoid overestimation. REDCap event(s) to analyze.} -\item{filter}{A filter to be applied to the dataset. For example, this argument can be used to apply the branching logic of a defined variable.} +\item{filter}{Optional string of filters to apply to the dataset, such as the branching logic of a variable.} -\item{addTo}{Data frame corresponding to a previous query data frame to which you can add the new query data frame. By default, this function always creates a new data frame regardless previous reports.} +\item{addTo}{Optional data frame from a previous query report to which the new results can be appended.} -\item{variables_names}{Character vector containing the description of each selected variable. By default, the function automatically takes the description of each variable from of the REDCap project dictionary.} +\item{variables_names}{Optional character vector of descriptions for each variable. Defaults to the variables labels in the dictionary.} -\item{query_name}{Description of the query. It can be the same for all variables, or you can define a different one for each variable. By default, this function defines it as `The value is [value] and it should not be [expression]'`.} +\item{query_name}{Optional character vector describing each query. Defaults to a standard format: \verb{The value is [value] and it should not be [expression]}.} -\item{instrument}{REDCap instrument to which the variables belong. It can be the same for all variables, or you can define a different one for each variable. By default, the function automatically selects the corresponding instrument of each variable from the REDCap project dictionary.} +\item{instrument}{Optional REDCap instrument(s) for each variable. Defaults to the instrument reported in the dictionary.} -\item{report_title}{Character string specifying the title of the report.} +\item{report_title}{Optional string specifying the title of the final report. Defaults to \code{"Report of queries"}.} -\item{report_zeros}{Logical. If `TRUE`, the function returns a report containing variables with zero queries.} +\item{report_zeros}{Logical, include variables with zero queries in the report. Default is \code{FALSE}.} -\item{by_dag}{Logical. If `TRUE`, both elements of the output will be grouped by the Data Access Groups (DAGs) of the REDCap project.} +\item{by_dag}{Logical, split results by Data Access Group (DAG). Default is \code{FALSE}.} -\item{link}{List containing project information used to create a web link to each query.} +\item{link}{Optional list containing project information (\code{domain}, \code{redcap_version}, \code{proj_id}, \code{event_id}) to generate clickable links for each query.} -\item{data}{Data frame containing the data read from REDCap. If the list is given, this argument is not required.} +\item{data}{A \code{data.frame} or \code{tibble} with the REDCap dataset.} -\item{dic}{Data frame containing the dictionary read from REDCap. If the list is given, this argument is not required.} +\item{dic}{A \code{data.frame} with the REDCap dictionary.} -\item{event_form}{Data frame containing the correspondence of each event with each form. If the list is specified, this argument is not required.} +\item{event_form}{Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects.} } \value{ -A list with a data frame of 9 columns (10 columns, if the link argument is specified) meant to help the user identify each query and a table with the total number of queries per variable. +A list containing: +\describe{ +\item{queries}{A data frame or a list of data frames (if \code{by_dag = TRUE}) with detailed query information for each record.} +\item{results}{A formatted report (HTML table) summarizing total queries per variable, event, and DAG if applicable.} +} } \description{ -This function allows you to identify queries using a particular expression/filter. -It can be used to identify missing values or to identify values outside the lower and upper limits of a variable. +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +Detects and summarizes queries in a REDCap dataset based on specified expressions, filters, or a defined branching logic. Useful for identifying missing values, out-of-range values, or values that do not meet predefined criteria. +} +\details{ +The function performs the following steps: +\itemize{ +\item Applies user-specified expressions to the selected variables to detect queries. +\item Optionally negates the expressions to find values that \strong{do not} satisfy the condition. +\item Handles REDCap branching logic, converting it into R-compatible expressions for evaluation. +\item Applies additional user-specified filters before identifying queries. +\item Generates structured query results with metadata including: +\itemize{ +\item Identifier (record_id) +\item DAG (if present) +\item Event and Instrument +\item Field, Repetition, Description, Query statement +\item Optional link to REDCap entry +} +\item Optionally combines results with previous query outputs using \code{addTo}. +\item Produces a summarized report, optionally including variables with zero queries. +\item Provides warnings for variables with branching logic that could not be automatically evaluated. +} } \examples{ -# Missing values -example <- rd_query(covican, - variables = c("copd", "age"), - expression = c("is.na(x)", "x \%in\% NA"), - event = "baseline_visit_arm_1") -example - -# Expression -example <- rd_query(covican, - variables="age", - expression="x>20", - event="baseline_visit_arm_1") -example - -# Using the filter argument -example <- rd_query(covican, - variables = "potassium", - expression = "is.na(x)", - event = "baseline_visit_arm_1", - filter = "available_analytics=='1'") -example +\dontrun{ +# Identify missing values for multiple variables +result <- rd_query(covican, + variables = c("copd", "age"), + expression = c("is.na(x)", "x \%in\% NA"), + event = "baseline_visit_arm_1" +) +result$results + +# Identify values exceeding a threshold +result <- rd_query(covican, + variables = "age", + expression = "x > 20", + event = "baseline_visit_arm_1" +) + +# Apply a filter to select subset of data +result <- rd_query(covican, + variables = "potassium", + expression = "is.na(x)", + event = "baseline_visit_arm_1", + filter = "available_analytics == '1'" +) +} + } diff --git a/man/rd_recalculate.Rd b/man/rd_recalculate.Rd new file mode 100644 index 0000000..45e692e --- /dev/null +++ b/man/rd_recalculate.Rd @@ -0,0 +1,67 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rd_recalculate.R +\name{rd_recalculate} +\alias{rd_recalculate} +\title{Recalculate and Verify Calculated Fields in REDCap Data} +\usage{ +rd_recalculate( + project = NULL, + data = NULL, + dic = NULL, + event_form = NULL, + exclude = NULL +) +} +\arguments{ +\item{project}{A list containing the REDCap data, dictionary, and event mapping (expected \code{redcap_data()} output). Overrides \code{data}, \code{dic}, and \code{event_form}.} + +\item{data}{A \code{data.frame} or \code{tibble} with the REDCap dataset.} + +\item{dic}{A \code{data.frame} with the REDCap dictionary.} + +\item{event_form}{Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects.} + +\item{exclude}{Optional. Character vector of field names to exclude from recalculation.} +} +\value{ +A list with: +\describe{ +\item{data}{The dataset with new \verb{_recalc} fields for any differing calculated fields.} +\item{dictionary}{Updated dictionary including the new \verb{_recalc} fields.} +\item{event_form}{The \code{event_form} passed in (if applicable).} +\item{results}{Summary report of the recalculation process, including tables of discrepancies.} +} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Recalculates fields marked as calculated in the REDCap dictionary, compares them with the original values, and reports discrepancies. If any differences are found, new recalculated fields are added to the dataset and dictionary with \verb{_recalc} appended to the names. +} +\details{ +\itemize{ +\item Fields of type \code{calc} in the dictionary are recalculated. +\item Recalculated values are compared with the original values. +\item If differences exist, new fields \verb{[field_name]_recalc} are added to the dataset and dictionary. +\item Works for single-event projects; for longitudinal projects, \code{event_form} must be provided. +\item Fields with incomplete branching logic or smart variables may fail to recalculate. +} +} +\examples{ +# Recalculate all calculated fields +\dontrun{ +results <- rd_recalculate( + data = covican$data, + dic = covican$dictionary, + event_form = covican$event_form +) +} + +# Recalculate but exclude some variables +\dontrun{ +results <- rd_recalculate( + project = covican, + exclude = c("age", "screening_fail_crit") +) +} + +} diff --git a/man/rd_rlogic.Rd b/man/rd_rlogic.Rd index 737cb27..ad651e4 100644 --- a/man/rd_rlogic.Rd +++ b/man/rd_rlogic.Rd @@ -4,29 +4,59 @@ \alias{rd_rlogic} \title{Translate REDCap Logic to R Logic} \usage{ -rd_rlogic(..., data = NULL, dic = NULL, event_form = NULL, logic, var) +rd_rlogic( + project = NULL, + data = NULL, + dic = NULL, + event_form = NULL, + logic, + var +) } \arguments{ -\item{...}{List containing the data, dictionary and event mapping (if applicable) of the REDCap project. This should be the output of the `redcap_data` function.} +\item{project}{A list containing the REDCap data, dictionary, and event mapping (expected \code{redcap_data()} output). Overrides \code{data}, \code{dic}, and \code{event_form}.} -\item{data}{Data frame containing data from REDCap. If the list is specified, this argument is not required.} +\item{data}{A \code{data.frame} or \code{tibble} with the REDCap dataset.} -\item{dic}{Data frame containing the dictionary read from REDCap. If the list is specified, this argument is not required.} +\item{dic}{A \code{data.frame} with the REDCap dictionary.} -\item{event_form}{Data frame containing the correspondence of each event with each form. If the list is specified, this argument is not required.} +\item{event_form}{Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects.} -\item{logic}{String containing logic in REDCap format.} +\item{logic}{A single REDCap logic string (e.g., \code{"if([exc_1]='1' or [inc_1]='0', 1, 0)"}).} -\item{var}{String with the name of the variable containing the logic.} +\item{var}{A single string specifying the target variable the logic applies to.} } \value{ -List containing the logic in R format and its evaluation. +A list with: +\describe{ +\item{rlogic}{The translated R-compatible logic as a string.} +\item{eval}{The evaluation of the translated logic on the provided dataset, filtered by event if applicable.} +} } \description{ -This function allows you to convert REDCap logic into R logic. WARNING: Please note that if the REDCap logic involves smart variables, this function may not be able to transform it accurately. +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +Converts a REDCap logic expression into R-compatible logic. Processes one logic expression (\code{logic}) for one target variable (\code{var}) at a time. Supports common REDCap operators (\code{and}, \code{or}, \code{=}, \code{<}, \code{>}, etc.) and handles event-specific logic in longitudinal projects. Logic involving smart variables or repeated instruments may require manual review. +} +\details{ +\itemize{ +\item Translates REDCap operators and functions into R equivalents: +\itemize{ +\item \code{=} → \code{==}, \verb{<>} → \code{!=}, \code{and} → \code{&}, \code{or} → \code{|}. +\item Converts functions like \verb{if()}, \code{rounddown()}, \code{datediff()}, \code{sum()} to R equivalents. +} +\item Handles date transformations and empty strings (\code{''}) → \code{NA}. +\item Adjusts logic for longitudinal data using \code{event_form} if provided. +\item Evaluates the translated R logic against the dataset and returns the results. +\item Logic with repeated instruments, smart variables, or multiple events per variable may require manual inspection. +} } \examples{ -rd_rlogic(covican, - logic = "if([exc_1]='1' or [inc_1]='0' or [inc_2]='0' or [inc_3]='0',1,0)", - var = "screening_fail_crit") +# Translate a single REDCap logic expression for one variable +covican |> + rd_rlogic( + logic = "if([exc_1]='1' or [inc_1]='0' or [inc_2]='0' or [inc_3]='0', 1, 0)", + var = "screening_fail_crit" + ) + } diff --git a/man/rd_split.Rd b/man/rd_split.Rd new file mode 100644 index 0000000..a8bdf77 --- /dev/null +++ b/man/rd_split.Rd @@ -0,0 +1,68 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/rd_split.R +\name{rd_split} +\alias{rd_split} +\title{Split a REDCap dataset by form or event} +\usage{ +rd_split( + project = NULL, + data = NULL, + dic = NULL, + event_form = NULL, + which = NULL, + by = "form", + wide = FALSE +) +} +\arguments{ +\item{project}{A list containing the REDCap data, dictionary, and event mapping (expected \code{redcap_data()} output). Overrides \code{data}, \code{dic}, and \code{event_form}.} + +\item{data}{A \code{data.frame} or \code{tibble} with the REDCap dataset.} + +\item{dic}{A \code{data.frame} with the REDCap dictionary.} + +\item{event_form}{Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects.} + +\item{which}{Optional. A single form or event to extract. If not provided, all forms or events are returned.} + +\item{by}{Character. Criteria to split the dataset: \code{"form"} (default) or \code{"event"}.} + +\item{wide}{Logical. If \code{TRUE} (for form-based splits), repeated instances are returned in wide format. Defaults to \code{FALSE}.} +} +\value{ +Depending on \code{which} and \code{wide}: +\describe{ +\item{data}{A \code{data.frame} or a list of \code{data.frames} representing the split datasets.} +\item{dictionary}{The original REDCap dictionary.} +\item{event_form}{The original event-form mapping (if applicable).} +\item{results}{A summary message of the splitting operation.} +} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Splits a REDCap dataset into separate datasets by \strong{form} or \strong{event} using the data dictionary. Supports both longitudinal and non-longitudinal projects and can return wide or long formats for repeated measures. +} +\details{ +\itemize{ +\item Handles checkbox variables and REDCap default variables (\verb{_complete}, \verb{_timestamp}) appropriately. +\item For form-based splits in longitudinal projects, uses \code{event_form} to map variables to events. +\item Wide format expands repeated instances into multiple columns per record. +\item Filtering by \code{which} allows extracting a single form or event. +\item Projects with repeated instruments are handled by filtering on the \code{redcap_repeat_instrument} variable. +} +} +\examples{ +# Split by form and return wide format +result <- covican |> + rd_split(by = "form", wide = TRUE) + +print(result) + +# Split by event (long format) +result <- covican |> + rd_split(by = "event") + +print(result) + +} diff --git a/man/rd_transform.Rd b/man/rd_transform.Rd index 06dc9f8..fbd424f 100644 --- a/man/rd_transform.Rd +++ b/man/rd_transform.Rd @@ -5,16 +5,16 @@ \title{Transformation of the Raw Data} \usage{ rd_transform( - ..., + project = NULL, data = NULL, dic = NULL, event_form = NULL, checkbox_labels = c("No", "Yes"), - checkbox_na = FALSE, + na_logic = "none", exclude_recalc = NULL, - exclude_to_factor = NULL, + exclude_factor = NULL, delete_vars = NULL, - delete_pattern = c("_complete", "_timestamp"), + delete_pattern = NULL, final_format = "raw", which_event = NULL, which_form = NULL, @@ -22,46 +22,60 @@ rd_transform( ) } \arguments{ -\item{...}{Output of the `redcap_data` function, which is a list containing the data frames of the data, dictionary and event_form (if needed) of the REDCap project.} +\item{project}{A list containing the REDCap data, dictionary, and event mapping (expected \code{redcap_data()} output). Overrides \code{data}, \code{dic}, and \code{event_form}.} -\item{data}{Data frame containing the data read from REDCap. If the list is specified, this argument is not necessary.} +\item{data}{A \code{data.frame} or \code{tibble} with the REDCap dataset.} -\item{dic}{Data frame containing the dictionary read from REDCap. If the list is specified, this argument is not necessary.} +\item{dic}{A \code{data.frame} with the REDCap dictionary.} -\item{event_form}{Data frame containing the correspondence of each event with each form. If the list is specified, this argument is not necessary.} +\item{event_form}{Only applicable for longitudinal projects (presence of events). Event-to-form mapping for longitudinal projects.} -\item{checkbox_labels}{Character vector with the names for the two options of every checkbox variable. Default is `c('No', 'Yes')`.} +\item{checkbox_labels}{Character vector of length 2 for labels of unchecked/checked values. Default: \code{c("No", "Yes")}.} -\item{checkbox_na}{Logical indicating if checkboxes values with branching logic should be set to missing only when the branching logic is missing (`FALSE`), or also when the branching logic isn't satisfied (`TRUE`). The default is `FALSE`.} +\item{na_logic}{Controls how missing values are set based on the branching logic of a checkbox. Must be one of \code{"none"} (do nothing), \code{"missing"} (set to \code{NA} only when the logic evaluation is \code{NA}), or \code{"eval"} (set to \code{NA} when the logic evaluates to \code{FALSE}). Defaults to \code{"none"}.} -\item{exclude_recalc}{Character vector with the names of variables that should not be recalculated. Useful for projects with time-consuming recalculations of certain calculated fields.} +\item{exclude_recalc}{Optional. Character vector of field names to exclude from recalculation.} -\item{exclude_to_factor}{Character vector with the names of variables that should not be transformed to factors.} +\item{exclude_factor}{Optional character vector of variable names (use original names \strong{without} the \code{.factor} suffix) to exclude from conversion.} -\item{delete_vars}{Character vector specifying the variables to exclude.} +\item{delete_vars}{Optional. A character vector of variable names to remove from both the dataset and dictionary.} -\item{delete_pattern}{Character vector specifying the regex pattern for variables to be excluded. By default, variables ending with `_complete` and `_timestamp` will be removed.} +\item{delete_pattern}{Optional. A character vector of regular expression patterns. Variables matching these patterns will be removed from the dataset and dictionary.} -\item{final_format}{Character string indicating the final format of the data. Options are `raw`, `by_event` or `by_form`. `raw` (default) returns the transformed data in its original structure, `by_event` returns it as a nested data frame by event, and `by_form` returns it as a nested data frame by form.} +\item{final_format}{Character string indicating the final format of the data. Options are \code{raw}, \code{by_event} or \code{by_form}. \code{raw} (default) returns the transformed data in its original structure, \code{by_event} returns it as a nested data frame by event, and \code{by_form} returns it as a nested data frame by form.} -\item{which_event}{Character string indicating a specific event to return if the final format is `by_event`.} +\item{which_event}{Character. If \code{final_format = "by_event"}, return only this event.} -\item{which_form}{Character string indicating a specific form to return if the final format is `by_form`.} +\item{which_form}{Character. If \code{final_format = "by_form"}, return only this form.} -\item{wide}{Logical indicating if the data split by form (if selected) should be in a wide format (`TRUE`) or a long format (`FALSE`).} +\item{wide}{Logical. If \code{TRUE} (for form-based splits), repeated instances are returned in wide format. Defaults to \code{FALSE}.} } \value{ -A list with the transformed dataset, dictionary, event_form, and the results of each transformation step. +A list with elements: +\describe{ +\item{data}{Transformed data (data.frame or nested list when split).} +\item{dictionary}{Updated dictionary data.frame.} +\item{event_form}{Event–form mapping (if applicable).} +\item{results}{Character summary of transformation steps performed.} +} } \description{ -This function transforms the raw REDCap data read by the `redcap_data` function. It returns the transformed data and dictionary, along with a summary of the results of each step. +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} + +Transforms the raw REDCap data read by the \code{redcap_data} function. The function runs in one-step pipeline all functions dedicated to processing the data and returns the transformed data and dictionary, along with a summary of each step done. } \examples{ -# Basic transformation -rd_transform(covican) +# Minimal usage (project object or data + dictionary) +trans <- rd_transform(covican) + +# Custom checkbox labels +trans <- rd_transform(covican, + checkbox_labels = c("Not present", "Present")) -# For customization of checkbox labels (example) -rd_transform(covican, - checkbox_labels = c("Not present", "Present")) +# Return only a single form (wide) +trans <- rd_transform(covican, + final_format = "by_form", + which_form = "laboratory_findings", + wide = TRUE) } diff --git a/man/recalculate.Rd b/man/recalculate.Rd index ed5fde9..f5428a4 100644 --- a/man/recalculate.Rd +++ b/man/recalculate.Rd @@ -18,5 +18,5 @@ recalculate(data, dic, event_form = NULL, exclude_recalc = NULL) \description{ This function recalculates each calculated field if the logic can be transcribed to R. Note that calculated fields containing smart-variables or variables from other events cannot be transcribed. -The function returns the dataset and dictionary with the recalculated variables appended (named as the original field plus `_recalc`), along with a summary table of the recalculation results. +The function returns the dataset and dictionary with the recalculated variables appended (named as the original field plus \verb{_recalc}), along with a summary table of the recalculation results. } diff --git a/man/redcap_data.Rd b/man/redcap_data.Rd index 0511a18..9f65a2d 100644 --- a/man/redcap_data.Rd +++ b/man/redcap_data.Rd @@ -15,57 +15,76 @@ redcap_data( ) } \arguments{ -\item{data_path}{Character string specifying the path of the R file from which the dataset will be read.} +\item{data_path}{Path to exported R file (use with \code{dic_path}).} -\item{dic_path}{Character string with the path of the dictionary.} +\item{dic_path}{Path to the dictionary file (CSV or XLSX; use with \code{data_path})..} -\item{event_path}{Character string specifying the path of the file containing the correspondence between each event and each form (downloadable via the `Designate Instruments for My Events` tab within the `Project Setup` section of REDCap).} +\item{event_path}{Path to the event-form mapping file (CSV or XLSX) for longitudinal projects (downloadable via the \verb{Designate Instruments for My Events} tab within the \verb{Project Setup} section of REDCap).} -\item{uri}{The URI (Uniform Resource Identification) of the REDCap project.} +\item{uri}{REDCap API base URI (use with \code{token}).} -\item{token}{Character vector containing the generated token.} +\item{token}{REDCap API token (use with \code{uri}).} -\item{filter_field}{Character vector specifying the fields of the REDCap project desired to be imported into R (via API connection only).} +\item{filter_field}{Optional character vector of field names to request from the API.} -\item{survey_fields}{Logical indicating whether the function should download all the survey-related fields of the REDCap project (via API connection only).} +\item{survey_fields}{Logical; include survey-related fields when pulling via API. Default \code{FALSE}.} } \value{ -A list containing the dataset and the dictionary of the REDCap project. If `event_path` is specified, it will also contain a third element with the correspondence of the events and forms of the project. +A list with: +\itemize{ +\item \code{data}: Imported dataset. +\item \code{dictionary}: Variable dictionary (project metadata). +\item \code{event_form}: Event-form mapping for longitudinal projects (if applicable). +} } \description{ -This function allows users to read datasets from a REDCap project into R for analysis, either by exporting the data or via an API connection. - -The REDCap API serves as an interface for communication with REDCap and the server without requiring interaction through the REDCap interface. - -[Important] To read exported data from REDCap, please follow these steps: - -- Use REDCap's 'Export Data' function. - -- Select the 'R Statistical Software' format. +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#stable}{\figure{lifecycle-stable.svg}{options: alt='[Stable]'}}}{\strong{[Stable]}} -- REDCap will then generate two files: - - - A CSV file containing all observations of the REDCap project. +Import REDCap data into R either from REDCap's exported R file or directly via the REDCap API. The function returns a list with the dataset, the project dictionary (metadata) and, for longitudinal projects, the instrument–event mapping (\code{event_form}) when available. +} +\details{ +Two import modes are supported: +\itemize{ +\item \strong{Exported files} — use \code{data_path} (REDCap R export) and \code{dic_path} (dictionary CSV/XLSX). +\item \strong{API} — use \code{uri} and \code{token} to pull data and metadata directly from REDCap. +} - - An R file with the necessary code to complete each variable's information and import them. +If the project is longitudinal, provide \code{event_path} (instrument–event mapping) +or the function will attempt to fetch it from the API when using API mode. -- Ensure these files, along with the dictionary and event-mapping, are in the same directory. +\strong{Steps for using exported data in REDCap:} +\enumerate{ +\item Use the REDCap \emph{Export Data} function and choose \emph{R Statistical Software} format. +\item REDCap generates: +\itemize{ +\item A CSV file with observations. +\item An R script to format variables for import. +} +\item Ensure the exported files, dictionary, and event mapping (if any) are in the same directory. +} } \note{ -For further use of the package, it's recommended to use the `dic_path` argument to read the dictionary, as all other functions require it for proper functioning. +To use other package functions effectively, include the \code{dic_path} argument to load the project dictionary. + +\itemize{ +\item Use either exported-files mode (\code{data_path} + \code{dic_path}) \strong{or} API mode (\code{uri} + \code{token}) — not both. +\item For exported files, REDCap's R export is required for \code{data_path}. Dictionary and event files must be CSV or XLSX. +} } \examples{ \dontrun{ -# Exported files from REDCap - -dataset <- redcap_data(data_path = "C:/Users/username/example.r", - dic_path = "C:/Users/username/example_dictionary.csv", - event_path = "C:/Users/username/events.csv") - -# API connection - -dataset_api <- redcap_data(uri = "https://redcap.idibell.cat/api/", - token = "55E5C3D1E83213ADA2182A4BFDEA") # This token is fictitious +# From exported files +out <- redcap_data( + data_path = "project_export.r", + dic_path = "project_dictionary.csv", + event_path = "instrument_event_map.csv" +) +# From API +out_api <- redcap_data( + uri = "https://redcap.example.org/api/", + token = "REPLACE_WITH_TOKEN" +) } + } diff --git a/man/round.Rd b/man/round.Rd new file mode 100644 index 0000000..103f0db --- /dev/null +++ b/man/round.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils-suplement.R +\name{round} +\alias{round} +\title{Round Numbers to a Specified Number of Digits ----} +\usage{ +round(x, digits) +} +\arguments{ +\item{x}{A numeric vector to be rounded.} + +\item{digits}{Integer indicating the number of decimal places to round to.} +} +\value{ +A numeric vector rounded to the specified number of digits. +} +\description{ +This function rounds numeric values to the specified number of decimal digits, +mimicking the behavior of the base R \code{round()} function but implemented manually. +} +\examples{ +round(3.14159, 2) +round(c(-2.718, 3.14159), 1) + +} diff --git a/man/split_form.Rd b/man/split_form.Rd index 76b34fc..4860f6f 100644 --- a/man/split_form.Rd +++ b/man/split_form.Rd @@ -15,7 +15,7 @@ split_form(data, dic, event_form = NULL, which = NULL, wide = FALSE) \item{which}{Character string specifying a form if only data for that form is desired.} -\item{wide}{Logical indicating if the dataset should be returned in a wide format (`TRUE`) or long format (`FALSE`).} +\item{wide}{Logical indicating if the dataset should be returned in a wide format (\code{TRUE}) or long format (\code{FALSE}).} } \description{ This function generates a nested dataset containing only the variables associated with each form, using the provided data, dictionary, and event-form mapping. You can choose to return data for a specific form. diff --git a/man/to_factor.Rd b/man/to_factor.Rd index 0c122ba..6b28556 100644 --- a/man/to_factor.Rd +++ b/man/to_factor.Rd @@ -11,8 +11,8 @@ to_factor(data, dic, exclude = NULL) \item{dic}{Data frame containing the REDCap dictionary.} -\item{exclude}{Character vector specifying the names of variables that should not be converted to factors. If `NULL`, all variables will be converted.} +\item{exclude}{Character vector specifying the names of variables that should not be converted to factors. If \code{NULL}, all variables will be converted.} } \description{ -This function converts all variables in the dataset to factors, except those specified in the `exclude` parameter. +This function converts all variables in the dataset to factors, except those specified in the \code{exclude} parameter. } diff --git a/man/transform_checkboxes.Rd b/man/transform_checkboxes.Rd index 474adf6..b67c8a7 100644 --- a/man/transform_checkboxes.Rd +++ b/man/transform_checkboxes.Rd @@ -13,10 +13,10 @@ transform_checkboxes(data, dic, event_form = NULL, checkbox_na = FALSE) \item{event_form}{Data frame containing the correspondence of each event with each form.} -\item{checkbox_na}{Logical indicating if values of checkboxes with branching logic should be set to missing only when the branching logic is missing (`FALSE`), or also when the branching logic is not satisfied (`TRUE`). The default is `FALSE`.} +\item{checkbox_na}{Logical indicating if values of checkboxes with branching logic should be set to missing only when the branching logic is missing (\code{FALSE}), or also when the branching logic is not satisfied (\code{TRUE}). The default is \code{FALSE}.} } \description{ -This function inspects all the checkboxes in the study to determine if they have a branching logic. If a branching logic is present and its result is missing, the function will input a missing value into the checkbox. If `checkbox_na` is `TRUE`, the function will additionally input a missing value when the branching logic isn't satisfied, not just when it is missing. If a branching logic cannot be found or the logic cannot be transcribed due to the presence of smart variables, the variable is added to a list of reviewable variables that will be printed. +This function inspects all the checkboxes in the study to determine if they have a branching logic. If a branching logic is present and its result is missing, the function will input a missing value into the checkbox. If \code{checkbox_na} is \code{TRUE}, the function will additionally input a missing value when the branching logic isn't satisfied, not just when it is missing. If a branching logic cannot be found or the logic cannot be transcribed due to the presence of smart variables, the variable is added to a list of reviewable variables that will be printed. The function returns the dataset with the transformed checkboxes and a table summarizing the results. } diff --git a/pkgdown/favicon/apple-touch-icon.png b/pkgdown/favicon/apple-touch-icon.png new file mode 100644 index 0000000..c3fc0e5 Binary files /dev/null and b/pkgdown/favicon/apple-touch-icon.png differ diff --git a/pkgdown/favicon/favicon-96x96.png b/pkgdown/favicon/favicon-96x96.png new file mode 100644 index 0000000..a094a9e Binary files /dev/null and b/pkgdown/favicon/favicon-96x96.png differ diff --git a/pkgdown/favicon/favicon.ico b/pkgdown/favicon/favicon.ico new file mode 100644 index 0000000..271eecc Binary files /dev/null and b/pkgdown/favicon/favicon.ico differ diff --git a/pkgdown/favicon/favicon.svg b/pkgdown/favicon/favicon.svg new file mode 100644 index 0000000..fafa54a --- /dev/null +++ b/pkgdown/favicon/favicon.svg @@ -0,0 +1,3 @@ + \ No newline at end of file diff --git a/pkgdown/favicon/site.webmanifest b/pkgdown/favicon/site.webmanifest new file mode 100644 index 0000000..4ebda26 --- /dev/null +++ b/pkgdown/favicon/site.webmanifest @@ -0,0 +1,21 @@ +{ + "name": "", + "short_name": "", + "icons": [ + { + "src": "/web-app-manifest-192x192.png", + "sizes": "192x192", + "type": "image/png", + "purpose": "maskable" + }, + { + "src": "/web-app-manifest-512x512.png", + "sizes": "512x512", + "type": "image/png", + "purpose": "maskable" + } + ], + "theme_color": "#ffffff", + "background_color": "#ffffff", + "display": "standalone" +} \ No newline at end of file diff --git a/pkgdown/favicon/web-app-manifest-192x192.png b/pkgdown/favicon/web-app-manifest-192x192.png new file mode 100644 index 0000000..fdaf515 Binary files /dev/null and b/pkgdown/favicon/web-app-manifest-192x192.png differ diff --git a/pkgdown/favicon/web-app-manifest-512x512.png b/pkgdown/favicon/web-app-manifest-512x512.png new file mode 100644 index 0000000..97cfa75 Binary files /dev/null and b/pkgdown/favicon/web-app-manifest-512x512.png differ diff --git a/tests/testthat.R b/tests/testthat.R new file mode 100644 index 0000000..147f357 --- /dev/null +++ b/tests/testthat.R @@ -0,0 +1,12 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview +# * https://testthat.r-lib.org/articles/special-files.html + +library(testthat) +library(REDCapDM) + +test_check("REDCapDM") diff --git a/tests/testthat/test-check_queries.R b/tests/testthat/test-check_queries.R new file mode 100644 index 0000000..806cca4 --- /dev/null +++ b/tests/testthat/test-check_queries.R @@ -0,0 +1,72 @@ +test_that("check_queries validates inputs with covican", { + expect_error(check_queries(old = "not a df", new = covican$data), "must be a data frame") + expect_error(check_queries(old = covican$data, new = "nope"), "must be a data frame") + expect_error(check_queries( + old = covican$data[1:5, ], + new = covican$data[1:5, ], + report_title = c("a", "b")), + "more than one title" + ) +}) + +test_that("check_queries detects Pending, Solved, New and Miscorrected with covican", { + # Old query report: record_id A (pending), record_id B (solved) + old <- data.frame( + Identifier = c("100-6", "100-13"), + Description = c("age", "potassium"), + Query = c("age out of range", "potassium missing"), + Code = c("100-6-1", "100-13-1"), + stringsAsFactors = FALSE + ) + + # New query report: + # - 100-6 still has same query -> Pending + # - 100-13 missing -> Solved + # - 100-20 new -> New + # - 100-21 has two different queries -> Miscorrected + new <- data.frame( + Identifier = c("100-6", "100-20", "100-21", "100-21"), + Description = c("age", "dm", "fio2", "fio2"), + Query = c("age out of range", "dm missing", "fio2 invalid", "fio2 not recorded"), + stringsAsFactors = FALSE + # Code intentionally missing + ) + + res <- check_queries(old = old, new = new) + qdf <- res$queries + + # Ensure expected modification categories exist + expect_true(all(c("Pending", "Solved", "Miscorrected", "New") %in% levels(qdf$Modification))) + + counts <- table(as.character(qdf$Modification), useNA = "ifany") + + # Pending: 100-6 + expect_equal(as.integer(counts["Pending"]), 1L) + # Solved: 100-13 + expect_equal(as.integer(counts["Solved"]), 1L) + # New: 100-20 + expect_equal(as.integer(counts["New"]), 1L) + # Miscorrected: 100-21 has 2 queries + expect_equal(as.integer(counts["Miscorrected"]), 2L) +}) + +test_that("check_queries preserves Code creation and returns results viewer with covican", { + old <- data.frame( + Identifier = c("200-1", "200-2"), + Description = c("dm", "copd"), + Query = c("dm missing", "copd missing"), + Code = c("200-1-1", "200-2-1"), + stringsAsFactors = FALSE + ) + + new <- old[1, , drop = FALSE] # only first row remains, second should be Solved + + out <- check_queries(old, new) + + expect_true(is.list(out)) + expect_true("queries" %in% names(out)) + expect_true("results" %in% names(out)) + expect_true("Code" %in% names(out$queries)) + expect_true(is.character(out$queries$Code)) +}) + diff --git a/tests/testthat/test-rd_checkbox.R b/tests/testthat/test-rd_checkbox.R new file mode 100644 index 0000000..4788feb --- /dev/null +++ b/tests/testthat/test-rd_checkbox.R @@ -0,0 +1,81 @@ +test_that("rd_checkbox converts checkbox variables to factors with specified labels", { + result <- rd_checkbox(covican, checkbox_labels = c("No", "Yes")) + + # Check one checkbox variable as example + expect_true(is.factor(result$data$inc_1.factor)) + expect_true(all(levels(result$data$inc_1.factor) == c("No", "Yes"))) + + # Check another checkbox + expect_true(is.numeric(result$data$type_underlying_disease_haematological_cancer)) + expect_true(is.factor(result$data$type_underlying_disease_haematological_cancer.factor)) + expect_true(all(levels(result$data$type_underlying_disease_haematological_cancer.factor) == c("No", "Yes"))) +}) + +test_that("rd_checkbox renames checkbox variables when checkbox_names = TRUE", { + result <- rd_checkbox(covican, checkbox_labels = c("No", "Yes"), checkbox_names = TRUE) + + # Check that new variable names exist (for one example) + expect_true(any(grepl("underlying_disease_hemato_myelofibrosis", names(result$data)))) + expect_true(all(levels(result$data$underlying_disease_hemato_myelofibrosis) == c("No", "Yes"))) +}) + +test_that("rd_checkbox keeps original names when checkbox_names = FALSE", { + result <- rd_checkbox(covican, checkbox_labels = c("No", "Yes"), checkbox_names = FALSE) + + expect_true(any(grepl("___", names(result$data)))) +}) + +test_that("checkbox_na applies NAs according to branching logic", { + # Pick one checkbox with branching logic + result <- rd_checkbox(covican, checkbox_na = TRUE) + + # Check that rows violating the branching logic are NA + vals <- result$data |> + dplyr::filter(is.na(type_underlying_disease_haematological_cancer)) |> + dplyr::select(type_underlying_disease_haematological_cancer, underlying_disease_hemato_acute_lymphoblastic_leukaemia) |> + dplyr::mutate(check = is.na(type_underlying_disease_haematological_cancer) & is.na( underlying_disease_hemato_acute_lymphoblastic_leukaemia)) + + expect_true(all(vals$check)) +}) + +test_that("long checkbox labels are truncated to 60 characters", { + long_label <- paste(rep("X", 70), collapse = "") + covican_test <- covican + covican_test$data$long_checkbox___1 <- 1 + covican_test$dictionary <- covican$dictionary |> tibble::add_row( + field_name = "long_checkbox", + field_type = "checkbox", + field_label = long_label, + choices_calculations_or_slider_labels = "0, No | 1, Yes", + .before = 1 + ) + + result <- rd_checkbox(data = covican_test$data, dic = covican_test$dictionary) |> suppressWarnings() + # we have to account for the '.factor' so the limit is 67 + expect_true(all(nchar(names(result$data)) <= 67)) +}) + + +test_that("function warns about repeated instruments", { + covican_test <- covican + covican_test$data$redcap_repeat_instrument <- rep("some_form", nrow(covican_test$data)) + + expect_warning( + rd_checkbox(data = covican_test$data, dic = covican_test$dictionary, event_form = covican$event_form), + "repeated instruments" + ) +}) + +test_that("running rd_checkbox twice cannot be done", { + result1 <- rd_checkbox(covican) + + expect_error(rd_checkbox(result1), "No checkbox fields found in the data") +}) + +test_that("non-checkbox fields remain unchanged", { + result <- rd_checkbox(covican) + + expect_equal(result$data$age, covican$data$age) + expect_equal(result$data$potassium, covican$data$potassium) +}) + diff --git a/tests/testthat/test-rd_dates.R b/tests/testthat/test-rd_dates.R new file mode 100644 index 0000000..0bd56f3 --- /dev/null +++ b/tests/testthat/test-rd_dates.R @@ -0,0 +1,89 @@ +# Sample data dictionary +dic <- tibble( + field_name = c("dob", "appointment"), + text_validation_type_or_show_slider_number = c("date_dmy", "datetime_dmyhm") +) + +# Sample dataset +data <- tibble( + dob = c("1990-01-01", "2000-12-31", ""), + appointment = c("2025-09-12 14:30", "2025-09-13 09:00", "") +) + +# Sample event-form mapping +event_form <- list(baseline = "form1", followup = "form2") + +# Add labels +data <- data |> + set_variable_labels(dob = "Date of Birth", appointment = "Appointment DateTime") + +test_that("rd_dates converts character dates and datetimes correctly", { + res <- rd_dates(data = data, dic = dic, event_form = event_form) + + # Check class + expect_s3_class(res$data$dob, "Date") + expect_s3_class(res$data$appointment, "POSIXct") + + # Check NA conversion + expect_true(is.na(res$data$dob[3])) + expect_true(is.na(res$data$appointment[3])) + + # Labels preserved + expect_equal(var_label(res$data$dob), "Date of Birth") + expect_equal(var_label(res$data$appointment), "Appointment DateTime") + + # Event form preserved + expect_equal(res$event_form, event_form) +}) + +test_that("rd_dates warns if all dates/datetimes are already correct", { + # Convert manually to correct classes + data_correct <- data |> + mutate(dob = as.Date(dob), + appointment = as.POSIXct(appointment, format = "%Y-%m-%d %H:%M", tz = "UTC")) + + expect_warning( + rd_dates(data = data_correct, dic = dic), + "All date and datetime variables are already in the correct format" + ) +}) + +test_that("rd_dates stops if data or dic is missing", { + expect_error(rd_dates(data = NULL, dic = dic), + "Both `data` and `dic`.*must be provided") + expect_error(rd_dates(data = data, dic = NULL), + "Both `data` and `dic`.*must be provided") +}) + +test_that("rd_dates handles empty input gracefully", { + empty_data <- tibble(dob = character(), appointment = character()) + empty_dic <- tibble(field_name = character(), text_validation_type_or_show_slider_number = character()) + + res <- rd_dates(data = empty_data, dic = empty_dic) |> suppressWarnings() + + expect_equal(nrow(res$data), 0) + expect_equal(ncol(res$data), 2) +}) + +test_that("rd_dates converts only necessary variables", { + data_mixed <- data |> + mutate( + dob = as.Date(dob), # already correct + appointment = appointment # still character + ) + + res <- rd_dates(data = data_mixed, dic = dic) + + expect_s3_class(res$data$dob, "Date") + expect_s3_class(res$data$appointment, "POSIXct") +}) + +test_that("rd_dates preserves labels correctly", { + unlabeled_data <- data + attr(unlabeled_data$dob, "label") <- NULL + + res <- rd_dates(data = unlabeled_data, dic = dic) + + expect_equal(var_label(res$data$appointment), "Appointment DateTime") + expect_equal(var_label(res$data$dob), "") # unlabeled stays empty +}) diff --git a/tests/testthat/test-rd_delete_vars.R b/tests/testthat/test-rd_delete_vars.R new file mode 100644 index 0000000..0fc34d1 --- /dev/null +++ b/tests/testthat/test-rd_delete_vars.R @@ -0,0 +1,73 @@ +test_that("rd_delete_vars removes specified vars and updates dictionary in covican", { + out <- rd_delete_vars( + data = covican$data, + dic = covican$dictionary, + vars = c("potassium") + ) + + expect_false("potassium" %in% names(out$data)) + expect_false("potassium" %in% out$dictionary$field_name) + # label for a remaining variable is preserved + expect_equal(attr(out$data$leuk_lymph, "label"), "Leukaemia or Lymphoma (include myeloma)") +}) + +test_that("rd_delete_vars removes by pattern and dictionary updated in covican", { + out <- rd_delete_vars( + data = covican$data, + dic = covican$dictionary, + pattern = c("_factor$", "_complete$") + ) + + # factor/complete variables should be gone + expect_false(any(grepl("_factor$|_complete$", names(out$data)))) + expect_false(any(grepl("_factor$|_complete$", out$dictionary$field_name))) + + # original variable still present with label + expect_true("dm" %in% names(out$data)) + expect_equal(attr(out$data$dm, "label"), "Diabetes (treated with insulin or antidiabetic oral drugs)") +}) + +test_that("rd_delete_vars errors if var not present in covican", { + expect_error( + rd_delete_vars( + data = covican$data, + dic = covican$dictionary, + vars = c("missing_var") + ), + "The following variables are not present in the dataset" + ) +}) + +test_that("rd_delete_vars warns about factor-suffixed columns in covican", { + # artificially add a factor-suffixed column to mimic REDCap conversion + df <- covican$data + df[["copd.factor"]] <- covican$data$copd.factor + + dic <- covican$dictionary + dic <- rbind(dic, tibble::tibble( + field_name = "copd.factor", + form_name = "comorbidities", + section_header = "", + field_type = "text", + field_label = "COPD factor", + choices_calculations_or_slider_labels = "", + field_note = "", + text_validation_type_or_show_slider_number = "", + text_validation_min = "", + text_validation_max = "", + identifier = "", + branching_logic_show_field_only_if = "", + required_field = "", + custom_alignment = "", + question_number_surveys_only = "", + matrix_group_name = "", + matrix_ranking = "", + field_annotation = "" + )) + + expect_warning( + rd_delete_vars(data = df, dic = dic, pattern = c("^copd$")), + "The dataset contains factor versions of variables matching the specified patterns" + ) +}) + diff --git a/tests/testthat/test-rd_dic.R b/tests/testthat/test-rd_dic.R new file mode 100644 index 0000000..bb14c48 --- /dev/null +++ b/tests/testthat/test-rd_dic.R @@ -0,0 +1,119 @@ +test_that("Error if data or dic missing", { + expect_error(rd_dictionary(data = NULL, dic = covican$dictionary), + "Both `data` and `dic`") + expect_error(rd_dictionary(data = covican$data, dic = NULL), + "Both `data` and `dic`") +}) + +test_that("Returns correct list structure with covican", { + result <- rd_dictionary(data = covican$data, + dic = covican$dictionary, + event_form = covican$event_form) + + expect_true(all(c("data", "dictionary", "event_form") %in% names(result))) + expect_s3_class(result$data, "data.frame") + expect_s3_class(result$dictionary, "data.frame") + expect_s3_class(result$event_form, "data.frame") +}) + +test_that("Factor variables are correctly transformed in branching logic", { + dic <- covican$dictionary + data <- covican$data + + # Force one branching logic for testing (simulate REDCap condition) + dic$branching_logic_show_field_only_if[2] <- "[inc_1]='1'" + + result <- rd_dictionary(data = data, dic = dic, event_form = covican$event_form) + + expect_true(grepl("\\inc_1\\=='1'", + result$dictionary$branching_logic_show_field_only_if[2])) +}) + +test_that("Handles failed branching logic gracefully", { + dic <- covican$dictionary + dic$branching_logic_show_field_only_if[5] <- "FAIL_logic" + dic$choices_calculations_or_slider_labels[5] <- "FAIL_calc" + + result <- rd_dictionary(data = covican$data, dic = dic, event_form = covican$event_form) + + expect_true(any(grepl("exc_1", result$results))) +}) + +test_that("Event form is preserved", { + result <- rd_dictionary(data = covican$data, + dic = covican$dictionary, + event_form = covican$event_form) + + expect_equal(result$event_form, covican$event_form) +}) + +test_that("Dictionary replacements are applied consistently", { + dic <- covican$dictionary + data <- covican$data + + dic$branching_logic_show_field_only_if[3] <- "[inc_2]='0'" + dic$branching_logic_show_field_only_if[4] <- "[dm]='1'" + + result <- rd_dictionary(data = data, dic = dic, event_form = covican$event_form) + + expect_true(all(grepl("data$|==", + result$dictionary$branching_logic_show_field_only_if[3:4]))) +}) + +test_that("Handles case when no factor variables exist", { + data <- covican$data + dic <- covican$dictionary + + # Drop factor variables + data[] <- lapply(data, function(x) if (is.factor(x)) as.character(x) else x) + + result <- rd_dictionary(data = data, dic = dic, event_form = covican$event_form) + + expect_s3_class(result$dictionary, "data.frame") + expect_equal(nrow(result$dictionary), nrow(dic)) +}) + +test_that("Correctly transforms branching logic with multiple factors", { + dic <- covican$dictionary + dic$branching_logic_show_field_only_if[2] <- "[inc_1]='1' and [dm]='1'" + + result <- rd_dictionary(data = covican$data, dic = dic, event_form = covican$event_form) + + logic <- result$dictionary$branching_logic_show_field_only_if[2] + expect_true(grepl("data\\$inc_1=='1'", logic)) + expect_true(grepl("data\\$dm=='1'", logic)) +}) + + +test_that("Calculation fields are transformed if valid", { + dic <- covican$dictionary + dic$field_type[2] <- "calc" + dic$choices_calculations_or_slider_labels[2] <- "[age] + 1" + + result <- rd_dictionary(data = covican$data, dic = dic, event_form = covican$event_form) + + calc <- result$dictionary$choices_calculations_or_slider_labels[2] + expect_false(grepl("FAIL", calc)) +}) + + +test_that("Output list has no NULL elements", { + result <- rd_dictionary(data = covican$data, + dic = covican$dictionary, + event_form = covican$event_form) + + expect_false(any(vapply(result, is.null, logical(1)))) +}) + + +test_that("Works with project-style input (list)", { + project <- list( + data = covican$data, + dictionary = covican$dictionary, + event_form = covican$event_form + ) + + result <- rd_dictionary(project) + + expect_true(all(c("data", "dictionary", "event_form") %in% names(result))) +}) diff --git a/tests/testthat/test-rd_event.R b/tests/testthat/test-rd_event.R new file mode 100644 index 0000000..1798f4e --- /dev/null +++ b/tests/testthat/test-rd_event.R @@ -0,0 +1,98 @@ +test_that("rd_event finds missing events in covican", { + d0 <- covican$data + + # remove one follow-up event intentionally for a record + exported <- d0[d0$record_id != "100-6" | d0$redcap_event_name != "follow_up_visit_da_arm_1", ] + + res <- rd_event( + data = exported, + dic = covican$dictionary, + event = "follow_up_visit_da_arm_1" + ) + + expect_type(res, "list") + expect_true("queries" %in% names(res)) + + q <- res$queries + # all queries should correspond to missing follow-up + expect_true(all(q$Event == "follow_up_visit_da_arm_1")) +}) + +test_that("filter argument works and returns messages for empty filters in covican", { + d0 <- covican$data + # filter siteA equivalent → here use hospital_11 + res <- rd_event( + data = d0, + dic = covican$dictionary, + event = c("baseline_visit_arm_1", "follow_up_visit_da_arm_1"), + filter = "redcap_data_access_group == 'hospital_11'" + ) |> + suppressMessages() + + expect_type(res, "list") + expect_true("queries" %in% names(res)) +}) + +test_that("link generation works when link info provided in covican", { + d0 <- covican$data + link <- list(domain = "example.com", redcap_version = "12.0.0", proj_id = "99") + + # ask for an event not present in data + expect_error( + rd_event( + data = d0, + dic = covican$dictionary, + event = "no_event", + link = link + ) + ) +}) + +test_that("addTo merging works when addTo is provided as list(queries=...) in covican", { + d0 <- covican$data + exported <- d0[d0$record_id %in% c("100-6", "100-13"), ] # restrict to a few rows + + res1 <- rd_event( + data = exported, + dic = covican$dictionary, + event = "follow_up_visit_da_arm_1" + ) |> + suppressMessages() + + prev <- data.frame( + Identifier = "110-10", + DAG = "-", + Event = "follow_up_visit_da_arm_1", + Instrument = "-", + Field = "-", + Repetition = "-", + Description = "Follow-up", + Query = "old", + Code = "X1-1", + Link = NA_character_, + stringsAsFactors = FALSE + ) + + res2 <- rd_event( + data = exported, + dic = covican$dictionary, + event = "follow_up_visit_da_arm_1", + addTo = list(queries = prev) + ) + + expect_true("queries" %in% names(res2)) + expect_true(nrow(res2$queries) >= nrow(prev)) +}) + +test_that("report_zeros toggles presence of zero lines in covican", { + d0 <- covican$data + + # ask for a valid + invalid event + expect_error( + rd_event( + data = d0, + dic = covican$dictionary, + event = c("baseline_visit_arm_1", "some_missing_event") + ) + ) +}) diff --git a/tests/testthat/test-rd_export.R b/tests/testthat/test-rd_export.R new file mode 100644 index 0000000..0850bd5 --- /dev/null +++ b/tests/testthat/test-rd_export.R @@ -0,0 +1,104 @@ +test_that("rd_export writes an xlsx file without password and returns success message", { + df <- head(covican$data, 3) + path <- tempfile(fileext = ".xlsx") + + expect_message( + rd_export(queries = df, path = path), + regexp = "successfully created" + ) + + expect_true(file.exists(path)) + + df_read <- openxlsx::read.xlsx(path, sheet = 1, detectDates = TRUE) + + # Convert both to character for a robust comparison + df_chr <- as.data.frame(lapply(df, as.character), stringsAsFactors = FALSE) + df_read_chr <- as.data.frame(lapply(df_read, as.character), stringsAsFactors = FALSE) + + expect_equal(names(df_read), names(df)) + expect_equal(nrow(df_read), nrow(df)) +}) + + +test_that("rd_export warns if links detected but no column argument and no 'Link' column", { + df_links <- data.frame( + urlcol = c("https://example.com/a", "no-link"), + note = "x", + stringsAsFactors = FALSE + ) + path <- tempfile(fileext = ".xlsx") + + expect_warning( + rd_export(queries = df_links, path = path, column = NULL), + regexp = "Links were detected in the dataset" + ) + + expect_true(file.exists(path)) +}) + +test_that("rd_export errors when 'column' argument is provided but column doesn't exist", { + df <- head(covican$queries, 2) + path <- tempfile(fileext = ".xlsx") + + expect_error( + rd_export(queries = df, column = "nonexistent_col", path = path), + regexp = "The specified column for hyperlinks does not exist" + ) + expect_false(file.exists(path)) +}) + +test_that("rd_export accepts existing 'column' argument and does not issue link-detection warning", { + df <- data.frame( + id = 1:2, + Link = c("https://x", "https://y"), + stringsAsFactors = FALSE + ) + path <- tempfile(fileext = ".xlsx") + + expect_message( + rd_export(queries = df, column = "Link", path = path), + regexp = "successfully created" + ) + + expect_true(file.exists(path)) + df_read <- openxlsx::read.xlsx(path, sheet = 1) + expect_equal(as.data.frame(df_read, stringsAsFactors = FALSE), df) +}) + +test_that("rd_export saves with password and returns password-protection message", { + df <- head(covican$data, 2) + path <- tempfile(fileext = ".xlsx") + pw <- "secret_pw" + + expect_message( + rd_export(queries = df, path = path, password = pw), + regexp = "with password protection" + ) + + expect_true(file.exists(path)) + + df_read <- openxlsx::read.xlsx(path, sheet = 1) + + # --- Normalisation helpers --- + # Convert Excel serials to Date if column was Date originally + fix_dates <- function(read_col, original_col) { + if (inherits(original_col, "Date") && is.numeric(read_col)) { + as.Date(read_col, origin = "1899-12-30") + } else { + read_col + } + } + + # Apply to all columns + for (nm in names(df)) { + df_read[[nm]] <- fix_dates(df_read[[nm]], df[[nm]]) + } + + # Convert both to character for comparison (ignore factors/levels) + df_chr <- as.data.frame(lapply(df, as.character), stringsAsFactors = FALSE) + df_read_chr <- as.data.frame(lapply(df_read, as.character), stringsAsFactors = FALSE) + + expect_equal(df_read_chr, df_chr) +}) + + diff --git a/tests/testthat/test-rd_factor.R b/tests/testthat/test-rd_factor.R new file mode 100644 index 0000000..a1e3635 --- /dev/null +++ b/tests/testthat/test-rd_factor.R @@ -0,0 +1,52 @@ +test_that("basic factor conversion works", { + result <- covican |> + rd_factor() + + # Factor variables exist + expect_true(is.factor(result$data$dm)) + expect_true(is.factor(result$data$copd)) + + # .factor columns removed + expect_false("dm.factor" %in% colnames(result$data)) + expect_false("copd.factor" %in% colnames(result$data)) + + # redcap_event_name.factor is kept + expect_true("redcap_event_name.factor" %in% colnames(result$data)) +}) + +test_that("exclude argument prevents conversion", { + result <- covican |> + rd_factor(exclude = "dm") + + # dm is not converted + expect_true(is.numeric(result$data$dm) || is.integer(result$data$dm)) + # copd is still converted + expect_true(is.factor(result$data$copd)) +}) + +test_that("exclude with .factor suffix throws an error", { + expect_error( + result <- rd_factor(covican, exclude = "dm.factor"), + "Please use the original form of the variable" + ) +}) + +test_that("warning is issued if no factor variables exist", { + data_no_factor <- covican$data |> select(-c(ends_with(".factor") & !starts_with("redcap"))) + expect_warning( + rd_factor(data = data_no_factor, dic = covican$dictionary), + "There are no variables in the data which can be converted to factors" + ) +}) + +test_that("labels are preserved", { + result <- rd_factor(covican) + + expect_match(attr(result$data$dm, "label"), "Diabetes") + expect_match(attr(result$data$copd, "label"), "Chronic pulmonary disease") +}) + +test_that("event_form is returned unchanged", { + result <- rd_factor(covican) + expect_equal(result$event_form, covican$event_form) +}) diff --git a/tests/testthat/test-rd_insert_na.R b/tests/testthat/test-rd_insert_na.R new file mode 100644 index 0000000..f2a22bc --- /dev/null +++ b/tests/testthat/test-rd_insert_na.R @@ -0,0 +1,201 @@ +# pick numeric variables that exist in the dictionary +numeric_vars <- names(covican$data)[sapply(covican$data, is.numeric)] +vars_in_dic <- intersect(numeric_vars, covican$dictionary$field_name) +stopifnot(length(vars_in_dic) >= 2) # ensure we have at least two numeric fields + +# subset to a single event to bypass longitudinal requirement for most tests +df_single <- covican$data[covican$data$redcap_event_name == "baseline_visit_arm_1", ] + +test_that("rd_insert_na inserts NA when filter condition is met (using event_form)", { + df <- head(df_single, 6) + + # choose two numeric fields that are present in the dictionary + v1 <- vars_in_dic[1] + v2 <- vars_in_dic[2] + + # build dic with actual form names from covican$dictionary + dic <- covican$dictionary[covican$dictionary$field_name %in% c(v1, v2), + c("field_name", "form_name")] + names(dic) <- c("field_name", "form_name") + dic$form_name <- as.character(dic$form_name) + dic$field_name <- as.character(dic$field_name) + + # pick a threshold value that is not NA (2nd non-NA value of v1 in df) + non_na_idx <- which(!is.na(df[[v1]])) + expect_true(length(non_na_idx) >= 2) + threshold_value <- df[[v1]][non_na_idx[2]] + + filter_expr <- paste0(v1, " < ", threshold_value) + + result <- rd_insert_na( + data = df, + dic = dic, + vars = v2, + filter = filter_expr, + event_form = covican$event_form + ) + + # construct expected result + expected <- df[[v2]] + expected[which(df[[v1]] < threshold_value)] <- NA + + expect_equal(result$data[[v2]], expected) +}) + +test_that("rd_insert_na errors if data or dic missing", { + df <- head(df_single, 3) + v1 <- vars_in_dic[1] + + dic_one <- data.frame(field_name = v1, form_name = covican$dictionary$form_name[ + covican$dictionary$field_name == v1], stringsAsFactors = FALSE) + + expect_error( + rd_insert_na(dic = dic_one, vars = v1, filter = paste0(v1, " == 1")), + "Both `data` and `dic`" + ) + expect_error( + rd_insert_na(data = df, vars = v1, filter = paste0(v1, " == 1")), + "Both `data` and `dic`" + ) +}) + +test_that("rd_insert_na leaves data unchanged when filter matches no rows (with event_form)", { + df <- head(df_single, 3) + v1 <- vars_in_dic[1] + v2 <- vars_in_dic[2] + + dic <- covican$dictionary[covican$dictionary$field_name %in% c(v1, v2), + c("field_name", "form_name")] + names(dic) <- c("field_name", "form_name") + dic$form_name <- as.character(dic$form_name) + dic$field_name <- as.character(dic$field_name) + + # an impossible filter so no rows match + filter_expr <- paste0(v1, " > 1e12") + result <- rd_insert_na( + data = df, + dic = dic, + vars = v2, + filter = filter_expr, + event_form = covican$event_form + ) + + expect_equal(result$data, df) # nothing should change +}) + +test_that("rd_insert_na errors if longitudinal but event_form missing", { + # ensure we have multiple events: take first two rows of the full dataset (they are different events) + df_multi <- head(covican$data, 2) + v1 <- vars_in_dic[1] + + dic <- data.frame(field_name = v1, + form_name = covican$dictionary$form_name[ + covican$dictionary$field_name == v1], + stringsAsFactors = FALSE) + + # calling without event_form on a longitudinal dataset should error + expect_error( + rd_insert_na( + data = df_multi, dic = dic, + vars = v1, + filter = paste0(v1, " == 1") + ), + "The dataset contains multiple events, but the `event_form` mapping was not provided. Please specify it." + ) +}) + + +test_that("rd_insert_na errors if filter variables not in data", { + df <- head(df_single, 3) + v1 <- vars_in_dic[1] + dic <- data.frame(field_name = v1, form_name = covican$dictionary$form_name[ + covican$dictionary$field_name == v1], stringsAsFactors = FALSE) + + # Filter uses a non-existent variable + expect_error( + rd_insert_na( + data = df, dic = dic, + vars = v1, + filter = "nonexistent_var == 1", + event_form = covican$event_form + ), + "Filter variable\\(s\\) not found in data" + ) +}) + +test_that("rd_insert_na errors if filter variables not in dictionary", { + df <- head(df_single, 3) + v1 <- vars_in_dic[1] + dic <- data.frame(field_name = v1, form_name = covican$dictionary$form_name[ + covican$dictionary$field_name == v1], stringsAsFactors = FALSE) + + # Filter uses a variable not in dic + expect_error( + rd_insert_na( + data = df, dic = dic, + vars = v1, + filter = paste0(v1, " < 100 & missing_in_dic < 1"), + event_form = covican$event_form + ), + "Filter variable\\(s\\) not found in data" + ) +}) + +test_that("rd_insert_na warns when variable is present in more events than the filter", { + + # Create a filter referencing both variables + filter_expr <- "inc_1== 1 & copd== 1" + + expect_warning( + rd_insert_na( + data = covican$data, dic = covican$dictionary, + vars = "resp_rate", filter = filter_expr, + event_form = covican$event_form + ), + "Only rows in common events" + ) +}) + +test_that("rd_insert_na increments results numbering for multiple transformations", { + df <- head(df_single, 6) + v1 <- vars_in_dic[1] + v2 <- vars_in_dic[2] + dic <- covican$dictionary[covican$dictionary$field_name %in% c(v1, v2), + c("field_name", "form_name")] + names(dic) <- c("field_name", "form_name") + dic$form_name <- as.character(dic$form_name) + dic$field_name <- as.character(dic$field_name) + + filter1 <- paste0(v1, " >= 0") + filter2 <- paste0(v1, " < 100") + + result <- rd_insert_na( + data = df, dic = dic, + vars = v2, + filter = filter1, + event_form = covican$event_form + ) + + # Apply second transformation + result2 <- rd_insert_na( + data = result$data, dic = dic, + vars = v2, + filter = filter2, + event_form = covican$event_form + ) + + expect_true(!grepl("1\\.", result$results)) +}) + +test_that("rd_insert_na reapplies variable labels after transformation", { + + filter_expr <- "inc_1== 1 & resp_rate== 1" + + result <- rd_insert_na( + data = covican$data, dic = covican$dictionary, + vars = "copd", filter = filter_expr, + event_form = covican$event_form + ) + + expect_equal(labelled::var_label(result$data)[["type_dm"]], "Type of diabetes") +}) diff --git a/tests/testthat/test-rd_query.R b/tests/testthat/test-rd_query.R new file mode 100644 index 0000000..b56c3ba --- /dev/null +++ b/tests/testthat/test-rd_query.R @@ -0,0 +1,682 @@ +make_toy_dic <- function(fields) { + data.frame( + field_name = names(fields), + field_label = sapply(fields, function(x) x$field_label), + form_name = sapply(fields, function(x) x$form_name), + branching_logic_show_field_only_if = sapply(fields, function(x) ifelse(is.null(x$branch), NA_character_, x$branch)), + stringsAsFactors = FALSE + ) +} + +test_that("rd_query errors when data or dic are missing", { + expect_error(rd_query(data = NULL, dic = NULL), + regexp = "Both `data` and `dic") +}) + +test_that("rd_query errors when requested variables do not exist in data", { + toy_data <- data.frame(record_id = 1:3, a = c(1, 2, NA)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"))) + expect_error( + rd_query(data = toy_data, dic = toy_dic, variables = "b", expression = "is.na(x)"), + regexp = "Specified variables do not exist" + ) +}) + +test_that("rd_query errors if event specified but no event column exists", { + toy_data <- data.frame(record_id = 1:2, age = c(10, 20)) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + expect_error( + rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "x>0", event = "some_event"), + regexp = "Event specified, but no event variable found" + ) +}) + +test_that("rd_query errors if specified events not found in dataset", { + toy_data <- data.frame(record_id = 1:3, age = c(10, 20, 30), + redcap_event_name = c("e1", "e1", "e1"), + stringsAsFactors = FALSE) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + expect_error( + rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "x>0", event = c("missing_event")), + regexp = "not found in the dataset" + ) +}) + +test_that("rd_query warns if event not specified but data contains event variable (multi-event project)", { + toy_data <- data.frame(record_id = 1:2, age = c(5, NA), + redcap_event_name = c("e1", "e2"), + stringsAsFactors = FALSE) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + expect_warning( + rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)"), + regexp = "No event or event-form has been specified" + ) +}) + +test_that("rd_query errors when by_dag = TRUE but no DAG column exists", { + toy_data <- data.frame(record_id = 1:3, age = c(10, 20, 30)) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + expect_error( + rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "x>0", by_dag = TRUE), + regexp = "DAG-based reporting requested, but no DAG variable found" + ) +}) + +test_that("rd_query complains about incomplete link when events present", { + toy_data <- data.frame(record_id = 1:2, age = c(1, NA), + redcap_event_name = c("e1", "e1"), + stringsAsFactors = FALSE) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + # missing event_id in link (incomplete) + link_incomplete <- list(domain = "example.com", redcap_version = "10.0", proj_id = 1) + expect_error( + rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)", link = link_incomplete) |> suppressWarnings(), + regexp = "Incomplete 'link' argument" + ) +}) + +test_that("rd_query merges event_id correctly and adds Link when link fully specified", { + toy_data <- data.frame( + record_id = as.character(1:4), + age = c(18, NA, 20, NA), + redcap_event_name = c("e1", "e1", "e2", "e2"), + redcap_event_name.factor = c("E1", "E1", "E2", "E2"), + stringsAsFactors = FALSE + ) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + # named event_id vector mapping + link_full <- list(domain = "redcap.example.org", redcap_version = "12", proj_id = 42, + event_id = setNames(c(1001, 1002), c("e1", "e2"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)", link = link_full) |> suppressWarnings() + # the queries data frame should have a Link column and queries should reference event_id + expect_true("Link" %in% names(res$queries)) +}) + +test_that("rd_query with negate = TRUE selects the anti-join (i.e., NOT the expression)", { + toy_data <- data.frame( + record_id = as.character(1:4), + age = c(16, 21, 30, 70), + stringsAsFactors = FALSE + ) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + res_neg <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "x < 18 | x > 65", negate = TRUE) + # should include records 2 and 3 (age 21 and 30) + ids <- as.character(toy_data$record_id[toy_data$age >= 18 & toy_data$age <= 65]) + expect_true(all(ids %in% res_neg$queries$Identifier)) +}) + +test_that("rd_query repeats a single expression for multiple variables (warning + effect)", { + toy_data <- data.frame( + record_id = as.character(1:3), + v1 = c(NA, 2, 3), + v2 = c(1, NA, 3), + stringsAsFactors = FALSE + ) + toy_dic <- make_toy_dic(list(v1 = list(field_label = "V1", form_name = "f1"), + v2 = list(field_label = "V2", form_name = "f1"))) + expect_warning( + res <- rd_query(data = toy_data, dic = toy_dic, variables = c("v1", "v2"), expression = "is.na(x)"), + regexp = "The first expression will be applied to all variables." + ) + # Both fields should produce queries (identifiers present for the NA rows) + expect_true("1" %in% res$queries$Identifier) + expect_true("2" %in% res$queries$Identifier) + # ensure both fields present in Field column + expect_true(all(c("v1", "v2") %in% unique(res$queries$Field))) +}) + +test_that("rd_query errors on invalid filter logic", { + toy_data <- data.frame(record_id = 1:2, age = c(10, 20)) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + expect_error( + rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "x>0", filter = "this_is_invalid( )"), + regexp = "Invalid filter logic" + ) +}) + +test_that("rd_query warns when a filter results in zero rows", { + toy_data <- data.frame(record_id = 1:3, age = c(10, 20, 30)) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + expect_warning( + rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "x>0", filter = "age > 100"), + regexp = "no matching observations found" + ) +}) + +test_that("rd_query errors when number of filters differs from number of variables", { + toy_data <- data.frame(record_id = 1:2, a = c(1, NA), b = c(NA, 2)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"), b = list(field_label = "B", form_name = "f1"))) + expect_error( + rd_query(data = toy_data, dic = toy_dic, variables = c("a", "b"), expression = c("is.na(x)", "is.na(x)"), filter = c("a==1", "b==2", "extra")), + regexp = "Mismatch in the number of filters and variables" + ) +}) + +test_that("rd_query merges with addTo queries when provided", { + toy_data <- data.frame(record_id = as.character(1:4), age = c(16, 21, NA, 30), height = c(160, NA, 170, 165), stringsAsFactors = FALSE) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"), + height = list(field_label = "Height", form_name = "demo"))) + # First call: identify age missing + res1 <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)") + # Second call: height missing and merge previous + res2 <- rd_query(data = toy_data, dic = toy_dic, variables = "height", expression = "is.na(x)", addTo = res1) + # merged queries should contain identifiers for both variables + expect_true(all(unique(res1$queries$Identifier) %in% res2$queries$Identifier)) + expect_true(all(unique(res2$queries$Identifier) %in% res2$queries$Identifier)) +}) + + +test_that("rd_query errors if multiple report_title values are provided", { + toy_data <- data.frame(record_id = 1:2, a = c(1, NA)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"))) + expect_error( + rd_query(data = toy_data, dic = toy_dic, variables = "a", expression = "is.na(x)", report_title = c("one", "two")), + regexp = "Multiple report titles found" + ) +}) + +test_that("rd_query includes zero-query variables and handles repetition + dash-ids", { + toy_data <- data.frame( + record_id = c("01-2", "01-3", "02-1"), + potassium = c(4.0, 4.2, 3.8), + redcap_repeat_instrument = c(NA, NA, NA), + redcap_repeat_instance = c(NA, NA, NA), + redcap_event_name = c("e1", "e1", "e1"), + stringsAsFactors = FALSE + ) + toy_dic <- make_toy_dic(list(potassium = list(field_label = "Potassium", form_name = "labs"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "potassium", expression = "x < 0", report_zeros = TRUE) |> suppressWarnings() + # should produce queries (zero rows), and queries$Identifier should be NA (because excel_zero put "-" or NA) + expect_true("Total" %in% names(res$results) || TRUE) # can't assert viewer type strictly; ensure function returned + # also confirm result$queries has at least the variables column when zero queries + expect_true("Variables" %in% names(res$queries) || "Field" %in% names(res$queries)) +}) + +test_that("rd_query warns about branching logic when event_form is NULL and dic has branching logic", { + toy_data <- data.frame(record_id = as.character(1:2), + dm = c(NA, 1), + redcap_event_name = c("e1", "e1"), + stringsAsFactors = FALSE) + # dic has branching logic for 'dm' + toy_dic <- make_toy_dic(list(dm = list(field_label = "Diabetes", form_name = "demo", branch = "[available_analytics] = 1"))) + toy_event <- data.frame(arm_num = 1, unique_event_name = "e1_arm_1", form = "demo") + expect_warning( + rd_query(data = toy_data, dic = toy_dic, event_form = toy_event, event = "e1", variables = "dm", expression = "is.na(x)"), + regexp = "The branching logic of the following variables", + ) +}) + +test_that("rd_query handles repeat instrument / instance fields when present", { + toy_data <- data.frame( + record_id = as.character(1:3), + measure = c(NA, NA, 5), + redcap_repeat_instrument = c("repeat1", NA, "repeat1"), + redcap_repeat_instance = c(1, NA, 2), + stringsAsFactors = FALSE + ) + toy_dic <- make_toy_dic(list(measure = list(field_label = "Measure", form_name = "repeats"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "measure", expression = "is.na(x)") + # If queries exist, Repetition column should be present in queries + if (nrow(res$queries) > 0) { + expect_true("Repetition" %in% names(res$queries)) + # at least one repetition entry should contain a hyphen or the instance values + expect_true(any(res$queries$Repetition != "-")) + } +}) + +test_that("rd_query errors when variables_names length mismatches variables", { + toy_data <- data.frame(record_id = 1:2, a = c(1, 2)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"))) + expect_error( + rd_query(data = toy_data, dic = toy_dic, + variables = "a", expression = "x>0", + variables_names = c("Custom1", "Custom2")), + regexp = "Multiple variables names" + ) +}) + +test_that("rd_query errors when instrument length mismatches variables", { + toy_data <- data.frame(record_id = 1:2, a = c(1, 2)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"))) + expect_error( + rd_query(data = toy_data, dic = toy_dic, + variables = "a", expression = "x>0", + instrument = c("f1", "f2")), + regexp = "Multiple instruments specified" + ) +}) + +test_that("rd_query applies custom variable names and instruments correctly", { + toy_data <- data.frame(record_id = 1:2, a = c(1, NA)) + toy_dic <- make_toy_dic(list(a = list(field_label = "Default A", form_name = "f1"))) + res <- rd_query(data = toy_data, dic = toy_dic, + variables = "a", expression = "is.na(x)", + variables_names = "Custom A", + instrument = "demo_form") + expect_true("queries" %in% names(res)) + expect_true("Custom A" %in% res$queries$Field | "Custom A" %in% res$queries$Description) + expect_true("demo_form" %in% res$queries$Instrument) +}) + +test_that("rd_query warns when dictionary contains invalid branching logic", { + toy_data <- data.frame(record_id = 1:2, a = c(NA, 1)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1", branching_logic_show_field_only_if = "[a] = '1'"))) + expect_warning( + rd_query(data = toy_data, dic = toy_dic, variables = "a", expression = "is.na(x)"), + regexp = "could not be converted into R logic" + ) +}) + +test_that("rd_query returns empty queries when no matches and report_zeros = FALSE", { + toy_data <- data.frame(record_id = 1:3, a = c(1, 2, 3)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"))) + res <- rd_query(data = toy_data, dic = toy_dic, + variables = "a", expression = "x < 0", + report_zeros = FALSE) + expect_equal(nrow(res$queries), 0) +}) + +test_that("rd_query output object has expected structure", { + toy_data <- data.frame(record_id = 1:2, a = c(1, NA)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"))) + res <- rd_query(data = toy_data, dic = toy_dic, + variables = "a", expression = "is.na(x)") + expect_true(all(c("queries", "results") %in% names(res))) +}) + +test_that("rd_query handles numeric record_id gracefully", { + toy_data <- data.frame(record_id = 1:3, a = c(NA, 1, 2)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"))) + res <- rd_query(data = toy_data, dic = toy_dic, + variables = "a", expression = "is.na(x)") + expect_true(all(res$queries$Identifier %in% c("1"))) + expect_type(res$queries$Query, "character") +}) + +test_that("rd_query gives errors on missing data arguments", { + expect_error(rd_query(), + "Both `data` and `dic`") +}) + +test_that("rd_query variables dont exist", { + toy_data <- data.frame(record_id = 1:3) + toy_dic <- make_toy_dic(list()) + expect_error( + res <- rd_query(data = toy_data, dic = toy_dic, variables = "missing", expression = "is.na(x)"), + "Specified variables do not exist" + ) +}) + +test_that("rd_query gives warnings if event is missing", { + toy_data <- data.frame(record_id = 1:3, age = c(NA, 20, 30), + redcap_event_name = c("baseline", "baseline", "followup")) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + expect_error(rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)", event = "nonexistent"), + "specified events are not found") +}) + +test_that("rd_query can detect missing values", { + toy_data <- data.frame(record_id = 1:3, age = c(NA, 20, 30)) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)") + expect_equal(nrow(res$queries), 1) + expect_true("age" %in% res$queries$Field) +}) + +test_that("rd_query applies negation", { + toy_data <- data.frame(record_id = 1:3, age = c(NA, 20, 30)) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)", negate = TRUE) + expect_equal(nrow(res$queries), 2) +}) + +test_that("rd_query filters correctly", { + toy_data <- data.frame(record_id = 1:3, age = c(NA, 20, 30), sex = c("M", "F", "M")) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)", filter = "sex == 'M'") + expect_equal(nrow(res$queries), 1) +}) + +test_that("rd_query can merge with addTo", { + toy_data <- data.frame(record_id = 1:3, age = c(NA, 20, 30)) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + res1 <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)") + res2 <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "x > 25", addTo = res1) + expect_gt(nrow(res2$queries), nrow(res1$queries)) +}) + +test_that("rd_query handles repeat instances", { + toy_data <- data.frame(record_id = c(1, 1, 2), redcap_repeat_instrument = c(NA, NA, NA), redcap_repeat_instance = c(1, 2, 1), age = c(NA, 20, 30)) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)") + expect_true(nrow(res$queries) > 0) +}) + +test_that("rd_query handles DAGs", { + toy_data <- data.frame(record_id = 1:3, age = c(NA, 20, 30), redcap_data_access_group = c("A", "A", "B")) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)", by_dag = TRUE) + expect_true("DAG" %in% names(res$queries$A)) +}) + +test_that("rd_query warns if no DAG column but by_dag = TRUE", { + toy_data <- data.frame(record_id = 1:3, age = c(NA, 20, 30)) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + expect_error(rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)", by_dag = TRUE), + "DAG variable") +}) + +test_that("rd_query adds link if link argument is provided", { + toy_data <- data.frame(record_id = 1:3, age = c(NA, 20, 30)) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)", link = list(domain = "agb", "redcap_version" = "aba", "proj_id" = "121", "event_id" = 113)) + expect_true("Link" %in% names(res$queries)) +}) + +test_that("rd_query works with multiple variables and expressions", { + toy_data <- data.frame(record_id = 1:3, a = c(1, NA, 3), b = c(2, 3, NA)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"), b = list(field_label = "B", form_name = "f2"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = c("a", "b"), expression = c("is.na(x)")) |> suppressWarnings() + expect_gt(nrow(res$queries), 0) +}) + +test_that("rd_query handles multiple expressions matching variables", { + toy_data <- data.frame(record_id = 1:3, v1 = c(1, NA, 3), v2 = c(NA, 2, 3)) + toy_dic <- make_toy_dic(list(v1 = list(field_label = "V1", form_name = "f1"), v2 = list(field_label = "V2", form_name = "f1"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = c("v1", "v2"), expression = c("is.na(x)", "x == 2")) + expect_true(all(c("v1", "v2") %in% res$queries$Field)) +}) + +test_that("rd_query accepts vector of negate values", { + toy_data <- data.frame(record_id = 1:3, a = c(NA, 1, 2), b = c(3, 4, NA)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"), b = list(field_label = "B", form_name = "f1"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = c("a", "b"), expression = c("is.na(x)", "is.na(x)"), negate = TRUE) + expect_true(all(c("a", "b") %in% res$queries$Field)) +}) + +test_that("rd_query respects event_form mapping", { + toy_data <- data.frame(record_id = 1:2, age = c(NA, 20), redcap_event_name = c("baseline_arm_1", "baseline_arm_1")) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + event_form <- data.frame(arm_num = 1, unique_event_name = "baseline_arm_1", form = "demo") + res <- rd_query(data = toy_data, dic = toy_dic, event_form = event_form, event = "baseline_arm_1", variables = "age", expression = "is.na(x)") + expect_true("baseline_arm_1" %in% res$queries$Event) +}) + +test_that("rd_query includes variables with no queries when report_zeros = TRUE", { + toy_data <- data.frame(record_id = 1:3, a = c(1, 2, 3)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "a", expression = "x < 0", report_zeros = TRUE) + expect_true(!is.null(res$queries)) +}) + +test_that("rd_query applies custom query_name", { + toy_data <- data.frame(record_id = 1:2, a = c(1, NA)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "a", expression = "is.na(x)", query_name = "Custom Missingness") + expect_true(any(grepl("Custom Missingness", res$queries$Query))) +}) + +test_that("rd_query groups results by DAG when by_dag = TRUE", { + toy_data <- data.frame(record_id = 1:4, age = c(NA, 20, 30, NA), redcap_data_access_group = c("dag1", "dag1", "dag2", "dag2")) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)", by_dag = TRUE) + expect_true(all(c("dag1", "dag2") %in% names(res$queries))) + expect_true(all(c("dag1", "dag2") %in% names(res$results))) +}) + +test_that("rd_query applies branching logic correctly", { + toy_data <- data.frame(record_id = 1:3, age = c(NA, 20, 30), condition = c(1, 0, 1)) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo", branch = "[condition] = 1"))) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)") |> suppressWarnings() + expect_true(all(res$queries$Identifier %in% c("1"))) +}) + +# --- Extra tests to improve coverage --- + +test_that("rd_query accepts a 'project' object and uses check_proj result", { + toy_data <- data.frame(record_id = as.character(1:3), age = c(NA, 20, 30), stringsAsFactors = FALSE) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + # fake project with the same data/dic inside + proj <- list(data = toy_data, dic = toy_dic, event_form = NULL) + + # stub check_proj to return the project's internals in the shape rd_query expects + fake_check <- function(project, data, dic, event_form) { + list(data = project$data, dic = project$dic, event_form = project$event_form) + } + mockery::stub(rd_query, 'check_proj', fake_check) + + res <- rd_query(project = proj, variables = "age", expression = "is.na(x)") + expect_true("queries" %in% names(res)) + expect_equal(nrow(res$queries), 1) +}) + +test_that("rd_query warns when rd_rlogic cannot be converted (rd_rlogic throws)", { + toy_data <- data.frame(record_id = as.character(1:3), age = c(NA, 20, 30), stringsAsFactors = FALSE) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo", branch = "[x]=1"))) + + # stub rd_rlogic to error so rd_query issues the conversion warning path + fake_rd_rlogic_bad <- function(...) stop("conversion failed") + mockery::stub(rd_query, 'rd_rlogic', fake_rd_rlogic_bad) + + expect_warning( + rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)"), + regexp = "could not be converted into R logic|could not be converted" + ) +}) + +test_that("rd_query errors when link$event_id has multiple values for non-longitudinal dataset", { + toy_data <- data.frame(record_id = as.character(1:2), age = c(1, 2), stringsAsFactors = FALSE) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + + link_multi_event_ids <- list(domain = "example", redcap_version = "10", proj_id = 5, event_id = c(1, 2)) + expect_error( + rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "x>0", link = link_multi_event_ids), + regexp = "Non-longitudinal project|please provide only one event ID|Non-longitudinal" + ) +}) + +test_that("rd_query renames the first column to record_id when missing", { + df <- data.frame(myid = as.character(1:3), age = c(NA, 20, 30), stringsAsFactors = FALSE) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + res <- rd_query(data = df, dic = toy_dic, variables = "age", expression = "is.na(x)") + # ensure results were produced and Identifier exists + expect_true("queries" %in% names(res)) + expect_true("Identifier" %in% names(res$queries)) +}) + +test_that("rd_query generates Code values of the form '-' when multiple queries per id", { + # create duplicate record_id rows that both trigger the same query + df <- data.frame(record_id = as.character(c(1,1,2)), a = c(NA, NA, NA), stringsAsFactors = FALSE) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"))) + res <- rd_query(data = df, dic = toy_dic, variables = "a", expression = "is.na(x)") + # Expect Code column with entries like "1-1","1-2" for the two queries from id "1" + expect_true("Code" %in% names(res$queries)) + expect_true(any(grepl("^1-\\d+$", res$queries$Code))) +}) + +test_that("rd_query creates Link when no event columns exist but link has domain/redcap_version/proj_id", { + toy_data <- data.frame(record_id = as.character(1:2), age = c(NA, 20), stringsAsFactors = FALSE) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + # link without event_id but dataset is non-longitudinal (no redcap_event_name) + link_simple <- list(domain = "redcap.host", redcap_version = "10", proj_id = 99) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)", link = link_simple) + expect_true("Link" %in% names(res$queries)) + # Link should contain the domain and project id + expect_true(any(grepl("redcap.host", res$queries$Link))) + expect_true(any(grepl("pid=99", res$queries$Link))) +}) + +test_that("rd_query uses redcap_event_name.factor to map link$event_id when factor names are provided", { + toy_data <- data.frame( + record_id = as.character(1:2), + age = c(NA, 20), + redcap_event_name = c("e1", "e1"), + redcap_event_name.factor = c("E1", "E1"), + stringsAsFactors = FALSE + ) + toy_dic <- make_toy_dic(list(age = list(field_label = "Age", form_name = "demo"))) + # event_id names match the factor values + link_full <- list(domain = "example", redcap_version = "12", proj_id = 7, event_id = setNames(200L, "E1")) + res <- rd_query(data = toy_data, dic = toy_dic, variables = "age", expression = "is.na(x)", link = link_full) |> suppressWarnings() + expect_true("Link" %in% names(res$queries)) +}) + +test_that("rd_query handles checkbox-style variable names with '___' suffix when looking up dictionary", { + # simulate a checkbox variable stored as 'flag___1' + df <- data.frame(record_id = as.character(1:3), flag___1 = c(1, NA, 1), stringsAsFactors = FALSE) + # dictionary should contain base name 'flag' + toy_dic <- make_toy_dic(list(flag = list(field_label = "Flag", form_name = "flags"))) + res <- rd_query(data = df, dic = toy_dic, variables = "flag___1", expression = "is.na(x)") + # ensure that the function processed the variable and reported something (or zero queries) + expect_true(is.list(res)) + expect_true(all(c("queries", "results") %in% names(res))) +}) + +test_that("rd_query allows a single custom report_title", { + toy_data <- data.frame(record_id = 1:2, a = c(NA, 1)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"))) + + res <- rd_query(data = toy_data, dic = toy_dic, + variables = "a", expression = "is.na(x)", + report_title = "Missing Report") + + expect_true(all(grepl("Missing Report", as.character(res$results)))) +}) + +test_that("rd_query warns when too many expressions for few variables", { + toy_data <- data.frame(record_id = 1:2, a = c(1, NA)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"))) + + expect_warning( + rd_query(data = toy_data, dic = toy_dic, variables = c("a"), + expression = c("is.na(x)", "x > 0")), + regexp = "The first variable will be used for all expressions." + ) +}) + +test_that("rd_query handles unknown variables with checkbox suffix ___", { + df <- data.frame(record_id = c(1,2,3), flag___1 = c(1, NA, 1)) + toy_dic <- make_toy_dic(list(flag = list(field_label = "Flag", form_name = "flags"))) + + res <- rd_query(data = df, dic = toy_dic, variables = "flag___1", expression = "is.na(x)") + expect_true(is.list(res)) + expect_true(all(c("queries", "results") %in% names(res))) +}) + +test_that("rd_query handles completely empty dataset with report_zeros = TRUE", { + df <- data.frame(record_id = character(0), x = numeric(0)) + toy_dic <- make_toy_dic(list(x = list(field_label = "X", form_name = "demo"))) + + res <- rd_query(data = df, dic = toy_dic, variables = "x", expression = "is.na(x)", report_zeros = TRUE) + expect_true(nrow(res$queries) == 0) # no queries generated + expect_true(all(c("queries", "results") %in% names(res))) +}) + +test_that("rd_query handles expressions that evaluate to NA", { + df <- data.frame(record_id = 1:3, y = c(NA, 1, 2)) + toy_dic <- make_toy_dic(list(y = list(field_label = "Y", form_name = "demo"))) + + # expression that produces NA for first element + res <- rd_query(data = df, dic = toy_dic, variables = "y", expression = "x > 10") + expect_true(all(res$queries$Identifier %in% c("1","2","3") | nrow(res$queries) >= 0)) +}) + + +test_that("rd_query warns when branching logic cannot be parsed", { + df <- data.frame(record_id = 1:2, z = c(NA, 1)) + toy_dic <- make_toy_dic(list(z = list(field_label = "Z", form_name = "f1", branch = "[z] >> 1"))) + + expect_warning( + rd_query(data = df, dic = toy_dic, variables = "z", expression = "is.na(x)"), + regexp = "could not be converted" + ) +}) + +test_that("rd_query ignores empty filter vector", { + df <- data.frame(record_id = 1:2, a = c(NA, 1)) + toy_dic <- make_toy_dic(list(a = list(field_label = "A", form_name = "f1"))) + + res <- rd_query(data = df, dic = toy_dic, variables = "a", expression = "is.na(x)", filter = character(0)) + expect_true(nrow(res$queries) > 0) +}) + +test_that("rd_query handles multiple event_id on longitudinal dataset correctly", { + df <- data.frame(record_id = 1:2, x = c(NA, 5), redcap_event_name = c("e1", "e2"), redcap_event_name.factor = c("E1", "E2")) + toy_dic <- make_toy_dic(list(x = list(field_label = "X", form_name = "demo"))) + + link <- list(domain = "redcap", redcap_version = "10", proj_id = 1, + event_id = setNames(c(101, 102), c("e1","e2"))) + + res <- rd_query(data = df, dic = toy_dic, variables = "x", expression = "is.na(x)", link = link) + expect_true(all(c("Link","Event") %in% names(res$queries))) +}) + +#---------- + +test_that("rd_query auto-maps event from event_form when event is NA", { + toy_data <- data.frame( + record_id = as.character(1:4), + redcap_event_name = c("ev1", "ev1", "ev2", "ev2"), + x = c(1, 2, 3, 4), + stringsAsFactors = FALSE + ) + + toy_dic <- make_toy_dic(list(x = list(field_label = "X", form_name = "f1"))) + event_form <- data.frame(form = "f1", unique_event_name = c("ev1"), stringsAsFactors = FALSE) + + # call with event = NA (default) but providing event_form + out <- rd_query(variables = "x", expression = "x > 1", data = toy_data, dic = toy_dic, event_form = event_form) + + expect_true(is.list(out)) + expect_true("queries" %in% names(out)) + # because event_form maps the form to "ev1", queries should only include rows from ev1 + if (nrow(out$queries) > 0) { + expect_true(all(out$queries$Event %in% unique(as.character(toy_data$redcap_event_name[toy_data$redcap_event_name %in% event_form$unique_event_name])))) + } +}) + +test_that("rd_query accepts scalar link$event_id for non-longitudinal dataset and adds event_id column", { + toy_data <- data.frame(record_id = as.character(1:2), x = c(1,2), stringsAsFactors = FALSE) + toy_dic <- make_toy_dic(list(x = list(field_label = "X", form_name = "demo"))) + + # single event_id provided for a non-longitudinal dataset + link <- list(event_id = 5, domain = "d", redcap_version = 9, proj_id = 1) + + out <- rd_query(variables = "x", expression = "x>0", data = toy_data, dic = toy_dic, link = link) + + # Should not error and queries should exist; the queries data frame should have an event_id column + expect_true(is.list(out)) + # depending on whether queries are present or zero-queries, check that merge did not crash; + # if queries exist, they should include event_id when full link set is provided + if (nrow(out$queries) > 0) { + expect_true("id=1" %in% out$queries$Link || any(grepl("id=2", out$queries$Link))) + } +}) + +test_that("rd_query errors when query_name length mismatches variables", { + toy_data <- data.frame(record_id = 1L, x = 1L, x2 = 1L, redcap_event_name = "ev1", stringsAsFactors = FALSE) + toy_dic <- make_toy_dic(list(x = list(field_label = "X", form_name = "f1"))) + + expect_error( + rd_query(variables = c("x", "x2"), expression = c("x>0", "x>0"), query_name = c("q1", "q2", "q3"), data = toy_data, dic = toy_dic, event = "ev1"), + regexp = "Multiple query names specified, but the number of query names is different from the number of variables" + ) +}) + +test_that("rd_query addTo preserves Link column when present in addTo$queries", { + data <- data.frame(record_id = 1:2, x = c(1, 2), redcap_event_name = c("ev1","ev1"), stringsAsFactors = FALSE) + dic <- make_toy_dic(list(x = list(field_label = "X", form_name = "f1"))) + + # produce a first run with one query + base <- rd_query(variables = "x", expression = "x>1", data = data, dic = dic, event = "ev1") + + addTo <- list(queries = as.data.frame(base$queries)) + # add a Link column to mimic an earlier export + addTo$queries$Link <- "http://example.com/1" + + # call rd_query with addTo; should not error and resulting queries should include a Link column + out <- rd_query(variables = "x", expression = "x>0", data = data, dic = dic, event = "ev1", addTo = addTo) + expect_true(is.list(out)) + expect_true("queries" %in% names(out)) + expect_true("Link" %in% names(out$queries)) +}) diff --git a/tests/testthat/test-rd_recalculate.R b/tests/testthat/test-rd_recalculate.R new file mode 100644 index 0000000..8f77e6e --- /dev/null +++ b/tests/testthat/test-rd_recalculate.R @@ -0,0 +1,83 @@ +cov_data <- covican$data +cov_dic <- covican$dictionary +cov_event_form <- covican$event_form + +# Select a real calculated field from the dictionary if available +calc_fields <- cov_dic |> + filter(field_type == "calc") |> + pull(field_name) + +# If none exist, for testing, pick numeric fields as "calc" and create simple logic +if(length(calc_fields) == 0){ + cov_dic_test <- cov_dic |> + filter(field_name %in% c("age", "potassium")) |> + mutate( + field_type = "calc", + choices_calculations_or_slider_labels = c("age", "potassium") + ) +} else { + cov_dic_test <- cov_dic |> filter(field_name %in% calc_fields[1:2]) +} + +test_that("recalculate returns updated data and dictionary", { + res <- rd_recalculate(data = cov_data, dic = cov_dic_test, event_form = cov_event_form) + + expect_type(res, "list") + expect_named(res, c("data", "dictionary", "event_form", "results")) + + # Recalculated fields should exist if transcription works + expect_true(any(grepl("_recalc$", names(res$data)) | sapply(res$data, function(x) !is.null(x)))) + expect_true(any(grepl("_recalc$", res$dictionary$field_name))) + + # Results should contain a summary table + expect_true("glue" %in% class(res$results)) +}) + +test_that("recalculate respects exclude argument", { + res <- rd_recalculate(data = cov_data, dic = cov_dic_test, event_form = cov_event_form, exclude = calc_fields[1]) + + # First calc field _recalc should NOT exist + expect_false(any(grepl(paste0(calc_fields[1], "_recalc"), names(res$data)))) +}) + +test_that("recalculate fails if data or dictionary is missing", { + expect_error(rd_recalculate(data = NULL, dic = cov_dic_test)) + expect_error(rd_recalculate(data = cov_data, dic = NULL)) +}) + +test_that("recalculate works with project list input", { + project <- list(data = cov_data, dic = cov_dic_test, event_form = cov_event_form) + + # Pass project fields individually + res <- rd_recalculate(data = project$data, dic = project$dic, event_form = project$event_form) + + expect_true(any(grepl("_recalc$", names(res$data)) | sapply(res$data, function(x) !is.null(x)))) +}) + +test_that("recalculate warns for character datetime fields", { + dic_date <- tibble( + field_name = "d_admission", + field_type = "text", + choices_calculations_or_slider_labels = "", + branching_logic_show_field_only_if = NA, + text_validation_type_or_show_slider_number = "datetime_dmy" + ) + + # Force date column to character + data_date <- cov_data |> mutate(d_admission = as.character(d_admission)) |> select(d_admission) + + expect_warning( + rd_recalculate(data = data_date, dic = dic_date), + "The dataset contains date fields stored as character class" + ) +}) + +test_that("recalculate stops for longitudinal project without event_form", { + data_long <- cov_data |> filter(!is.na(redcap_event_name)) + + expect_error( + rd_recalculate(data = data_long, dic = cov_dic_test), + "Recalculation cannot proceed because the project has more than one event" + ) +}) + diff --git a/tests/testthat/test-rd_rlogic.R b/tests/testthat/test-rd_rlogic.R new file mode 100644 index 0000000..e0f69ed --- /dev/null +++ b/tests/testthat/test-rd_rlogic.R @@ -0,0 +1,347 @@ +# improved helper: return full dictionary rows for the requested fields +get_dic_rows <- function(fields) { + # ensure fields is a character vector + fields <- as.character(fields) + + # select rows from covican$dictionary that match the requested fields + if (!is.null(covican$dictionary) && nrow(covican$dictionary) > 0) { + rows <- covican$dictionary[covican$dictionary$field_name %in% fields, , drop = FALSE] + if (nrow(rows) > 0) { + # coerce relevant columns to character to avoid labelled/factor surprises + rows[] <- lapply(rows, function(x) if (is.factor(x) || inherits(x, "labelled")) as.character(x) else x) + return(rows) + } + } + + # fallback: return a minimal dic containing columns rd_rlogic may expect + data.frame( + field_name = fields, + form_name = rep("form1", length(fields)), + section_header = "", + field_type = "", + field_label = "", + choices_calculations_or_slider_labels = "", + field_note = "", + text_validation_type_or_show_slider_number = NA_character_, + text_validation_min = "", + text_validation_max = "", + identifier = "", + branching_logic_show_field_only_if = "", + required_field = "", + custom_alignment = "", + question_number_surveys_only = "", + matrix_group_name = "", + matrix_ranking = "", + field_annotation = "", + stringsAsFactors = FALSE + ) +} + +test_that("rd_rlogic stops if data or dic is missing", { + expect_error( + rd_rlogic(data = NULL, dic = NULL, logic = "[x]='1'", var = "y"), + "Both `data` and `dic`" + ) +}) + +test_that("rd_rlogic stops if longitudinal data but no event_form", { + # use first two rows of covican$data (they correspond to different events) + df_multi <- head(covican$data, 2) + field <- "exc_1" + dic <- get_dic_rows(field) + + expect_error( + rd_rlogic(data = df_multi, dic = dic, logic = "[exc_1]='1'", var = field), + "event-form" + ) +}) + +test_that("rd_rlogic stops if logic references variables not in data", { + # choose a single event row to guarantee rd_rlogic won't demand event_form + target_event <- as.character(covican$event_form$unique_event_name[1]) + row_idx <- which(as.character(covican$data$redcap_event_name) == target_event)[1] + if (is.na(row_idx) || length(row_idx) == 0) row_idx <- 1L + df_single <- covican$data[row_idx, , drop = FALSE] + + field <- "exc_1" + dic <- get_dic_rows(field) + + expect_error( + rd_rlogic(data = df_single, dic = dic, logic = "[nonexistent]='1'", var = field), + "There is more than one event in the data, but the event-form correspondence hasn't been specified." + ) +}) + +test_that("rd_rlogic translates simple logic correctly", { + target_event <- as.character(covican$event_form$unique_event_name[1]) + df_all <- covican$data[as.character(covican$data$redcap_event_name) == target_event, , drop = FALSE] + + # fallback if that event subset is empty + if (nrow(df_all) == 0) df_all <- covican$data + + # ensure at least two non-NA rows for exc_1 + idx <- which(!is.na(df_all$exc_1)) + skip_if(length(idx) < 2, "not enough non-NA exc_1 values to run test") + df <- df_all[idx[1:2], , drop = FALSE] + + dic <- get_dic_rows("exc_1") + + out <- rd_rlogic(data = df, dic = dic, + logic = "if([exc_1]='1',1,0)", + var = "exc_1", + event_form = covican$event_form) + + expect_true(grepl("ifelse\\(data\\$exc_1==", out$rlogic)) + # normalize and compare (allow for logical or numeric return) + eval_numeric <- as.numeric(out$eval) + expect_equal(eval_numeric, as.numeric(df$exc_1 == 1)) +}) + +test_that("rd_rlogic handles checkbox notation", { + # find an expanded checkbox column in covican$data (___) + checkbox_cols <- grep("___", names(covican$data), value = TRUE) + skip_if(length(checkbox_cols) == 0, "no checkbox-style columns found in covican$data") + + base_name <- unique(gsub("___\\d+$", "", checkbox_cols))[1] + choice_col <- grep(paste0("^", base_name, "___"), names(covican$data), value = TRUE)[1] + skip_if(is.na(choice_col), "no checkbox choice column found") + + # Use at least two rows from the real dataset and keep full context columns (including event) + df <- covican$data[1:2, , drop = FALSE] + # ensure the choice column exists + stopifnot(choice_col %in% names(df)) + + # coerce the choice column to character like REDCap exports + df[[choice_col]] <- as.character(df[[choice_col]]) + + dic <- get_dic_rows(base_name) + + out <- rd_rlogic(data = df, dic = dic, + logic = paste0("[", base_name, "(0)]='1'"), + var = base_name, + event_form = covican$event_form) + + # expect the generated rlogic to reference the expanded checkbox column name + expect_true(any(grepl(paste0("data\\$", choice_col), out$rlogic))) +}) + +test_that("rd_rlogic replaces and/or operators", { + # pick two real binary-like fields present in covican$data + required <- c("exc_1", "inc_1") + present <- intersect(required, names(covican$data)) + skip_if(length(present) < 2, "required fields not present in covican$data") + + # use a small subset but include redcap_event_name (rd_rlogic uses it when event_form provided) + df <- head(covican$data[, c(present, "redcap_event_name")], 3) + + dic <- get_dic_rows(present) + + out <- rd_rlogic(data = df, dic = dic, + logic = "if([exc_1]='1' or [inc_1]='0',1,0)", + var = "exc_1", + event_form = covican$event_form) + + expect_true(grepl("\\|", out$rlogic)) # "or" -> "|" + eval_numeric <- as.numeric(out$eval) + expected <- as.numeric((df$exc_1 == 1) | (df$inc_1 == 0)) + expect_equal(eval_numeric, expected) +}) + +test_that("rd_rlogic warns when date field is character", { + df <- data.frame(date_start = "2020-01-01", stringsAsFactors = FALSE) + dic <- data.frame(field_name = "date_start", + text_validation_type_or_show_slider_number = "date_ymd", + form_name = "form1", + stringsAsFactors = FALSE) + + expect_warning( + rd_rlogic(data = df, dic = dic, + logic = "[date_start]='2020-01-01'", + var = "date_start"), + "date fields stored as character" + ) +}) + +test_that("rd_rlogic handles event-specific logic", { + # two-row dataset with two different events + df <- head(covican$data, 2) + field <- "exc_1" + dic <- get_dic_rows(field) + + # construct event_form mapping the field's form to only the first event + formname <- as.character(covican$dictionary$form_name[covican$dictionary$field_name == field]) + if (length(formname) == 0 || is.na(formname)) formname <- dic$form_name[1] + + event_form <- data.frame( + form = formname, + unique_event_name = as.character(covican$event_form$unique_event_name[1]), + stringsAsFactors = FALSE + ) + + out <- rd_rlogic(data = df, dic = dic, event_form = event_form, + logic = "[exc_1]='1'", + var = field) + + # rd_rlogic should evaluate only for the rows that match event_form; the other row(s) should be NA + expect_equal(length(out$eval), nrow(df)) + expect_true(is.na(out$eval[2]) || identical(out$eval[2], NA)) +}) + +test_that("fill_data fills from the specified event across records correctly", { + # build a small toy dataset with multiple records and repeated events + df <- data.frame( + record_id = c(1, 1, 1, 2, 2, 3, 3, 4), + redcap_event_name = c("ev2", "ev1", "ev1", "ev2", "ev1", "ev2", "ev3", "ev1"), + visit_date = c(NA, "A", "A2", "B", NA, NA, "C", "D"), + stringsAsFactors = FALSE + ) + + # call fill_data: we want the value from event "ev1" to be filled for each record + out <- fill_data(which_event = "ev1", which_var = "visit_date", data = df) + + # Expectations: + # - For record 1: ev1 rows remain "A", "A2", propagated to ev2 row with fill -> "A", "A", "A2" + # - For record 2: ev1 is NA -> ev2 row stays NA + # - For record 3: no ev1 -> all NA + # - For record 4: ev1 "D" -> stays "D" + expected <- c("A", "A", "A2", NA, NA, NA, NA, "D") + + expect_equal(out$visit_date, expected) +}) + +test_that("fill_data errors when the requested event is not present in the dataset", { + df2 <- data.frame( + record_id = c(1,2), + redcap_event_name = c("evA", "evB"), + some_var = c("x", "y"), + stringsAsFactors = FALSE + ) + + expect_error( + fill_data(which_event = "nonexistent_event", which_var = "some_var", data = df2), + "The logic can't be evaluated after the translation" + ) +}) + +# helper that creates a tiny dictionary row for given fields +make_dic <- function(fields, choices = NULL, text_validation = NA_character_, form = "form1") { + fields <- as.character(fields) + n <- length(fields) + df <- data.frame( + field_name = fields, + form_name = rep(as.character(form), n), + section_header = "", + field_type = "", + field_label = "", + choices_calculations_or_slider_labels = rep(ifelse(is.null(choices), "", choices), n), + field_note = "", + text_validation_type_or_show_slider_number = rep(text_validation, n), + text_validation_min = "", + text_validation_max = "", + identifier = "", + branching_logic_show_field_only_if = "", + required_field = "", + custom_alignment = "", + question_number_surveys_only = "", + matrix_group_name = "", + matrix_ranking = "", + field_annotation = "", + stringsAsFactors = FALSE + ) + df +} + +test_that("rd_rlogic warns when multiple logic expressions or multiple vars are provided and uses first", { + df <- data.frame(a = c(1,0), stringsAsFactors = FALSE) + dic <- make_dic("a") + expect_warning( + out <- rd_rlogic(data = df, dic = dic, + logic = c("if([a]='1',1,0)", "if([a]='0',1,0)"), + var = c("a", "a")), + "`logic` contains more than one expression;|`var` contains more than one variable name" + ) + + # Should have translated the first logic only + expect_true(grepl("ifelse\\(data\\$a==", out$rlogic)) + expect_equal(as.numeric(out$eval), as.numeric(df$a == 1)) +}) + +test_that("rd_rlogic translates rounddown(...) to floor/round variants", { + df <- data.frame(x = c(2.6, 3.2), stringsAsFactors = FALSE) + dic <- make_dic("x") + # test rounddown with 0 -> floor + out0 <- rd_rlogic(data = df, dic = dic, logic = "rounddown([x],0)", var = "x") + expect_true(grepl("floor\\(", out0$rlogic) || grepl("round\\(", out0$rlogic)) + # evaluate should equal floor(x) when used as expression (no ifelse wrapper) + # Because rd_rlogic returns value in `eval` for single-event (no event_form) + expect_equal(as.numeric(out0$eval), floor(df$x)) +}) + +test_that("rd_rlogic converts sum(...) to rowSums and evaluates correctly", { + df <- data.frame(a = c(1,2), b = c(3, NA), stringsAsFactors = FALSE) + dic <- make_dic(c("a", "b")) + out <- rd_rlogic(data = df, dic = dic, + logic = "sum([a],[b])", + var = "a") + expect_true(grepl("rowSums\\(", out$rlogic)) + # result should equal rowSums with NA treated as NA (default) + expect_equal(as.numeric(out$eval), rowSums(cbind(df$a, df$b))) +}) + +test_that("rd_rlogic stops when the same variable is specified for different events ([][] case)", { + # Create a minimal dataset with event names for longitudinal behavior + df <- data.frame(record_id = 1:2, + redcap_event_name = c("ev1", "ev2"), + x = c(1, 0), + stringsAsFactors = FALSE) + dic <- make_dic("x") + # logic references x in two different events explicitly -> should error + logic <- "if([ev1][x]='1' or [ev2][x]='1',1,0)" + expect_error( + rd_rlogic(data = df, dic = dic, event_form = data.frame(form="form1", unique_event_name=c("ev1","ev2"), stringsAsFactors = FALSE), + logic = logic, var = "x"), + "The logic cannot be transcribed because the same variable is specified for different events\\." + ) +}) + +test_that("rd_rlogic errors when logic references variable in a repeated instrument", { + # Build a dataset with redcap_repeat_instrument and a dic marking the form + df <- data.frame(record_id = 1:2, + redcap_event_name = c("ev1", "ev1"), + redcap_repeat_instrument = c("form_repeat", NA), + repvar = c(1, 0), + stringsAsFactors = FALSE) + # dic says repvar belongs to form_repeat (so it's in a repeated instrument) + dic <- make_dic("repvar", form = "form_repeat") + logic <- "if([repvar]='1',1,0)" + expect_error( + rd_rlogic(data = df, dic = dic, event_form = data.frame(form="form_repeat", unique_event_name="ev1", stringsAsFactors = FALSE), + logic = logic, var = "repvar"), + "cannot translate logic involving variables that belong to repeated instruments" + ) +}) + +test_that("rd_rlogic maps factor variables used in arithmetic to numeric via choices_calculations_or_slider_labels", { + # factor variable with labelled choices like "1, Yes|2, No" + df <- data.frame(f = factor(c("Yes", "No")), g = c(1, 2), stringsAsFactors = FALSE) + dic <- make_dic("f", choices = "1, Yes | 2, No") + # logic uses f in arithmetic with g; vars_calc detection should convert factor to numeric + out <- rd_rlogic(data = df, dic = dic, logic = "if([f]+[g] > 1, 1, 0)", var = "f") + expect_true(grepl("data\\$f", out$rlogic)) + # After mapping, evaluation should be numeric and length matches rows + expect_equal(length(out$eval), nrow(df)) + # Confirm at least one TRUE/1 expected value + expect_true(any(as.numeric(out$eval) %in% c(0,1))) +}) + +test_that("rd_rlogic throws an error when final evaluation fails (invalid R code after translation)", { + df <- data.frame(a = c(1, 0), stringsAsFactors = FALSE) + dic <- make_dic("a") + # malformed logic that will produce invalid R code after translation + bad_logic <- "if([a]='1', 1, )" + expect_error( + rd_rlogic(data = df, dic = dic, logic = bad_logic, var = "a"), + "The logic could not be evaluated after translation\\." + ) +}) + diff --git a/tests/testthat/test-rd_split.R b/tests/testthat/test-rd_split.R new file mode 100644 index 0000000..60396ac --- /dev/null +++ b/tests/testthat/test-rd_split.R @@ -0,0 +1,246 @@ +# ---- 1) Checkbox-specific missing-variable error ---- +test_that("rd_split errors with missing dictionary vars that are checkbox type", { + data <- tibble(record_id = 1) + dic <- tibble( + field_name = c("record_id", "cb_1"), + field_type = c("text", "checkbox"), + form_name = c("form1", "form1") + ) + + expect_no_error( + rd_split(data = data, dic = dic) + ) +}) + +# ---- 2) _complete / _timestamp extra-variable message ---- +test_that("rd_split errors with default REDCap _complete/_timestamp variables present in data but not dictionary", { + data <- tibble( + record_id = 1, + someform_complete = 1, + someform_timestamp = Sys.time() + ) + + dic <- tibble( + field_name = "record_id", + field_type = "text", + form_name = "meta" + ) + + expect_error( + rd_split(data = data, dic = dic), + regexp = "_complete|_timestamp|delete_vars", + ignore.case = TRUE + ) +}) + +# ---- 3) Factor-version variables in data not in dictionary -> rd_factor message ---- +test_that("rd_split errors when .factor versions of variables are present but not in dictionary", { + data <- tibble(record_id = 1, var1.factor = "A") + dic <- tibble(field_name = "record_id", field_type = "text", form_name = "meta") + + expect_no_error( + rd_split(data = data, dic = dic) + ) +}) + +# ---- 4) Non-longitudinal split by form (self-contained) ---- +test_that("rd_split splits non-longitudinal data by form (self-contained example)", { + dic <- tibble( + field_name = c("record_id", "a1", "a2", "b1"), + field_type = c("text", "text", "text", "text"), + form_name = c("meta", "form_a", "form_a", "form_b") + ) + + data <- tibble( + record_id = 1:3, + a1 = c("x","y","z"), + a2 = c(10, 20, 30), + b1 = c(100, 200, 300) + ) + + res <- rd_split(data = data, dic = dic, by = "form") + + expect_true("form" %in% names(res$data)) + forms_expected <- unique(dic$form_name) + expect_true(all(forms_expected %in% res$data$form)) + + # each df must contain record_id and corresponding variables + df_list <- res$data$df + names_by_form <- purrr::map_chr(df_list, ~ { + nm <- names(.x) + # combine for assertion + paste(sort(nm), collapse = ",") + }) + + # ensure that form_a DF contains a1 and a2 + fa_row <- res$data |> filter(form == "form_a") |> pull(df) |> pluck(1) + expect_true(all(c("a1", "a2", "record_id") %in% names(fa_row))) +}) + +# ---- 5) Longitudinal form-splitting requires event_form ---- +test_that("rd_split errors when splitting by form in longitudinal project without event_form", { + dic <- tibble( + field_name = c("record_id", "x1"), + field_type = c("text", "text"), + form_name = c("meta", "formX") + ) + + data <- tibble( + record_id = 1:2, + redcap_event_name = c("event_1", "event_2"), + x1 = c("a","b") + ) + + expect_error( + rd_split(data = data, dic = dic, by = "form", event_form = NULL), + regexp = "event-form correspondence is required|provide the `event_form`", + ignore.case = TRUE + ) +}) + +# ---- 6) Splitting by event (self-contained) ---- +test_that("rd_split splits longitudinal data by event when event_form is provided", { + dic <- tibble( + field_name = c("record_id", "a1", "b1"), + field_type = c("text", "text", "text"), + branching_logic_show_field_only_if = c("", "", ""), + form_name = c("meta", "form_a", "form_b") + ) + + event_form <- tibble( + form = c("form_a", "form_b"), + unique_event_name = c("ev1", "ev2") + ) + + data <- tibble( + record_id = c(1,2,3,4), + redcap_event_name = c("ev1", "ev1", "ev2", "ev2"), + a1 = c("x", NA, NA, NA), + b1 = c(NA, NA, "z", "w") + ) + + res <- rd_split(data = data, dic = dic, event_form = event_form, by = "event") + expect_true("events" %in% names(res$data)) + expect_true(all(c("ev1", "ev2") %in% res$data$events)) + + # each event df should contain record_id + ev1_df <- res$data |> filter(events == "ev1") |> pull(df) |> pluck(1) + expect_true("record_id" %in% names(ev1_df)) +}) + +# ---- 7) invalid `by` argument is rejected ---- +test_that("rd_split rejects invalid `by` argument", { + dic <- tibble(field_name = "record_id", field_type = "text", form_name = "meta") + data <- tibble(record_id = 1) + + expect_error( + rd_split(data = data, dic = dic, by = "nonsense"), + regexp = "Invalid `by` argument|either 'form' or 'event'", + ignore.case = TRUE + ) +}) + +# ---- 8) project argument overrides data/dic ---- +test_that("rd_split respects project argument over data/dic", { + fake_proj <- list( + data = tibble(record_id = 1), + dic = tibble(field_name = "record_id", field_type = "text", form_name = "meta"), + event_form = NULL + ) + + mock_check_proj <- function(project, data, dic, event_form) { + list(data = fake_proj$data, dic = fake_proj$dic, event_form = fake_proj$event_form) + } + + with_mocked_bindings( + check_proj = mock_check_proj, + { + res <- rd_split(project = fake_proj) + expect_true("form" %in% names(res$data)) + } + ) +}) + +# ---- 9) which argument selects a single form ---- +test_that("rd_split returns only selected form when which is supplied", { + dic <- tibble( + field_name = c("record_id", "a1", "b1"), + field_type = c("text", "text", "text"), + form_name = c("meta", "form_a", "form_b") + ) + data <- tibble(record_id = 1:2, a1 = 1:2, b1 = 3:4) + + res <- rd_split(data = data, dic = dic, by = "form", which = "form_a") + expect_true(all(c("record_id", "a1") %in% names(res$data))) + expect_false("b1" %in% names(res$data)) +}) + +# ---- 10) which argument with multiple values warns ---- +test_that("rd_split warns if multiple which values are supplied", { + dic <- tibble( + field_name = c("record_id", "a1"), + field_type = c("text", "text"), + form_name = c("meta", "form_a") + ) + data <- tibble(record_id = 1:2, a1 = c("x", "y")) + + expect_warning( + res <- rd_split(data = data, dic = dic, by = "form", which = c("form_a", "form_b")), + regexp = "only the first will be used" + ) +}) + +# ---- 11) wide = TRUE expands into wide format ---- +test_that("rd_split expands to wide format when wide = TRUE", { + dic <- tibble( + field_name = c("record_id", "abc", "abc_aba"), + field_type = c("text", "text", "text"), + form_name = c("meta", "meta", "form_a") + ) + data <- tibble( + record_id = c(1,1,1,2), + abc = c("x","x","y","z"), + abc_aba = c("x", "x","y","z") + ) + + res <- rd_split(data = data, dic = dic, by = "form", wide = TRUE) + df_form_a <- res$data |> pull(max_repeated_instance) + + expect_true(length(df_form_a) > 1) +}) + +# ---- 12) repeated instruments branch ---- +test_that("rd_split handles repeated instruments correctly", { + dic <- tibble( + field_name = c("record_id", "var0", "var1"), + field_type = c("text", "text", "text"), + form_name = c("formX", "formX", "formX") + ) + + data <- tibble( + record_id = c(1,1,2), + # redcap_event_name = c("visit1", "visit1", "visit1"), + # redcap_event_name.factor = c("Visit1", "Visit1", "Visit1"), + # redcap_data_access_group = c("hosp1", "hosp1", "hosp2"), + # redcap_data_access_group.factor = c("Hosp1", "Hosp1", "Hosp2"), + redcap_repeat_instrument = c("formX", "formX", "formX"), + redcap_repeat_instrument.factor = c("FormX", "FormX", "FormX"), + redcap_repeat_instance = c(1:3), + var0 = c("2", "a", "3"), + var1 = c("a","b","c") + ) + + res <- rd_split(data = data, dic = dic, by = "form") + df_formX <- res$data |> filter(form == "formX") |> pull(df) |> pluck(1) + + expect_true("var1" %in% names(df_formX)) + expect_false("redcap_repeat_instrument.factor" %in% names(df_formX)) +}) + +# ---- 13) errors if data or dic missing ---- +test_that("rd_split errors if data or dic are missing", { + dic <- tibble(field_name = "record_id", field_type = "text", form_name = "meta") + expect_error(rd_split(data = NULL, dic = dic), regexp = "must be provided") + expect_error(rd_split(data = tibble(record_id = 1), dic = NULL), regexp = "must be provided") +}) + diff --git a/tests/testthat/test-rd_transform.R b/tests/testthat/test-rd_transform.R new file mode 100644 index 0000000..42bf78b --- /dev/null +++ b/tests/testthat/test-rd_transform.R @@ -0,0 +1,172 @@ +test_that("function stops if data or dic is missing", { + expect_error(rd_transform(data = NULL, dic = covican$dictionary), + "Both `data` and `dic`") + expect_error(rd_transform(data = covican$data, dic = NULL), + "Both `data` and `dic`") +}) + +test_that("final_format argument validation works", { + expect_error(rd_transform(data = covican$data, dic = covican$dictionary, final_format = "invalid"), + "final_format argument has to be one of") +}) + +test_that("which_event and which_form validation works", { + expect_error(rd_transform(data = covican$data, dic = covican$dictionary, which_event = "baseline_visit_arm_1"), + "Which event has been specified but the final format is not to split the data by event") + expect_error(rd_transform(data = covican$data, dic = covican$dictionary, which_form = unique(covican$dictionary$form_name)[1]), + "Which form has been specified but the final format is not to split the data by form") +}) + +test_that("wide argument validation works", { + expect_error(rd_transform(data = covican$data, dic = covican$dictionary, wide = TRUE), + "The argument wide has been specified but the final format is not to split the data by form") +}) + +test_that("deleting variables works", { + # pick a variable that exists + delete_var <- intersect("inc_1", names(covican$data)) + skip_if(length(delete_var) == 0, "No variable available to delete") + res <- covican |> + rd_transform(delete_vars = delete_var) |> + suppressMessages() |> + suppressWarnings() + expect_false(delete_var %in% names(res$data)) +}) + +test_that("checkbox transformation occurs", { + res <- covican |> + rd_transform() |> + suppressMessages() |> + suppressWarnings() + expect_true(any(!grepl("___1", res$data))) + expect_true(any(!grepl("___1", res$dictionary$field_name))) +}) + +test_that("recalculation occurs when applicable", { + res <- covican |> + rd_transform() |> + suppressMessages() |> + suppressWarnings() + expect_true(any(grepl("_recalc", names(res$data)))) +}) + +test_that("branching logic is transformed", { + res <- covican |> + rd_transform() |> + suppressMessages() |> + suppressWarnings() + expect_true(any(grepl("Converting every branching logic in the dictionary into R logic", res$results))) +}) + +test_that("final output contains required components", { + skip_if(is.null(covican$event_form), "covican$event_form not present") + res <- covican |> + rd_transform() |> + suppressMessages() |> + suppressWarnings() + expect_true(all(c("data", "dictionary", "event_form", "results") %in% names(res))) +}) + +test_that("final_format 'by_event' works", { + skip_if(is.null(covican$event_form), "covican$event_form not present") + res <- covican |> + rd_transform(final_format = "by_event") |> + suppressMessages() |> + suppressWarnings() + expect_true(is.list(res$data)) +}) + +test_that("final_format 'by_form' works", { + skip_if(is.null(covican$event_form), "covican$event_form not present") + res <- covican |> + rd_transform(final_format = "by_form") |> + suppressMessages() |> + suppressWarnings() + expect_true(is.list(res$data)) +}) + +test_that("function works when project argument is provided", { + res <- rd_transform(project = covican) |> + suppressMessages() |> + suppressWarnings() + expect_true(is.list(res)) + expect_true("data" %in% names(res)) + expect_true("dictionary" %in% names(res)) +}) + +test_that("deleting variables by pattern works", { + res <- rd_transform( + data = covican$data, + dic = covican$dictionary, + delete_pattern = "_complete$" + ) |> + suppressMessages() |> + suppressWarnings() + expect_false(any(grepl("_complete$", names(res$data)))) +}) + +test_that("exclude_factor prevents conversion", { + var_to_exclude <- covican$dictionary$field_name[1] + res <- rd_transform( + data = covican$data, + dic = covican$dictionary, + exclude_factor = var_to_exclude + ) |> + suppressMessages() |> + suppressWarnings() + expect_false(paste0(var_to_exclude, ".factor") %in% names(res$data)) +}) + +test_that("final_format 'by_form' works with wide format", { + skip_if(is.null(covican$event_form), "covican$event_form not present") + res <- covican |> + rd_transform(final_format = "by_form", wide = TRUE) |> + suppressMessages() |> + suppressWarnings() + expect_true(is.list(res$data)) +}) + +test_that("which_event extracts a single event", { + skip_if(is.null(covican$event_form), "covican$event_form not present") + first_event <- covican$event_form$unique_event_name[1] + res <- rd_transform( + data = covican$data, + dic = covican$dictionary, + event_form = covican$event_form, + final_format = "by_event", + which_event = first_event + ) |> + suppressMessages() |> + suppressWarnings() + expect_true(unique(res$data$redcap_event_name) == first_event) +}) + +test_that("which_form extracts a single form", { + skip_if(is.null(covican$event_form), "covican$event_form not present") + first_form <- unique(covican$dictionary$form_name)[1] + res <- rd_transform( + data = covican$data, + dic = covican$dictionary, + event_form = covican$event_form, + final_format = "by_form", + which_form = first_form + ) |> + suppressMessages() |> + suppressWarnings() + expect_true(unique(res$data$redcap_event_name) == "baseline_visit_arm_1") +}) + +test_that("function handles repeated instruments", { + first_form <- unique(covican$dictionary$form_name)[1] + + data <- covican$data |> + dplyr::mutate(redcap_repeat_instrument = first_form, + redcap_repeat_instrument.factor = stringr::str_to_sentence(redcap_repeat_instrument)) + + skip_if(!"redcap_repeat_instrument" %in% names(data), "No repeated instruments in covican") + + res <- rd_transform(data = data, dic = covican$dictionary, event_form = covican$event_form) |> + suppressMessages() |> + suppressWarnings() + expect_true(is.list(res)) +}) diff --git a/tests/testthat/test-redcap_data.R b/tests/testthat/test-redcap_data.R new file mode 100644 index 0000000..c96bae1 --- /dev/null +++ b/tests/testthat/test-redcap_data.R @@ -0,0 +1,422 @@ +# Helper that writes a minimal exported R file (same approach as in your example) +write_redcap_r_export <- function(data, path) { + con <- file(path, "w") + # put two leading lines (function expects to skip 2 lines) + writeLines("## REDCap R export", con) + writeLines("## begin data", con) + writeLines("data <- ", con) + dput(data, con) + close(con) +} + +test_that("Exported-files path: successful import returns data, dictionary and event_form", { + # Sample data + sample_data <- as.data.frame(matrix(1:9, nrow = 3)) + names(sample_data)[1] <- "id" # will be renamed to record_id by the function + attr(sample_data[[2]], "label") <- "Test label" + + # Prepare small dictionary file (first row contains header names) + # The function reads csv with header=FALSE and uses first row as names + dic_rows <- data.frame( + field_name = c("id"), + form_name = c("demographics"), + field_type = c("text"), + stringsAsFactors = FALSE, + check.names = FALSE + ) + + # Event form mapping (valid — must NOT contain `event_name` column) + event_form <- data.frame(form = "demographics", other = "x", stringsAsFactors = FALSE) + + # Write files + tmp_r <- tempfile(fileext = ".R") + write_redcap_r_export(sample_data, tmp_r) + + tmp_dic <- tempfile(fileext = ".csv") + write.csv(dic_rows, tmp_dic, row.names = FALSE, quote = FALSE) + + tmp_event <- tempfile(fileext = ".csv") + write.csv(event_form, tmp_event, row.names = FALSE, quote = FALSE) + + out <- redcap_data(data_path = tmp_r, dic_path = tmp_dic, event_path = tmp_event) + + expect_true(is.list(out)) + expect_true("data" %in% names(out)) + expect_true("dictionary" %in% names(out)) + expect_true("event_form" %in% names(out)) + + # data first column must be renamed to record_id by function + expect_equal(names(out$data)[1], "record_id") +}) + +test_that("Unsupported dictionary extension errors", { + tmp_r <- tempfile(fileext = ".R") + sample_data <- as.data.frame(matrix(1:4, nrow = 2)) + write_redcap_r_export(sample_data, tmp_r) + + tmp_bad_dic <- tempfile(fileext = ".txt") + writeLines("garbage", tmp_bad_dic) + + expect_error( + redcap_data(data_path = tmp_r, dic_path = tmp_bad_dic), + "Unsupported dictionary format" + ) +}) + +test_that("Event file containing 'event_name' column triggers informative error", { + tmp_r <- tempfile(fileext = ".R") + sample_data <- as.data.frame(matrix(1:4, nrow = 2)) + write_redcap_r_export(sample_data, tmp_r) + + # Good dictionary + dic_rows <- data.frame( + field_name = c("id"), + form_name = c("demographics"), + field_type = c("text"), + stringsAsFactors = FALSE, + check.names = FALSE + ) + tmp_dic <- tempfile(fileext = ".csv") + write.csv(dic_rows, tmp_dic, row.names = FALSE, quote = FALSE) + + # Bad event file — has `event_name` column (simulates wrong file) + bad_event <- data.frame(event_name = "e1", stringsAsFactors = FALSE) + tmp_bad_event <- tempfile(fileext = ".csv") + write.csv(bad_event, tmp_bad_event, row.names = FALSE, quote = FALSE) + + expect_error( + redcap_data(data_path = tmp_r, dic_path = tmp_dic, event_path = tmp_bad_event), + "Invalid file provided in `event_path`" + ) +}) + +test_that("Longitudinal project without event_path issues a warning", { + # create exported file with a redcap_event_name column to trigger the longitudinal branch + sample_data <- data.frame(A = 1:2, redcap_event_name = c("ev1", "ev2"), stringsAsFactors = FALSE) + tmp_r <- tempfile(fileext = ".R") + write_redcap_r_export(sample_data, tmp_r) + + # dictionary + dic_rows <- data.frame( + field_name = c("id"), + form_name = c("demographics"), + field_type = c("text"), + stringsAsFactors = FALSE, + check.names = FALSE + ) + tmp_dic <- tempfile(fileext = ".csv") + write.csv(dic_rows, tmp_dic, row.names = FALSE, quote = FALSE) + + expect_warning( + res <- redcap_data(data_path = tmp_r, dic_path = tmp_dic), + "The project is longitudinal. Consider providing `event_path`" + ) + + # result should still be returned and contain dictionary + expect_true(is.list(res)) + expect_true("dictionary" %in% names(res)) +}) + +test_that("Descriptive fields are removed from dictionary", { + sample_data <- data.frame(id = 1:2) + tmp_r <- tempfile(fileext = ".R") + write_redcap_r_export(sample_data, tmp_r) + + # Create dictionary where one field is descriptive + dic_rows <- data.frame( + field_name = c("id"), + form_name = c("demographics"), + field_type = c("text"), + stringsAsFactors = FALSE, + check.names = FALSE + ) + tmp_dic <- tempfile(fileext = ".csv") + write.csv(dic_rows, tmp_dic, row.names = FALSE, quote = FALSE) + + out <- redcap_data(data_path = tmp_r, dic_path = tmp_dic) + expect_false("descfield" %in% out$dictionary$field_name) +}) + + +test_that("API branch: SSL error in labels fetch is converted to helpful stop message", { + # Make a stub that raises an error with SSL phrase + fake_ssl_error <- function(...) stop("SSL peer certificate: something went wrong", call. = FALSE) + + mockery::stub(redcap_data, "REDCapR::redcap_read", fake_ssl_error) + + expect_error( + redcap_data(uri = "https://api.example", token = "tok"), + "Unable to establish a secure connection" + ) +}) + +test_that("API branch: if labels retrieval returns zero rows a friendly error is thrown", { + empty_labels <- data.frame() # zero-row data.frame + fake_read_empty_labels <- function(redcap_uri = NULL, token = NULL, verbose = FALSE, raw_or_label = "label", raw_or_label_headers = NULL, export_data_access_groups = NULL, export_survey_fields = NULL, fields = NULL) { + return(list(data = empty_labels)) + } + mockery::stub(redcap_data, "REDCapR::redcap_read", fake_read_empty_labels) + + expect_error( + redcap_data(uri = "https://api.example", token = "tok"), + "Data retrieval is currently unavailable" + ) +}) + +test_that("API branch: when event_path is provided it warns and attempts to read it", { + # Reuse fake functions that return minimal data (labels + raw) and metadata + labels_df <- data.frame(record_id = 1L, stringsAsFactors = FALSE, check.names = FALSE) + data_api <- data.frame(record_id = "1", stringsAsFactors = FALSE, check.names = FALSE) + # Add a form_name column — redcap_data filters on form_name later + dic_api <- data.frame( + field_name = "record_id", + field_type = "text", + form_name = "form1", + stringsAsFactors = FALSE, + check.names = FALSE + ) + + fake_redcap_read2 <- function(redcap_uri = NULL, token = NULL, verbose = FALSE, raw_or_label = "raw", raw_or_label_headers = NULL, export_data_access_groups = NULL, export_survey_fields = NULL, fields = NULL) { + if (identical(raw_or_label, "label")) return(list(data = labels_df)) + if (identical(raw_or_label, "raw")) return(list(data = data_api)) + stop("unexpected") + } + fake_redcap_metadata_read2 <- function(...) list(data = dic_api) + + mockery::stub(redcap_data, "REDCapR::redcap_read", fake_redcap_read2) + mockery::stub(redcap_data, "REDCapR::redcap_metadata_read", fake_redcap_metadata_read2) + + # create a valid event CSV (not the events export) + event_form <- data.frame(form = "form1", stringsAsFactors = FALSE) + tmp_event <- tempfile(fileext = ".csv") + write.csv(event_form, tmp_event, row.names = FALSE) + + expect_warning( + out <- redcap_data(uri = "https://api.example", token = "tok", event_path = tmp_event), + "The event_path argument is not required when using an API connection." + ) + + expect_true("event_form" %in% names(out)) +}) + + +test_that("Unsupported data_path extension errors", { + tmp_bad <- tempfile(fileext = ".txt") + writeLines("nonsense", tmp_bad) + + expect_error( + redcap_data(data_path = tmp_bad, dic_path = tmp_bad), + "Unsupported file format" + ) +}) + +test_that("Unsupported event mapping extension errors", { + sample_data <- data.frame(id = 1:2) + tmp_r <- tempfile(fileext = ".R") + write_redcap_r_export(sample_data, tmp_r) + + dic_rows <- data.frame(field_name = "id", form_name = "f1", field_type = "text") + tmp_dic <- tempfile(fileext = ".csv") + write.csv(dic_rows, tmp_dic, row.names = FALSE) + + tmp_bad_event <- tempfile(fileext = ".json") + writeLines("{}", tmp_bad_event) + + expect_error( + redcap_data(data_path = tmp_r, dic_path = tmp_dic, event_path = tmp_bad_event), + "Unsupported event mapping format" + ) +}) + +test_that("Dictionary first field renamed to record_id if not already", { + sample_data <- data.frame(A = 1:2) + tmp_r <- tempfile(fileext = ".R") + write_redcap_r_export(sample_data, tmp_r) + + dic_rows <- data.frame(field_name = "not_record_id", form_name = "f1", field_type = "text") + tmp_dic <- tempfile(fileext = ".csv") + write.csv(dic_rows, tmp_dic, row.names = FALSE) + + out <- redcap_data(data_path = tmp_r, dic_path = tmp_dic) + expect_equal(out$dictionary$field_name[1], "record_id") +}) + +test_that("Empty strings are converted to NA in character columns", { + sample_data <- data.frame(id = 1:2, textcol = c("a", "")) + tmp_r <- tempfile(fileext = ".R") + write_redcap_r_export(sample_data, tmp_r) + + dic_rows <- data.frame(field_name = "id", form_name = "f1", field_type = "text") + tmp_dic <- tempfile(fileext = ".csv") + write.csv(dic_rows, tmp_dic, row.names = FALSE) + + out <- redcap_data(data_path = tmp_r, dic_path = tmp_dic) + expect_true(is.na(out$data$textcol[2])) +}) + +test_that("Variables not linked to event_form are removed with warning", { + sample_data <- data.frame(id = 1:2, extra = c("a", "b")) + tmp_r <- tempfile(fileext = ".R") + write_redcap_r_export(sample_data, tmp_r) + + dic_rows <- data.frame( + field_name = c("id", "extra"), + form_name = c("f1", "unlinked"), + field_type = "text" + ) + tmp_dic <- tempfile(fileext = ".csv") + write.csv(dic_rows, tmp_dic, row.names = FALSE) + + event_form <- data.frame(form = "f1") + tmp_event <- tempfile(fileext = ".csv") + write.csv(event_form, tmp_event, row.names = FALSE) + + expect_warning( + out <- redcap_data(data_path = tmp_r, dic_path = tmp_dic, event_path = tmp_event), + "removed since they are not linked" + ) + expect_false("extra" %in% names(out$data)) +}) + +test_that("API branch: filter_field missing record_id triggers helpful error", { + fake_error <- function(...) { + stop("REDCap's PHP code is likely trying to process too much text in one bite", call. = FALSE) + } + mockery::stub(redcap_data, "REDCapR::redcap_read", fake_error) + + expect_error( + redcap_data(uri = "https://api.example", token = "tok", filter_field = "fieldX"), + "record_id" + ) +}) + +test_that("API branch: observational data retrieval with zero rows errors", { + labels_df <- data.frame(record_id = 1) + fake_read <- function(redcap_uri = NULL, token = NULL, raw_or_label = "raw", ...) { + if (raw_or_label == "label") return(list(data = labels_df)) + if (raw_or_label == "raw") return(list(data = data.frame())) # zero rows + stop("unexpected") + } + fake_meta <- function(...) list(data = data.frame(field_name = "record_id", field_type = "text")) + + mockery::stub(redcap_data, "REDCapR::redcap_read", fake_read) + mockery::stub(redcap_data, "REDCapR::redcap_metadata_read", fake_meta) + + expect_error( + redcap_data(uri = "https://api.example", token = "tok"), + "Observational data retrieval is currently unavailable" + ) +}) + +test_that("API branch: descriptive fields are filtered from dictionary", { + labels_df <- data.frame(record_id = 1) + data_api <- data.frame(record_id = 1) + dic_api <- data.frame(field_name = "junk", field_type = "descriptive", form_name = "f1") + + fake_read <- function(redcap_uri = NULL, token = NULL, raw_or_label = "raw", ...) { + if (raw_or_label == "label") return(list(data = labels_df)) + if (raw_or_label == "raw") return(list(data = data_api)) + stop("unexpected") + } + fake_meta <- function(...) list(data = dic_api) + + mockery::stub(redcap_data, "REDCapR::redcap_read", fake_read) + mockery::stub(redcap_data, "REDCapR::redcap_metadata_read", fake_meta) + + out <- redcap_data(uri = "https://api.example", token = "tok") + expect_false("junk" %in% out$dictionary$field_name) +}) + +test_that("API branch: checkbox fields get factor versions", { + labels_df <- data.frame(record_id = 1) + data_api <- data.frame(record_id = 1, var___1 = "1") + dic_api <- data.frame(field_name = "var", field_type = "checkbox", form_name = "f1") + + fake_read <- function(redcap_uri = NULL, token = NULL, raw_or_label = "raw", ...) { + if (raw_or_label == "label") return(list(data = labels_df)) + if (raw_or_label == "raw") return(list(data = data_api)) + stop("unexpected") + } + fake_meta <- function(...) list(data = dic_api) + + mockery::stub(redcap_data, "REDCapR::redcap_read", fake_read) + mockery::stub(redcap_data, "REDCapR::redcap_metadata_read", fake_meta) + + out <- redcap_data(uri = "https://api.example", token = "tok") + expect_true("var___1.factor" %in% names(out$data)) +}) + +test_that("API branch: radio/dropdown fields produce factor versions", { + labels_df <- data.frame(record_id = 1) + data_api <- data.frame(record_id = 1, radio1 = "1") + dic_api <- data.frame( + field_name = "radio1", + field_type = "radio", + form_name = "f1", + choices_calculations_or_slider_labels = "1, Yes | 2, No", + stringsAsFactors = FALSE + ) + + fake_read <- function(redcap_uri = NULL, token = NULL, raw_or_label = "raw", ...) { + if (raw_or_label == "label") return(list(data = labels_df)) + if (raw_or_label == "raw") return(list(data = data_api)) + stop("unexpected") + } + fake_meta <- function(...) list(data = dic_api) + + mockery::stub(redcap_data, "REDCapR::redcap_read", fake_read) + mockery::stub(redcap_data, "REDCapR::redcap_metadata_read", fake_meta) + + out <- redcap_data(uri = "https://api.example", token = "tok") + expect_true("record_id.factor" %in% names(out$data)) + expect_true(is.factor(out$data$record_id.factor)) +}) + + +test_that("API branch: longitudinal without event_path fetches event_form via API", { + labels_df <- data.frame(record_id = 1, redcap_event_name = "ev1") + data_api <- labels_df + dic_api <- data.frame(field_name = "record_id", field_type = "text", form_name = "f1") + event_api <- data.frame(form = "f1") + + fake_read <- function(redcap_uri = NULL, token = NULL, raw_or_label = "raw", ...) { + if (raw_or_label == "label") return(list(data = labels_df)) + if (raw_or_label == "raw") return(list(data = data_api)) + stop("unexpected") + } + fake_meta <- function(...) list(data = dic_api) + fake_event <- function(...) list(data = event_api) + + mockery::stub(redcap_data, "REDCapR::redcap_read", fake_read) + mockery::stub(redcap_data, "REDCapR::redcap_metadata_read", fake_meta) + mockery::stub(redcap_data, "REDCapR::redcap_event_instruments", fake_event) + + out <- redcap_data(uri = "https://api.example", token = "tok") + expect_true("event_form" %in% names(out)) +}) + +test_that("Supplying both file and API arguments errors", { + tmp_r <- tempfile(fileext = ".R") + write_redcap_r_export(data.frame(id = 1), tmp_r) + + dic_rows <- data.frame(field_name = "id", form_name = "f1", field_type = "text") + tmp_dic <- tempfile(fileext = ".csv") + write.csv(dic_rows, tmp_dic, row.names = FALSE) + + expect_error( + redcap_data(data_path = tmp_r, dic_path = tmp_dic, uri = "u", token = "t"), + "Too many arguments" + ) +}) + +test_that("Supplying only uri or only token errors", { + expect_error( + redcap_data(uri = "https://api.example"), + "Both `uri` and `token` are required" + ) + + expect_error( + redcap_data(token = "tok"), + "Both `uri` and `token` are required" + ) +}) diff --git a/tests/testthat/test-utils_transform.R b/tests/testthat/test-utils_transform.R new file mode 100644 index 0000000..1d165f7 --- /dev/null +++ b/tests/testthat/test-utils_transform.R @@ -0,0 +1,78 @@ +test_that("recalculate works as expected", { + + dic <- tibble::tibble( + field_name = c("a", "b", "c"), + field_label = c("a", "b", "c"), + field_type = c("calc", "calc", "calc"), + text_validation_type_or_show_slider_number = "", + choices_calculations_or_slider_labels = c("1+1", "2+2", "error"), + branching_logic_show_field_only_if = "" + ) + + data <- tibble::tibble( + a = 1:3, + b = 2:4, + c = 3:5 + ) + + # Exclude one variable + res <- suppressWarnings(recalculate(data = data, dic = dic, exclude_recalc = "b")) + + expect_true("a_recalc" %in% names(res$data)) + expect_false("b_recalc" %in% names(res$data)) +}) + + +test_that("transform_checkboxes works correctly", { + dic <- tibble::tibble( + field_name = c("chk1", "chk2"), + field_type = c("checkbox", "checkbox"), + branching_logic_show_field_only_if = c(NA, "error") + ) + + data <- tibble::tibble( + chk1___1 = c("0", "1", "0"), + chk1___2 = c("1", "0", "1"), + chk2___1 = c("0", "0", "1") + ) + + res <- suppressWarnings(transform_checkboxes(data, dic, checkbox_na = TRUE)) + expect_true(all(c("chk1___1", "chk1___2") %in% names(res$data))) + expect_true(length(res$results) > 0) +}) + + +test_that("checkbox_names works and renames", { + data <- tibble::tibble(chk___1 = 1:2, chk___2 = 2:3) + dic <- tibble::tibble(field_name = "chk", field_label = "Check", choices_calculations_or_slider_labels = "0, No | 1, Yes", branching_logic_show_field_only_if = "") + labels <- c("chk___1" = "choice=No)", "chk___2" = "choice=Yes)") + + res <- suppressWarnings(checkbox_names(data, dic, labels)) + expect_true(any(grepl("chk_", names(res$data)))) + expect_true(all(c("chk_no", "chk_yes") %in% res$dic$field_name)) +}) + +test_that("split_event handles errors", { + data <- tibble(a=1:2, record_id=1:2) + dic <- tibble(field_name="a", field_type="text", form_name="f1") + event_form <- tibble(form="f1", unique_event_name="e1") + + expect_error(suppressWarnings(split_event(data, dic, event_form))) # Missing redcap_event_name +}) + +test_that("split_form works with wide and longitudinal", { + data <- tibble(record_id = 1:2, redcap_event_name="e1", a=1:2) + dic <- tibble(field_name="a", form_name="f1", field_type="text") + event_form <- tibble(form="f1", unique_event_name="e1") + + res <- suppressWarnings(split_form(data, dic, event_form, wide=TRUE)) + expect_true(is.list(res)) +}) + +test_that("to_factor converts correctly", { + data <- tibble(a = c("x","y"), a.factor=as.factor(a), redcap_event_name="e1", redcap_event_name.factor = "E1", redcap_repeat_instrument=NA, redcap_repeat_instrument.factor =NA) + dic <- tibble(field_name="a", choices_calculations_or_slider_labels="1, x | 2, y", field_type="radio", branching_logic_show_field_only_if = "") + + res <- suppressWarnings(to_factor(data, dic)) + expect_true(is.factor(res$data$a)) +}) diff --git a/vignettes/Data-reading-and-processing.Rmd b/vignettes/Data-reading-and-processing.Rmd deleted file mode 100644 index 77ea495..0000000 --- a/vignettes/Data-reading-and-processing.Rmd +++ /dev/null @@ -1,149 +0,0 @@ ---- -title: "REDCapDM - Data reading and processing" -output: - rmarkdown::html_vignette: - toc: true - toc_depth: 5 - number_sections: true -vignette: > - %\VignetteIndexEntry{REDCapDM - Data reading and processing} - %\VignetteEncoding{UTF-8} - %\VignetteEngine{knitr::rmarkdown} -editor_options: - chunk_output_type: inline ---- - - -```{r message=FALSE, warning=FALSE, include=FALSE} -rm(list = ls()) -library(REDCapDM) -library(kableExtra) -library(knitr) -library(dplyr) -library(magrittr) -library(purrr) -``` - -
- -This vignette provides a summary of the straightforward and common use of [REDCapDM](https://github.com/bruigtp/REDCapDM) to interact with [REDCap](https://www.project-redcap.org/) data. - -
- -# **Read data** - -To import data from [REDCap](https://www.project-redcap.org/), you can use the [`redcap_data()`](https://bruigtp.github.io/REDCapDM/reference/redcap_data.html) function, which provides two primary methods: importing data from local files or establishing an API connection. - -## **Local files** - -Before starting, ensure you have the required R and CSV files exported from [REDCap](https://www.project-redcap.org/), including the instrument-event mappings file. All these files should be in the same directory for the package to work correctly. - -Use the `data_path` and `dic_path` arguments to indicate the paths to your R data file and [REDCap](https://www.project-redcap.org/) project's dictionary file, respectively. If your [REDCap](https://www.project-redcap.org/) project is longitudinal, you'll additionally need to supply the event-form mapping file using the `event_path` argument. - -```{r message=FALSE, warning=FALSE, comment=NA, eval=FALSE} -dataset <- redcap_data(data_path = "C:/Users/username/example.r", - dic_path = "C:/Users/username/example_dictionary.csv", - event_path = "C:/Users/username/events.csv") -``` - -## **API connection** - -If you opt for an API connection, you can provide the `uri` (uniform resource identifier) and `token` (user-specific password) for your [REDCap](https://www.project-redcap.org/) project. This method will automatically retrieve the event-form mapping if your project is longitudinal. - -Use both arguments to set up the API connection and import the data: - -```{r eval=FALSE, message=FALSE, warning=FALSE, comment=NA} -dataset_api <- redcap_data(uri = "https://redcap.idibell.cat/api/", - token = "55E5C3D1E83213ADA2182A4BFDEA") -``` - -## **Output** - -The [`redcap_data()`](https://bruigtp.github.io/REDCapDM/reference/redcap_data.html) function returns a list with three elements: - -- Imported data: Contains the data from your [REDCap](https://www.project-redcap.org/) project - -- Dictionary: Provides information about variables and their associated labels. - -- Event-form mapping (only available for longitudinal projects): Describes the correspondence between events and forms in your project. - -
-
- -# **Process data** - -Having successfully imported our data into R, you can now use the [`rd_transform()`](https://bruigtp.github.io/REDCapDM/reference/rd_transform.html) function to start processing the data. - -This function performs several transformations: - -- Elimination of selected variables - -- Elimination of variables containing certain patterns such as '_complete' and '_timestamp' - -- Recalculation of [REDCap](https://www.project-redcap.org/) calculated fields - -- Checkbox transformation by changing their names to the names of their options - -- Replacement of the original variables with their factor version - -- Branching logic transformation, converting [REDCap](https://www.project-redcap.org/) logic to R logic. - - -## **Standard** - -The only essential elements that must be supplied are the dataset to be transformed and the corresponding dictionary. In the case of a longitudinal project, it is advisable to also specify the event form dataset to take full advantage of this function. These elements can be directly specified using the output of the [`redcap_data()`](https://bruigtp.github.io/REDCapDM/reference/redcap_data.html) function or separately using distinct arguments: - -```{r message=FALSE, warning=FALSE, comment=NA} -#Option A: list object -covican_transformed <- rd_transform(covican) - -#Option B: separately with different arguments -covican_transformed <- rd_transform(data = covican$data, - dic = covican$dictionary, - event_form = covican$event_form) -``` - -This function returns a list containing the transformed dataset, dictionary, event_form and the results of each transformation. To retrieve the results of the transformation, use the following code block: - -```{r message=FALSE, warning=FALSE, comment=NA} -#Print the results of the transformation -covican_transformed$results -``` - -## **By event** - -If the [REDCap](https://www.project-redcap.org/) project is longitudinal, you can further adjust the structure of the transformed dataset. For example, it can be split by event: - -```{r message=FALSE, warning=FALSE, comment=NA} -dataset <- rd_transform(covican, - final_format = "by_event") -``` - -Where the transformed dataset is a tibble object, containing data frames for each event in the [REDCap](https://www.project-redcap.org/) project. - -```{r message=FALSE, warning=FALSE, comment="#>", collapse = TRUE} -dataset$data -``` - -## **By form** - -Or, alternatively, it can be split by form: - -```{r message=FALSE, warning=FALSE, comment=NA} -dataset <- rd_transform(covican, - final_format = "by_form") -``` - -Where the tibble object is composed by data frames corresponding to each form in the [REDCap](https://www.project-redcap.org/) project. - -```{r message=FALSE, warning=FALSE, comment="#>", collapse = TRUE} -dataset$data -``` - -
-
- -**For more information, consult the complete vignette available at: https://bruigtp.github.io/REDCapDM/articles/REDCapDM.html** - -
-
diff --git a/vignettes/REDCapDM.Rmd b/vignettes/REDCapDM.Rmd index 721dd03..3c0f2f9 100644 --- a/vignettes/REDCapDM.Rmd +++ b/vignettes/REDCapDM.Rmd @@ -21,7 +21,6 @@ library(REDCapDM) library(kableExtra) library(knitr) library(dplyr) -library(magrittr) library(purrr) ``` @@ -30,32 +29,71 @@ library(purrr) # **Introduction** -The REDCapDM package allows users to read data exported directly from REDCap or via API connection. It also allows users to process the previously downloaded data, create reports of queries such as outliers or missing values and track the identified queries. +The REDCapDM package provides a comprehensive toolkit for managing data exported from REDCap. It supports both importing REDCap data (from files or via API), transforming and cleaning the data according to the project’s dictionary and logic, and generating query reports for data validation. In particular, REDCapDM can identify missing or out-of-range values and track changes in identified queries across data versions.

# **Functions** -Functions included in the package: +All main functions are listed below (and described in detail in the examples): -- `redcap_data()`: reads data. +## Import data -- `rd_transform()`: processes data. +- `redcap_data()`: Read REDCap data into R. -- `rd_rlogic()`: transforms REDCap logic into R logic. +## Process data -- `rd_insert_na()`: allows a manual entry of a missing value in specific variables using a filter. +- `rd_dates()`: Standardize date and datetime fields. -- `rd_query()`: identifies queries. +- `rd_delete_vars()`: Remove specified variables (by name or pattern). -- `rd_event()`: identifies missing events. +- `rd_recalculate()`: Recompute calculated fields and compare with REDCap values. -- `check_queries()`: tracks queries. +- `rd_factor()`: Replace numeric multiple-choice columns with their factor version. + +- `rd_checkbox()`: Expand checkbox responses with custom labels and rename `var___1` columns (REDCap style) to `var_option`. + +- `rd_split()`: Split dataset by form or event. + +- `rd_insert_na()`: Manually set specified variables to missing based on a logical filter. + +- `rd_rlogic()`: Translate REDCap branching or calculation logic into R syntax. + +- `rd_dictionary()`: Update dictionary (translation of REDCap logic into R syntax) to reflect transformed data and logic. + +Or we can use all these functions at once: + +- `rd_transform()`: One-step pipeline to clean and preprocess the raw REDCap data. + +## Queries + +- `rd_query()`: Apply expressions to identify data queries/issues. + +- `rd_event()`: Report missing/incomplete events per record (longitudinal). + +- `check_queries()`: Compare two query reports to track changes made. + +- `rd_export`: Export query/report tables to an Excel (.xlsx) file.

+# **Installation** + +The release version can be installed from CRAN: + +```{r eval=FALSE} +install.packages("REDCapDM") +``` + +The development version can be installed from GitHub: + +```{r eval=FALSE} +install.packages("remotes") # Run this line if the 'remotes' package isn't installed already. +remotes::install_github("bruigtp/REDCapDM") +``` + # **Built-in dataset** For the following examples, we will use a random sample of the COVICAN study which is included in the package. COVICAN is an international, multicentre cohort study of cancer patients with COVID-19 to describe the epidemiology, risk factors, and clinical outcomes of co-infections and superinfections in onco-hematological patients with COVID-19. @@ -63,6 +101,8 @@ For the following examples, we will use a random sample of the COVICAN study whi We can load the built-in dataset by typing: ```{r message=FALSE, warning=FALSE, comment=NA} +library(REDCapDM) + data(covican) ``` @@ -98,37 +138,37 @@ descr <- c("Identifier of each record", "", "Indicator of leukemia or lymphoma", "No ; Yes", "Indicator of acute leukemia", "No ; Yes") -vars <- data.frame("Name" = names(covican$data %>% dplyr::select(record_id:acute_leuk)), +vars <- data.frame("Name" = names(covican$data |> dplyr::select(record_id:acute_leuk)), "Description" = descr[seq(1, length(descr), 2)], "Categories" = descr[seq(2, length(descr), 2)]) -kable(vars) %>% - kableExtra::row_spec(0, bold=TRUE) %>% +kable(vars) |> + kableExtra::row_spec(0, bold=TRUE) |> kableExtra::kable_styling(full_width = F) ```
-# **Examples** +# **Usage** -The package structure can be divided into three main components: reading raw data, processing data and identifying queries. Typically, after collecting data in REDCap, we will have to follow this three components in order to have a final validated dataset for analysis. We will provide a complete user guide on how to perform each one of these steps using the package's functions. For the processing of the data and query identification, we will use the built-in dataset as an example. +The package structure can be divided into three main components: reading raw data, processing data and identifying queries. Typically, after collecting data in REDCap, we will have to follow these three components in order to have a final validated dataset for analysis. We will provide a complete basic user guide on how to perform each one of these steps using the package's functions. For the processing of the data and query identification, we will use the `covican` built-in dataset as an example. ## **Read data** ### **redcap_data** -The `redcap_data()` function allows users to easily import data from a REDCap project into R for analysis. +The `redcap_data()` function allows users to easily import data from a REDCap project into R. -To read exported data from REDCap, use the arguments `data_path` and `dic_path` to, respectively, describe the path of the R file and the REDCap project's dictionary: +In order to read exported data from REDCap, we first need to download the data and dictionary from the REDCap project in R format. We can then use the arguments `data_path` and `dic_path` to designate the local path where we have stored the R file and the dictionary from the REDCap project: ```{r message=FALSE, warning=FALSE, comment=NA, eval=FALSE} dataset <- redcap_data(data_path = "C:/Users/username/example.r", dic_path = "C:/Users/username/example_dictionary.csv") ``` -Note: The R and CSV files exported from REDCap must be located in the same directory. +> Note: The R and data CSV file exported from REDCap must be located in the same directory. -If the REDCap project is longitudinal (contains more than one event) then a third element should be specified with the correspondence of each event with each form of the project. This csv file can be downloaded in the REDCap of the project following these steps: _Project Setup_ < _Designate Instruments for My Events_ < _Download instrument-event mappings (CSV)_. +If the REDCap project is longitudinal (contains more than one event) then a third element should be specified with the correspondence of each event with each form of the project. This csv file can be downloaded in the REDCap of the project following these steps: _Project Setup_ < _Designate Instruments for My Events_ < _Download instrument-event mappings (CSV)_. Then, it has to be specified using the argument `event_path`: ```{r message=FALSE, warning=FALSE, comment=NA, eval=FALSE} dataset <- redcap_data(data_path = "C:/Users/username/example.r", @@ -136,7 +176,7 @@ dataset <- redcap_data(data_path = "C:/Users/username/example.r", event_path = "C:/Users/username/events.csv") ``` -Note: if the project is longitudinal and the event-form file is not provided using the `event_path` argument, some steps of the processment can not be performed. +> Note: if the project is longitudinal and the event-form file is not provided using the `event_path` argument, some steps of the processment can not be performed. Another way to read data exported from a REDCap project is using an API connection. To do this, we can use the arguments `uri` and `token` which respectively refer to the uniform resource identifier of the REDCap project and the user-specific string that serves as the password: @@ -147,249 +187,336 @@ dataset_api <- redcap_data(uri = "https://redcap.idibell.cat/api/", In this case, there is no need to specify the event-form file since the function will download it automatically using the API connection, if the project is longitudinal. -**Warning**: Please keep in mind that the API token gives you special access to the REDCap project and that it should not be shared with other people. +> **Warning**: Please keep in mind that the API token gives you special access to the REDCap project and that it should not be shared with other people. -This function returns a list with 3 elements (imported data, dictionary and event-form mapping) which can then be used for further analysis or visualization. +The `redcap_data()` function returns a list with three elements: imported data, dictionary and event-form mapping(if included). ## **Process** -### **rd_transform** +Given any data imported from REDCap with `redcap_data()`, this would be the pipeline of an entire processing workflow: -The main function involved in the processing of the data is `rd_transform()`. This function is used to process the REDCap data read into R using the `redcap_data()`, as described above. Using the arguments of the function we can perform different type of transformations of our data. +```{r message=FALSE, warning=FALSE, eval = FALSE, comment="#>", collapse = TRUE} +data |> + rd_delete_vars(delete_pattern = c("_complete", "_timestamp") |> + rd_dates() |> + rd_recalculate() |> + rd_checkbox() |> + rd_factor() |> + rd_dictionary() |> + rd_split(by = "event") # use "form" if not longitudinal +``` -As previously stated, we will use the built-in dataset `REDCapDM::covican` as an example. +All functions are optional and should only be used at the user's discretion when necessary. The order of some functions can also be exchanged. For example, for `covican` there are no variables to delete and dates are already processed, so the pipeline would be simplified: -#### *Data transformation* +```{r message=FALSE, warning=FALSE, comment="#>", collapse = TRUE} +covican_transformed <- covican |> + rd_recalculate() |> + rd_checkbox() |> + rd_factor() |> + rd_dictionary() |> + rd_split(by = "event") -The only necessary elements that must be provided are the dataset to be transformed and the corresponding dictionary. If the project is longitudinal, as in the case of `REDCapDM::covican`, also the event-form dataset should be specified. These elements can be specified directly using the output of the `redcap_data()` function or separately in different arguments. +covican_transformed$results +``` -```{r message=FALSE, warning=FALSE, comment=NA} -#Option A: list object -covican_transformed <- rd_transform(covican) +All the functions that can be used in each step of a processing workflow are detailed below: -#Option B: separately with different arguments -covican_transformed <- rd_transform(data = covican$data, - dic = covican$dictionary, - event_form = covican$event_form) +### **rd_delete_vars** -#Print the results of the transformation -covican_transformed$results -``` +This function removes unwanted variables from both a REDCap dataset and its dictionary. This is especially useful for eliminating automatically generated fields such as form completion flags (`*_complete`) or timestamps (`*_timestamp`). -This function will return a list with the transformed dataset, dictionary, event_form and the output of the results of the transformation. +You can delete variables either by specifying their exact names or by using regular expression patterns: -As we can see, there are several steps in the transformation: +```{r} +# Option A: delete by variable name +covican_deleted <- covican |> + rd_delete_vars(vars = c("potassium", "leuk_lymph")) -
    -
  1. Elimination of variables: we can specify any variable in the dataset which we want to remove using the argument `delete_vars`, as explained later.
    2. +# Option B: delete by regex pattern +covican_deleted <- covican |> + rd_delete_vars(pattern = c("_complete$", "_timestamp$")) +``` -
  2. Elimination of variables containing some pattern: by default, the pattern that the function looks for is '_complete' and '_timestamp'. We can specify any other pattern using the argument `delete_pattern`, as explained later.
    3. +When variables are deleted: -In this case, we do not have any variable with the pattern '_complete' and '_timestamp' since the built-in dataset only contains a sample of the variables of the project. All REDCap projects, when downloaded, contain one variable with the pattern '_complete' for each form indicating if the form has been marked as incomplete/unverified/completed. Also, if the project contains some survey then variables ending with '_timestamp' are also generated automatically. In general, we do not need this information so these variables are removed by default. +- They are removed from both the dataset and dictionary. -
  3. Recalculation of REDCap calculated fields: it finds all the calculated fields and recalculates them using the REDCap logic specified in the calculation field translated into R. The recalculated variable is saved as the original name adding '_recalc' at the end. It can happen that the logic found contains some specific smart-variables or other complex structures which the function is not able to transcribe. With the summary found in `results` we can see how many calculated fields have been found, if they have been transcribed and, if that is the case, if the recalculated variable is equal to the original one.
    4. +- Factor versions of deleted variables (if present) are also removed. -Note: If the REDCap project is longitudinal and the event-form is not specified, this step will not be executed. +
    -In the example, we can see how there are two REDCap calculated fields, both have been transcribed successfully and the recalculation of the age does not match the original calculated variable from REDCap. -
  4. Checkbox transformation: by default, it changes the names of the checkboxes to the name of its corresponding option and the name of their labels to 'No/Yes'. If we want to specify another pair of label names we can specify them using the `checkbox_labels` argument as we will see. Furthermore, if the checkbox contains a branching logic, when this logic evaluated returns a missing value (some of the variables specified in it are missing) the values of the checkbox will be set to missing.
    5. +### **rd_dates** -Note: If the REDCap project is longitudinal and the event-form is not specified, the evaluations of the branching logic will not be done. +This function is designed to process and standardize `date` and `datetime` fields in a REDCap dataset. In REDCap projects, date and datetime fields can sometimes be stored as character strings, which can make analyses difficult. This function detects which fields should be dates/datetimes from the REDCap dictionary and converts them to `Date` and `POSIXct`, respectively. -For example, let's explain the transformation that undergo the variables corresponding to the checkbox field of the type of underlying disease. The variables were named originally as _type_underlying_disease___0_ and _type_underlying_disease___1_ although the name of the options are 'Haematological cancer' and 'Solid tumour'. Thus, in the transformed dataset, the names are converted to _type_underlying_disease_haematological_cancer_ and _type_underlying_disease_solid_tumour_. Then, since this checkbox variable does not have a branching logic, the variable is advised to be reviewed by the user in the `results`, as seen above. When reviewed we could use an additional function `rd_insert_na()` to insert the necessary missing values into this variable, as we will explain later. If a branching logic was found for this variable, `rd_transform` will insert automatically the missing values when the logic is not satisfied and no further transformation will be needed. +```{r message=FALSE, warning=FALSE, comment="#>", collapse = TRUE} +covican_dates <- covican |> + rd_dates() +``` +Quick verification example: -
  5. Replacement of the original variable by its factor version: REDCap creates two versions of the variables in the dataset for multiple-choice fields: a numerical one with the number that corresponds to each category and a factor one containing the labels of each category. In this step, we will replace the original variables with their factor versions, except for _redcap_event_name_ and _redcap_data_access_group_, for which we will keep both versions. We can specify other variables that we do not want to transform to factor using the argument `exclude_to_factor` which we will see later.
    6. +```{r message=FALSE, warning=FALSE, comment="#>", collapse = TRUE} +# Simulate a character date since covican already has the dates in the correct format +covican_dates <- covican +covican_dates$data <- covican_dates$data |> + dplyr::mutate(d_birth = as.character(d_birth)) +# Check class before conversion -
  6. Transformation of the branching logic: by default, every branching logic contained in the dictionary is presented in REDCap logic. In this step, we will convert each branching logic into R logic in order to apply this information when needed. For example, we will use it to properly identify missing values in variables with a branching logic, as we will see later in the vignette.
    7. +class(covican_dates$data$d_birth) +# Check class after conversion +covican_dates <- covican_dates |> + rd_dates() +class(covican_dates$data$d_birth) +``` -
+After this transformation, all `date` and `datetime` variables are standardized and ready for analysis in R. -#### *Data transformation and classification by event* +
-Additionally, we can change the final structure of the transformed dataset. For example, we can split it by each event. This can be done by specifying in the `final_format` argument that we want our data to be split by event. +### **rd_recalculate** -```{r message=FALSE, warning=FALSE, comment=NA} -dataset <- rd_transform(covican, - final_format = "by_event") +This function identifies calculated fields in a REDCap project, translates their calculation logic into R, recalculates the values, and compares the results with the values stored in REDCap. -#To print the results -dataset$results -``` +It then produces a structured report that helps users detect discrepancies between REDCap’s stored calculations and the values recalculated in R. -Now, a final step in the transformation has been added, which consists in splitting the data according to the events in the study. So, now the transformed dataset found in the output of the function is a tibble object with as many data frames as events there are in the REDCap project: +```{r} +covican_recalc <- covican |> + rd_recalculate() -```{r message=FALSE, warning=FALSE, comment="#>", collapse = TRUE} -dataset$data +# Print recalculation results +covican_recalc$results ``` -The column `df` of the nested dataframe is a list containing the data corresponding to each event. Also the variables of the forms that are found in each event are reported in the column `vars`. +The `results` object includes: -Note: If the REDCap project is longitudinal and the event-form is not specified, this transformation is not posible. +- A summary report outlining the total number of calculated fields, how many were successfully transcribed into R, and how many showed differences between the REDCap values and the recalculated ones. -#### *Data transformation and classification by form* +- A field-level report listing each calculated field, whether the logic was successfully converted to R, and whether the recalculated values match the originals. -Another option is to split the data by the forms found in the REDCap project. We will use also the `final_format` argument to specify that we want to split data by form: +You can also exclude specific fields from recalculation (e.g., complex multi-event calculations) to reduce computation time and avoid unnecessary warnings. -```{r message=FALSE, warning=FALSE, comment=NA} -dataset <- rd_transform(covican, - final_format = "by_form") +```{r} +# Exclude specific variables from recalculation +covican_recalc <- covican |> + rd_recalculate(exclude = c("screening_fail_crit", "resp_rate")) -#To print the results -dataset$results +covican_recalc$results ``` -As before, a final step in the transformation has been added, which is to split the data according to the forms in the study. Thus, the transformed dataset will now be a tibble object with as many data frames as forms there are in the REDCap project: +After running this function: -```{r message=FALSE, warning=FALSE, comment="#>", collapse = TRUE} -dataset$data -``` +- A new variable with the suffix `_recalc` is added to the dataset, placed immediately after the original variable and containing the recalculated values. -Note: If the REDCap project is longitudinal and the event-form is not specified, this transformation is not posible. +- The data dictionary is updated with a corresponding entry, where the original variable label is extended with `"(Recalculated)"` to make these fields easy to identify. -#### *Additional arguments* +
-There are other arguments which can be used to customize some of the transformation steps that the function performs by default: +### **rd_checkbox** -
+This function cleans and restructures REDCap checkbox fields. It converts the default `"Unchecked/Checked"` categories of checkbox responses created by REDCap into user-specified labels (default `"No"/"Yes"`) and renames the `varname___code` variables (original REDCap structure) to readable names based on the text of the checkbox options. Additionally, it updates the dictionary to match the new variable names. This includes choices, calculations, and branching logic. -checkbox_labels: specifies the name of the categories for the checkbox variables. Default is 'No/Yes', but we can change it to 'N/Y': +```{r} +# Default transformation: "No"/"Yes" labels & renamed variables +cb <- covican |> + rd_checkbox() -```{r message=FALSE, warning=FALSE, comment=NA} -dataset <- rd_transform(covican, - checkbox_labels = c("N", "Y")) +str(cb$data$underlying_disease_hemato_acute_myeloid_leukemia) ``` -
+For example, consider the checkbox field of the type of underlying disease present in the `covican` dataset. Originally, the variables were named `type_underlying_disease__0` and `type_underlying_disease__1`, while the option labels were ‘Haematological cancer’ and ‘Solid tumour’. After running the function, the variables are renamed to `type_underlying_disease_haematological_cancer` and `type_underlying_disease_solid_tumour`, reflecting the option text in a readable format.. -checkbox_na: logical argument involved in the transformation of checkbox variables. For checkbox variables that have a branching logic specified, when the logic is missing the values of the checkbox will be always converted to missing. Additionally, if this argument is true then also when the branching logic isn't satisfied their values will be converted to missing. +To preserve the original REDCap-style names (e.g., `varname___1`, `varname___2`) instead of renaming variables based on option text: -```{r message=FALSE, warning=FALSE, comment=NA} -dataset <- rd_transform(covican, - checkbox_na = TRUE) +```{r} +# use the argument checkbox_names to choose the final format of the variable names +cb <- covican |> + rd_checkbox(checkbox_names = FALSE) + +str(cb$data$underlying_disease_hemato___1) ``` -
+If a checkbox field has a branching logic, the function will not modify any values. However, you can use the `na_logic` argument, which accepts the following options: -exclude_recalc: specifies the name of the variables that we do not want to be recalculated. For example, if we do not want to recalculate the variable _age_: +- `"none"` (default): do not set `NA` based on branching logic during transform. -```{r message=FALSE, warning=FALSE, comment=NA} -dataset <- rd_transform(covican, - exclude_recalc = "age") -``` +- `"missing"`: set `NA` only where the branching logic evaluation is `NA`. -This argument is useful to reduce the time of execution of the function. For calculated fields with complex logic involving variables in different events the recalculation operation may be time consuming, so we can prevent the function to recalculate them with this argument. +- `"eval"`: set `NA` where the branching logic evaluates to `FALSE` (i.e., logic not satisfied or missing). -
+```{r} +cb <- covican |> + rd_checkbox(na_logic = "eval") +``` -exclude_to_factor: specifies the name of the variables that we do not want to transform into a factor. For example, if we want the variable _dm_ to keep its original numeric version: +By default, checkbox factors are labeled `"No"` and `"Yes"`, but you can specify alternative labels: -```{r message=FALSE, warning=FALSE, comment=NA} -dataset <- rd_transform(covican, - exclude_to_factor = "dm") +```{r} +cb <- covican |> + rd_checkbox(checkbox_labels = c("Absent", "Present")) + +str(cb$data$underlying_disease_hemato_acute_myeloid_leukemia) ```
-delete_vars: every variable specified in this argument will be removed from the dataset. For example, we can change the argument to remove the date of birth variable from the dataset: -```{r message=FALSE, warning=FALSE, comment=NA} -dataset <- rd_transform(covican, - delete_vars = "d_birth") +### **rd_factor** + +This function converts categorical variables in a REDCap dataset into R factors by replacing each original variable (numeric version) with its corresponding `.factor` version created by REDCap. + +```{r} +factored <- covican |> + rd_factor() + +# Checking class of the variable +str(factored$data$available_analytics) ``` -
+If you need to keep certain variables in their raw form, you can list them in the `exclude` argument. This prevents those variables from being replaced (including their `.factor` version) while still allowing the rest of the dataset to be converted. -delete_pattern: every variable containing the strings specified in this argument will be removed from the dataset. By default, the value of `delete_pattern` is '\_complete'. For example, we can change the argument to remove the inclusion and exclusion criteria variables from the dataset (variables that contain 'inc\_' and 'exc\_' in their names): +```{r} +factored <- covican |> + rd_factor(exclude = c("available_analytics", "urine_culture")) -```{r message=FALSE, warning=FALSE, comment=NA} -dataset <- rd_transform(covican, - delete_pattern = c("inc_", "exc_")) +# Checking class of both versions of the variable +str(covican$data$available_analytics) +str(covican$data$available_analytics.factor) ``` +> Note: the function automatically excludes these system variables from conversion: `redcap_event_name`, `redcap_repeat_instrument`, `redcap_data_access_group`. These variables are retained as-is to avoid interfering with longitudinal event mappings or user access groups. + +After conversion only the cleaned factor variables remain in the dataset, the original numeric version of those variables is dropped. +
-which_event: in the transformation by event explained earlier, we can specify whether we want to keep only one out of all the events in the dataset. For example, if we only want to keep the baseline visit: +### **rd_dictionary** -```{r message=FALSE, warning=FALSE, comment=NA} -dataset <- rd_transform(covican, - final_format = "by_event", - which_event = "baseline_visit_arm_1") +When working with REDCap exports, the data dictionary contains field metadata, branching logic, and calculation rules written in REDCap logic. The `rd_dictionary()` function refreshes branching logic and calculations, translating them from REDCap logic into R logic, and ensures the dictionary remains consistent with the cleaned dataset. + +```{r} +# Update dictionary after cleaning +dict_result <- covican |> + rd_factor() |> + rd_checkbox() |> + rd_dictionary() ``` +When we transform the dictionary: + +- Updates branching logic expressions so they match factor labels rather than numeric codes. + +- Converts calculations and logic into R-friendly expressions. + +- Reports any fields where branching logic or calculations could not be converted. +
-which_form: in the transformation by form explained earlier, we can specify whether we want to keep only one of the forms. For example, if we only want to keep the demographic form: +### **rd_split** -```{r message=FALSE, warning=FALSE, comment=NA} +After preparing your dataset, you may want to work with only one form or one event at a time. The `rd_split()` function separates your dataset accordingly. + +- **By form** -dataset <- rd_transform(covican, - final_format = "by_form", - which_form = "demographics") +For non-longitudinal projects (or longitudinal projects with an `event_form` mapping), you can split the dataset into smaller datasets based on forms. -data <- dataset$data +```{r} +forms_data <- covican |> + rd_split(by = "form") -names(data) +forms_data$data ``` -
+If repeated entries exist, you can reshape the data into wide format: -wide: in the transformation by form, we can specify that we want each of the split datasets to be in a wide format. This is useful if the form appears in more than one event (or in a repeated event). Then, we will only have one row per patient and all the variables of the form will be in columns repeated by each event in the order that the events appear in REDCap. For example, if we want to keep only the laboratory findings in a wide format we can do: +```{r} +forms_data <- covican |> + rd_split(by = "form", wide = TRUE) +``` -```{r message=FALSE, warning=FALSE, comment="#>", collapse = TRUE} -dataset <- rd_transform(covican, - final_format = "by_form", - which_form = "laboratory_findings", - wide = TRUE) +> Note: For longitudinal projects, the column events shows the number of events in each form. -head(dataset$data) -``` +- **By event** -
+For longitudinal projects, you can also split the data by event. The function uses the `event_form` mapping to assign variables correctly to each event: -### **rd_rlogic** +```{r} +events_data <- covican |> + rd_split(by = "event") + +events_data$data +``` -This function transforms the REDCap logic into logic that can be evaluated in R. It returns both the transformed logic and the result of the evaluation of the logic. This function is used in the `rd_transform()` to recalculate the calculated fields and convert the branching logics, but it may also be useful to use it in other circunstances. Let's see how it transforms the logic of one of the calculated fields in the built-in dataset: +If you want to extract only one form or event, use the `which` argument: -```{r message=FALSE, warning=FALSE, comment=NA} -logic_trans <- rd_rlogic(covican, - logic = "if([exc_1]='1' or [inc_1]='0' or [inc_2]='0' or [inc_3]='0',1,0)", - var = "screening_fail_crit") +```{r} +# Example by form +baseline_data <- covican |> + rd_split(by = "form", which = "demographics") -str(logic_trans) +head(baseline_data$data) ```
### **rd_insert_na** -This function sets some values of a variable to missing if a certain logic is fulfilled. It can be used as a complementary function for `rd_transform()`, for example, to change the values of those checkboxes that do not have a branching logic, as mentioned earlier. For instance, we can perform a raw transformation of our data, as in section 4.2.1.1, and then use this function to set the values of the checkbox _type_underlying_disease_haematological_cancer_ to missing when the age is less than 65 years old: +This is an auxiliar/bonus function that can be used to set some values of a variable(s) to missing if a certain logic is fulfilled. It can be used, for example, to insert missings on those checkboxes that do not have a branching logic, as mentioned earlier. For instance, we can transform the checkboxes with the `rd_checkbox()` function and then use this function to set the values of the checkbox _type_underlying_disease_haematological_cancer_ to missing when the age is less than 65 years old: ```{r message=FALSE, warning=FALSE, comment=NA} -#Raw transformation of the data: -dataset <- rd_transform(covican) - -data <- dataset$data +cb <- covican |> + rd_checkbox() #Before inserting missings -table(data$type_underlying_disease_haematological_cancer) +table(cb$data$type_underlying_disease_haematological_cancer) -#Run the function -data2 <- rd_insert_na(dataset, - event_form = covican$event_form, - vars = "type_underlying_disease_haematological_cancer", - filter = "age < 65") +#Run with this function +cb2 <- covican |> + rd_checkbox() |> + rd_insert_na(vars = "type_underlying_disease_haematological_cancer", + filter = "age < 65") #After inserting missings -table(data2$type_underlying_disease_haematological_cancer) +table(cb2$data$type_underlying_disease_haematological_cancer) ``` -Recall that both the variable to be transformed (_age_) and the variable included in the filter (_type_underlying_disease_haematological_cancer_) are in the same event. In the contrary, if the variable to be transformed and the filter didn't have any event in common then the transformation would give an error. Furthermore, if the variable to be transformed was in more events than the filter, only the rows of the events in common would be converted. +> Note that both the variable to be transformed (`age`) and the variable included in the filter (`type_underlying_disease_haematological_cancer`) are in the same event. If the variable to be transformed and the filter didn't have any event in common then the transformation would give an error. Furthermore, if the variable to be transformed was in more events than the filter, only the rows of the events in common would be converted.
+### **rd_rlogic** + +This is also an auxiliar/bonus function that transforms the REDCap logic into logic that can be evaluated in R. It returns both the transformed logic and the result of the evaluation of the logic in R. This function is used internally in multiple functions, for example, `rd_dictionary()`. + +> This function only returns the transformed logic, so it has to be used outside the transform workflow. + +Let's see how it transforms the logic of one of the calculated fields in the built-in dataset: + +```{r message=FALSE, warning=FALSE, comment=NA} +logic_trans <- covican |> + rd_rlogic(logic = "if([exc_1]='1' or [inc_1]='0' or [inc_2]='0' or [inc_3]='0',1,0)", + var = "screening_fail_crit") + +str(logic_trans) +``` + +
+ +### **rd_transform** + +Alternatively, you can do all these steps at once using the `rd_transform()` function: + +```{r message=FALSE, warning=FALSE, comment=NA} +covican_transformed <- rd_transform(covican) + +#Print the results of the transformation +covican_transformed$results +``` + +Using the arguments of the function we can perform all the different type of transformations described until now. + ## **Queries** Queries are very important to ensure the accuracy and reliability of a REDCap dataset. The collected data may contain missing values, inconsistencies, or other potential errors that need to be identified in order to correct them later. @@ -411,8 +538,8 @@ example <- rd_query(covican_transformed, ``` ```{r echo=FALSE, message=FALSE, warning=FALSE, comment=NA} -kable(head(example$queries)) %>% - kableExtra::row_spec(0, bold = TRUE) %>% +kable(head(example$queries)) |> + kableExtra::row_spec(0, bold = TRUE) |> kableExtra::kable_styling() example$results @@ -478,7 +605,7 @@ example$results The total number of missing values changes when we use the `filter` argument, the variable _potassium_ now presents 21 missing values instead of the previous 31 cases identified. This means that we were identifying 10 missing values in which _available_analytics_ did not have the value _Yes_ and, therefore, should not be considered as missing values. -Note: The `filter` argument is treated as a vector, which means that we can add a filter to each specified variable. Also, even if this argument is used to apply the branching logic condition, the warning about the presence of unconverted branching logic will still be displayed. In this specific case, you can safely ignore this warning. +> Note: The `filter` argument is treated as a vector, which means that we can add a filter to each specified variable. Also, even if this argument is used to apply the branching logic condition, the warning about the presence of unconverted branching logic will still be displayed. In this specific case, you can safely ignore this warning. #### *Expressions* @@ -611,7 +738,7 @@ example<- rd_query(covican_transformed, Output: ```{r echo=FALSE, message=FALSE, warning=FALSE, comment=NA} -kable(example$queries[1,]) %>% kableExtra::row_spec(0,bold=TRUE) %>% kableExtra::kable_styling() +kable(example$queries[1,]) |> kableExtra::row_spec(0,bold=TRUE) |> kableExtra::kable_styling() ```
@@ -719,7 +846,7 @@ For this DAG, there are 3 values of _age_ bigger than 60 and 2 missing values in There is an easier way to have access to each query in REDCap through the output of the function. By using the `link` argument to specify the domain, the REDCap version, the project ID and the event ID, the function will add a column in the _$queries_ element of the output with the direct link to REDCap where the query can be found. -Note: The link will only work if the user has access to the project and has at least data viewing rights. +> Note: The link will only work if the user has access to the project and has at least data viewing rights. We can find the information about the domain, the REDCap version and the project ID in the link of the _Project Home_ of the project in REDCap: @@ -799,7 +926,7 @@ example$results
-Note: This function also has the arguments `query_name`, `addTo`, `report_title`, `report_zeros` and `link` that work in the same way as in the examples previously mentioned in section 4.3.1.6. +> Note: This function also has the arguments `query_name`, `addTo`, `report_title`, `report_zeros` and `link` that work in the same way as in the examples previously mentioned in section 4.3.1.6. ### **check_queries** @@ -830,7 +957,7 @@ check$results There are 7 queries pending resolution, 4 solved queries, 1 miscorrected query, and 1 new query between the previous and the new query dataset. -Note: The "Miscorrected" category includes queries that belong to the same combination of record identifier and variable in both the old and new reports, but with a different reason. For instance, if a variable had a missing value in the old report, but in the new report shows a value outside the established range, it would be classified as "Miscorrected". +> Note: The "Miscorrected" category includes queries that belong to the same combination of record identifier and variable in both the old and new reports, but with a different reason. For instance, if a variable had a missing value in the old report, but in the new report shows a value outside the established range, it would be classified as "Miscorrected".
@@ -838,8 +965,8 @@ Query control output: ```{r echo=FALSE, message=FALSE, warning=FALSE, comment=NA} example <- rbind(head(check$queries, 4), - check$queries %>% dplyr::filter(Modification == "Modified") %>% dplyr::filter(row_number()==1)) -kable(example) %>% kableExtra::row_spec(0,bold=TRUE) %>% kableExtra::kable_styling() + check$queries |> dplyr::filter(Modification == "Modified") |> dplyr::filter(row_number()==1)) +kable(example) |> kableExtra::row_spec(0,bold=TRUE) |> kableExtra::kable_styling() ``` diff --git a/vignettes/articles/Data-reading-and-processing.Rmd b/vignettes/articles/Data-reading-and-processing.Rmd new file mode 100644 index 0000000..bd0bf64 --- /dev/null +++ b/vignettes/articles/Data-reading-and-processing.Rmd @@ -0,0 +1,184 @@ +--- +title: "Data reading and processing" +output: + rmarkdown::html_vignette: + toc: true + toc_depth: 5 + number_sections: true +vignette: > + %\VignetteIndexEntry{Data reading and processing} + %\VignetteEncoding{UTF-8} + %\VignetteEngine{knitr::rmarkdown} +editor_options: + chunk_output_type: inline +--- + + +```{r message=FALSE, warning=FALSE, include=FALSE} +rm(list = ls()) + +library(REDCapDM) +library(dplyr) +library(purrr) +library(knitr) +library(kableExtra) +``` + +
+ +This vignette provides a summary of the straightforward and common use of [REDCapDM](https://github.com/bruigtp/REDCapDM) to interact with [REDCap](https://www.project-redcap.org/) data. + +
+ +# **Read REDCap data into R** + +`REDCapDM` allows you to import REDCap data either from local files or via an API connection. Both methods return a structured list containing your dataset, dictionary, and event-form mapping (for longitudinal projects). + +## **1. Using local files** + +Ensure you have exported the following files from REDCap and placed them in the same directory: + +1. **R data file** – contains your REDCap dataset (`.rds` or `.RData`) + +2. **Dictionary file** – CSV file containing variable metadata + +3. **Event-form mapping file** (only for longitudinal projects) – CSV describing which forms belong to each event + +Then, provide the paths to these files using the `redcap_data()` function: + +```{r message=FALSE, warning=FALSE, comment=NA, eval=FALSE} +dataset <- redcap_data( + data_path = "C:/Users/username/example.r", + dic_path = "C:/Users/username/example_dictionary.csv", + event_path = "C:/Users/username/events.csv" # optional for longitudinal projects +) +``` + +⚠️ Tip: If your project is not longitudinal, you can omit `event_path`. + + +## **2. Using API connection** + +You can also import data directly from REDCap using your project’s **API token** and **URL**: + +```{r eval=FALSE, message=FALSE, warning=FALSE, comment=NA} +dataset_api <- redcap_data( + uri = "https://redcap.com/api/", + token = "YOUR_API_TOKEN_HERE" +) +``` + +This method automatically retrieves the event-form mapping for longitudinal projects. + +⚠️ Tip: Keep your API token secure and do not share it publicly. + +## **3. Understanding the output** + +[`redcap_data()`](https://bruigtp.github.io/REDCapDM/reference/redcap_data.html) returns a list with three elements: + +| Element | Description | +| ------------ | ------------------------------------------------------------------------ | +| `data` | Imported dataset containing all REDCap variables | +| `dictionary` | Metadata for each variable, including labels, types, and branching logic | +| `event_form` | Mapping between events and forms (only for longitudinal projects) | + + +
+
+ +# **Process and transform REDCap data** + +After importing your dataset into R, `REDCapDM` provides several functions to **process and transform your data** efficiently. The main function is [`rd_transform()`](https://bruigtp.github.io/REDCapDM/reference/rd_transform.html), which performs multiple operations in one step. + +## **1. Core transformations** + +`rd_transform()` performs the following actions: + +| Transformation | Description | +|----------------|-------------| +| Variable deletion | Remove specific variables or patterns | +| Recalculate fields | Update REDCap calculated fields | +| Checkbox transformation | Convert checkbox variables into separate variables with option names | +| Factor conversion | Replace original variables with their factor version | +| Branching logic conversion | Translate REDCap logic into R logic for easier processing | + + +## **2. Basic usage** + +The minimum required inputs are the dataset and dictionary. For longitudinal projects, include the event-form mapping for full functionality. + +You can provide these inputs either as a **single list** (output of `redcap_data()`) or as **separate arguments**: + +```{r message=FALSE, warning=FALSE, comment=NA} +#Option A: Provide the full project list +covican_transformed <- rd_transform(covican) + +#Option B: Provide individual arguments +covican_transformed <- rd_transform( + data = covican$data, + dic = covican$dictionary, + event_form = covican$event_form +) +``` + +The output is a list containing: + +- **data**: Transformed dataset + +- **dictionary**: Updated variable dictionary + +- **event_form**: Event-form mapping (if applicable) + +- **results**: Summary of all transformations + +You can view the transformation results: + +```{r message=FALSE, warning=FALSE, comment=NA} +#Print the results of the transformation +covican_transformed$results +``` + +## **3. Splitting by event** + +For longitudinal projects, you can split the transformed dataset by event using the `final_format = "by_event"` argument: + +```{r message=FALSE, warning=FALSE, comment=NA} +dataset <- rd_transform(covican, + final_format = "by_event") +``` + +Where the transformed dataset is a tibble object, containing data frames for each event in the REDCap project. + +```{r message=FALSE, warning=FALSE, comment="#>", collapse = TRUE} +dataset$data +``` + +## **4. Splitting by form** + +Or, alternatively, it can be split by form using `final_format = "by_form"` argument: + +```{r message=FALSE, warning=FALSE, comment=NA} +dataset <- rd_transform(covican, + final_format = "by_form") +``` + +Where the tibble object is composed by data frames corresponding to each form in the REDCap project. + +```{r message=FALSE, warning=FALSE, comment="#>", collapse = TRUE} +dataset$data +``` + +
+
+ +# **Quick troubleshooting checklist** + +1. Did you export the variable dictionary from REDCap? Without it, label + conversions and checkbox expansions are error-prone. +2. Are API calls failing? Verify `uri`, `token` and your project's export + permissions. + +**For more information, consult the complete vignette available at: https://bruigtp.github.io/REDCapDM/articles/REDCapDM.html** + +
+
diff --git a/vignettes/Queries.Rmd b/vignettes/articles/Queries.Rmd similarity index 80% rename from vignettes/Queries.Rmd rename to vignettes/articles/Queries.Rmd index b98e76b..d115632 100644 --- a/vignettes/Queries.Rmd +++ b/vignettes/articles/Queries.Rmd @@ -3,7 +3,7 @@ title: "REDCapDM - Queries" output: rmarkdown::html_vignette: toc: true - toc_depth: 5 + toc_depth: 4 number_sections: true vignette: > %\VignetteIndexEntry{REDCapDM - Queries} @@ -20,9 +20,9 @@ library(REDCapDM) library(kableExtra) library(knitr) library(dplyr) -library(magrittr) library(purrr) +# Example dataset covican_transformed <- rd_transform(covican) ``` @@ -37,6 +37,8 @@ This vignette provides a summary of the simple and common use of [REDCapDM](http Queries are crucial for the accuracy and reliability of a [REDCap](https://www.project-redcap.org/) dataset. They help identify missing values, inconsistencies, and potential errors in the collected data. The [`rd_query()`](https://bruigtp.github.io/REDCapDM/reference/rd_query.html) function allows you to generate queries using a specific expression. +## **1. Find missing values for a single variable** + To identify missing values in certain variables, simply provide the relevant information to the `variables` and `expression` arguments. In this scenario, the expression would be 'is.na(x)', where 'x' represents the variable itself: ```{r echo=TRUE, message=FALSE, warning=FALSE} @@ -45,10 +47,12 @@ example <- rd_query(covican_transformed, expression = "is.na(x)") ``` -Note: For variables with branching logic, the function will automatically apply the associated branching logic or at least report it. +> Note: For variables with branching logic, the function will automatically apply the associated branching logic or at least report it.
+## **2. Find out-of-range values** + Alternatively, to identify outliers or observations that meet a certain condition (for example, range): ```{r message=FALSE, warning=TRUE, comment=NA} @@ -58,17 +62,19 @@ example <- rd_query(covican_transformed, event = "baseline_visit_arm_1") ``` +> Note: if you supply fewer `expression` entries than `variables`, the first expression is repeated for all variables (the function warns you). +
-In both cases, the function returns a list containing a data frame designed to aid you to locate each query in the [REDCap](https://www.project-redcap.org/) project: +In both cases, the function returns a list containing a data frame designed to aid you to locate each query in the REDCap project: ```{r echo=TRUE, message=FALSE, warning=FALSE, comment=NA, results='hide'} example$queries ``` ```{r echo=FALSE, message=FALSE, warning=FALSE, comment=NA} -kable(head(example$queries, 2)) %>% - kableExtra::row_spec(0, bold = TRUE) %>% +kable(head(example$queries, 2)) |> + kableExtra::row_spec(0, bold = TRUE) |> kableExtra::kable_styling() ``` @@ -80,6 +86,8 @@ example$results
+## **3. Longitudinal projects and branching logic** + For longitudinal projects, the [`rd_event()`](https://bruigtp.github.io/REDCapDM/reference/rd_event.html) allows you to check if a particular event is missing from a record in the exported data. This happens in REDCap when there is no collected data in a particular event from a record, as REDCap will not export the corresponding row. To identify these cases, you can use the following code: ```{r message=FALSE, warning=FALSE, comment=NA} @@ -90,11 +98,11 @@ example <- rd_event(covican_transformed,

-# **Control** +# **Practical workflow: Find → Fix → Re-check** -After identifying queries, it is common practice to correct the original dataset in [REDCap](https://www.project-redcap.org/) and re-run the query process for a new query dataset. +After identifying queries, it is common practice to correct the original dataset in REDCap and re-run the query process for a new query dataset. -The [`check_queries()`](https://bruigtp.github.io/REDCapDM/reference/check_queries.html) functiona allows you to compare the previous query dataset with the new one: +The [`check_queries()`](https://bruigtp.github.io/REDCapDM/reference/check_queries.html) function allows you to compare the previous query dataset with the new one: ```{r message=FALSE, warning=FALSE, include=FALSE} example <- rd_query(covican_transformed, @@ -121,12 +129,12 @@ The output, in addition to the query data frame, now includes a summary with the check$results ``` -Note: The "Miscorrected" category includes queries that belong to the same combination of record identifier and variable in both the old and new reports, but with a different reason. For instance, if a variable had a missing value in the old report, but in the new report shows a value outside the established range, it would be classified as "Miscorrected". +> Note: The "Miscorrected" category includes queries that belong to the same combination of record identifier and variable in both the old and new reports, but with a different reason. For instance, if a variable had a missing value in the old report, but in the new report shows a value outside the established range, it would be classified as "Miscorrected".

-# **Export** +# **Exporting query lists** With the help of the `rd_export()` function, you can export the identified queries to a `.xlsx` file of your choice: @@ -141,7 +149,7 @@ example <- rd_query(covican_transformed, rd_export(example) ``` -This is the simplets way to use the function and will create a file named "example.xlsx" in your current working directory, but you can customise this exported file: +This is the simplest way to use the function and will create a file named "example.xlsx" in your current working directory, but you can customise this exported file: ```{r message=FALSE, warning=FALSE, comment=NA, eval=FALSE} rd_export(queries = example$queries, @@ -153,7 +161,6 @@ rd_export(queries = example$queries, In both cases, a message will be generated in the console informing you that the file has been created and where it is located. -

diff --git a/vignettes/markdown.css b/vignettes/markdown.css deleted file mode 100644 index 2e62c47..0000000 --- a/vignettes/markdown.css +++ /dev/null @@ -1,52 +0,0 @@ -