diff --git a/NAMESPACE b/NAMESPACE index 35fc995..4b5f7d2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,6 +7,7 @@ export(build_quality_report) export(build_record_status_data) export(plot_record_status) export(pull_redcap_project) +export(save_codebook) export(view_codebook) importFrom(DT,datatable) importFrom(REDCapR,redcap_arm_export) @@ -57,8 +58,10 @@ importFrom(ggplot2,scale_x_discrete) importFrom(ggplot2,scale_y_discrete) importFrom(ggplot2,theme) importFrom(ggplot2,theme_minimal) +importFrom(htmltools,HTML) importFrom(htmltools,browsable) importFrom(htmltools,htmlDependency) +importFrom(htmltools,save_html) importFrom(htmltools,tagList) importFrom(htmltools,tags) importFrom(purrr,flatten_chr) diff --git a/R/REDCapExploreR-package.R b/R/REDCapExploreR-package.R index c309f7e..e4e6843 100644 --- a/R/REDCapExploreR-package.R +++ b/R/REDCapExploreR-package.R @@ -8,7 +8,7 @@ #' right_join row_number select slice summarise transmute #' @importFrom ggplot2 aes element_blank element_text geom_tile ggplot labs #' scale_fill_gradientn scale_x_discrete scale_y_discrete theme theme_minimal -#' @importFrom htmltools browsable htmlDependency tagList tags +#' @importFrom htmltools browsable HTML htmlDependency save_html tagList tags #' @importFrom purrr flatten_chr map map_chr map_dbl map_lgl #' @importFrom REDCapR redcap_arm_export redcap_event_instruments #' redcap_instruments redcap_event_read redcap_instrument_repeating diff --git a/R/codebook.R b/R/codebook.R index 451ee26..0c576e7 100644 --- a/R/codebook.R +++ b/R/codebook.R @@ -70,8 +70,8 @@ get_codebook <- function(project) { #' `view_codebook()` turns a `redcap_codebook` object from [build_codebook()] #' into a static HTML viewer with tab-style section navigation and one #' interactive table per codebook section. The returned object prints in the -#' RStudio/Posit Viewer and can be saved as an HTML file with -#' [htmltools::save_html()]. Event, event-instrument, and repeating-structure +#' RStudio/Posit Viewer. Use [save_codebook()] to save an HTML file for sharing +#' or email attachment. Event, event-instrument, and repeating-structure #' sections are omitted when those API tables are empty. #' #' @param codebook A `redcap_codebook` object returned by [build_codebook()]. @@ -88,7 +88,7 @@ get_codebook <- function(project) { #' ) #' #' viewer <- view_codebook(codebook) -#' htmltools::save_html(viewer, "codebook.html") +#' save_codebook(codebook, "codebook.html") #' } #' #' @export @@ -127,6 +127,46 @@ view_codebook <- function(codebook, page_length = 25) { ) } +#' @title Save a REDCap codebook viewer +#' +#' @description +#' `save_codebook()` saves the interactive HTML viewer from [view_codebook()] +#' to disk as a single HTML file. Local CSS and JavaScript dependencies are +#' inlined so the file can be opened in a browser or attached to an email +#' without a separate dependency folder. +#' +#' @param codebook A `redcap_codebook` object returned by [build_codebook()]. +#' @param file Output HTML file path. +#' @param page_length Number of rows to show per interactive table page. +#' +#' @returns The output file path, invisibly. +#' +#' @examples +#' \dontrun{ +#' codebook <- build_codebook( +#' redcap_uri = Sys.getenv("REDCAP_URI"), +#' token = Sys.getenv("REDCAP_TOKEN") +#' ) +#' +#' save_codebook(codebook, "codebook.html") +#' } +#' +#' @export +save_codebook <- function( + codebook, + file, + page_length = 25 +) { + get_validate_codebook(codebook) + get_validate_html_file(file) + get_validate_page_length(page_length) + + viewer <- view_codebook(codebook, page_length = page_length) + get_save_codebook_single_file(viewer, file) + + invisible(file) +} + pull_redcap_codebook <- function(redcap_uri, token) { get_validate_api_credentials(redcap_uri, token) @@ -330,7 +370,11 @@ get_codebook_forms <- function(project) { get_codebook_project_summary <- function(project) { project_info <- project$project_info - project_title <- if ("project_title" %in% names(project_info) && nrow(project_info) > 0) { + has_title_col <- "project_title" %in% names(project_info) + has_info_rows <- nrow(project_info) > 0 + has_project_title <- has_title_col && has_info_rows + + project_title <- if (has_project_title) { as.character(project_info$project_title[[1]]) } else { "Unknown REDCap project" @@ -550,7 +594,12 @@ get_codebook_repeating_summary <- function(project) { } repeating_events <- if ( - "redcap_event_name" %in% names(repeating) && all(c("redcap_event_name", "form_name") %in% names(project$event_instruments)) + "redcap_event_name" %in% + names(repeating) && + all( + c("redcap_event_name", "form_name") %in% + names(project$event_instruments) + ) ) { event_rows <- if ("form_name" %in% names(repeating)) { repeating |> filter(get_is_missing(.data$form_name)) @@ -614,7 +663,10 @@ get_codebook_validation_label <- function( } get_codebook_event_count <- function(project) { - if (nrow(project$events) == 0 || !"redcap_event_name" %in% names(project$events)) { + if ( + nrow(project$events) == 0 || + !"redcap_event_name" %in% names(project$events) + ) { return(NA_integer_) } @@ -648,6 +700,107 @@ get_validate_page_length <- function(page_length) { invisible(NULL) } +get_validate_html_file <- function(file) { + valid_file <- is.character(file) && + length(file) == 1 && + !is.na(file) && + file != "" + + if (!valid_file) { + cli_abort("{.arg file} must be a single non-empty HTML file path.") + } + + parent_dir <- dirname(file) + if (!dir.exists(parent_dir)) { + cli_abort("The output directory for {.arg file} must already exist.") + } + + invisible(NULL) +} + +get_save_codebook_single_file <- function(viewer, file) { + temp_dir <- tempfile("redcap-codebook-save-") + dir.create(temp_dir) + on.exit(unlink(temp_dir, recursive = TRUE), add = TRUE) + + temp_file <- file.path(temp_dir, basename(file)) + save_html(viewer, file = temp_file, libdir = "lib") + + html <- paste(readLines(temp_file, warn = FALSE), collapse = "\n") + html <- get_inline_html_styles(html, temp_dir) + html <- get_inline_html_scripts(html, temp_dir) + + writeLines(html, file, useBytes = TRUE) + invisible(file) +} + +get_inline_html_styles <- function(html, base_dir) { + get_inline_html_dependency( + html = html, + base_dir = base_dir, + pattern = "]+)href=\"([^\"]+)\"([^>]*)>", + replacement = \(path, content) { + paste0( + "" + ) + } + ) +} + +get_inline_html_scripts <- function(html, base_dir) { + get_inline_html_dependency( + html = html, + base_dir = base_dir, + pattern = "]*)src=\"([^\"]+)\"([^>]*)>", + replacement = \(path, content) { + paste0( + "" + ) + } + ) +} + +get_inline_html_dependency <- function(html, base_dir, pattern, replacement) { + matches <- gregexpr(pattern, html, perl = TRUE) + starts <- matches[[1]] + if (starts[[1]] == -1) { + return(html) + } + + match_text <- regmatches(html, matches)[[1]] + paths <- map_chr(match_text, \(match) { + sub(pattern, "\\2", match, perl = TRUE) + }) + + for (index in rev(seq_along(match_text))) { + path <- paths[[index]] + local_file <- file.path(base_dir, path) + if (!file.exists(local_file)) { + next + } + + content <- paste(readLines(local_file, warn = FALSE), collapse = "\n") + inline <- replacement(path, content) + start <- starts[[index]] + end <- start + attr(starts, "match.length")[[index]] - 1 + html <- paste0( + substr(html, 1, start - 1), + inline, + substr(html, end + 1, nchar(html)) + ) + } + + html +} + get_codebook_viewer_tables <- function(codebook) { tables <- list( project = list( diff --git a/man/save_codebook.Rd b/man/save_codebook.Rd new file mode 100644 index 0000000..beaf1e6 --- /dev/null +++ b/man/save_codebook.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/codebook.R +\name{save_codebook} +\alias{save_codebook} +\title{Save a REDCap codebook viewer} +\usage{ +save_codebook(codebook, file, page_length = 25) +} +\arguments{ +\item{codebook}{A \code{redcap_codebook} object returned by \code{\link[=build_codebook]{build_codebook()}}.} + +\item{file}{Output HTML file path.} + +\item{page_length}{Number of rows to show per interactive table page.} +} +\value{ +The output file path, invisibly. +} +\description{ +\code{save_codebook()} saves the interactive HTML viewer from \code{\link[=view_codebook]{view_codebook()}} +to disk as a single HTML file. Local CSS and JavaScript dependencies are +inlined so the file can be opened in a browser or attached to an email +without a separate dependency folder. +} +\examples{ +\dontrun{ +codebook <- build_codebook( + redcap_uri = Sys.getenv("REDCAP_URI"), + token = Sys.getenv("REDCAP_TOKEN") +) + +save_codebook(codebook, "codebook.html") +} + +} diff --git a/man/view_codebook.Rd b/man/view_codebook.Rd index 07afa2d..e056451 100644 --- a/man/view_codebook.Rd +++ b/man/view_codebook.Rd @@ -19,8 +19,8 @@ tables. \code{view_codebook()} turns a \code{redcap_codebook} object from \code{\link[=build_codebook]{build_codebook()}} into a static HTML viewer with tab-style section navigation and one interactive table per codebook section. The returned object prints in the -RStudio/Posit Viewer and can be saved as an HTML file with -\code{\link[htmltools:save_html]{htmltools::save_html()}}. Event, event-instrument, and repeating-structure +RStudio/Posit Viewer. Use \code{\link[=save_codebook]{save_codebook()}} to save an HTML file for sharing +or email attachment. Event, event-instrument, and repeating-structure sections are omitted when those API tables are empty. } \examples{ @@ -31,7 +31,7 @@ codebook <- build_codebook( ) viewer <- view_codebook(codebook) -htmltools::save_html(viewer, "codebook.html") +save_codebook(codebook, "codebook.html") } } diff --git a/pkgdown/_pkgdown.yml b/pkgdown/_pkgdown.yml index ecfb00f..57970c8 100644 --- a/pkgdown/_pkgdown.yml +++ b/pkgdown/_pkgdown.yml @@ -43,6 +43,7 @@ reference: Build and view REDCap project codebooks. contents: - build_codebook + - save_codebook - view_codebook - title: "Build Quality Reports" desc: > diff --git a/tests/testthat/test-codebook.R b/tests/testthat/test-codebook.R index 1057422..ff8a04c 100644 --- a/tests/testthat/test-codebook.R +++ b/tests/testthat/test-codebook.R @@ -605,3 +605,46 @@ test_that("view_codebook escapes REDCap metadata values as text", { expect_match(as.character(viewer), "<script>alert") expect_false(grepl("