diff --git a/DESCRIPTION b/DESCRIPTION index 9e79510..8f9c206 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -37,6 +37,7 @@ Imports: ggplot2, ggplotify, gridify, + jsonlite, junco, methods, openxlsx, @@ -49,8 +50,10 @@ Imports: teal, teal.code, teal.modules.clinical, + teal.reporter, tern, - yaml + yaml, + zip Suggests: forcats, knitr, @@ -58,7 +61,6 @@ Suggests: rmarkdown, teal.data, teal.modules.general, - teal.reporter, teal.transform VignetteBuilder: knitr Config/Needs/website: insightsengineering/nesttemplate diff --git a/NAMESPACE b/NAMESPACE index 82f4cb0..de2b5c9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -103,4 +103,5 @@ importFrom(teal.code,eval_code) importFrom(teal.modules.clinical,add_expr) importFrom(teal.modules.clinical,bracket_expr) importFrom(tern,rtable2gg) +importFrom(utils,write.csv) importFrom(yaml,as.yaml) diff --git a/NEWS.md b/NEWS.md index 0114b6b..cee6d48 100644 --- a/NEWS.md +++ b/NEWS.md @@ -6,6 +6,7 @@ - Fixed ID conflict in `or_filtering_transformator` that caused errors when multiple instances were used in the same Shiny app. Removed a `shinyBS::bsModal()` block with fixed, non-module-scoped IDs (dead code — preview is handled by `shiny::showModal()`), resolving duplicate element IDs across instances. - Added `updateOn = "blur"` to all `textInput` controls so that reactive updates are only triggered when the user leaves the field, reducing unnecessary re-renders while typing. Requires `shiny >= 1.11.0`. - Refactored `title_footer_decorator` not to overwrite the first row of the TABLE.ID column in the imported file. This change allows for importing files that have meaningful data in the first row. +- Added a button for CSV download for `tm_report_manager` module. #46 # Version 0.0.3 diff --git a/R/ReportManager.R b/R/ReportManager.R index 43d8845..63cdcc4 100644 --- a/R/ReportManager.R +++ b/R/ReportManager.R @@ -484,6 +484,86 @@ ReportManager <- R6::R6Class("ReportManager", # nolint: object_name_linter } }, + #' Set up CSV download observer + #' @description + #' Registers the `observeEvent` that handles CSV download clicks. + #' Call once from `moduleServer` after initialization. + #' @param input Shiny input object from `moduleServer` + setup_csv_download = function(input) { + shiny::observeEvent(input$csv_download_click, { + report_name <- input$csv_download_click + tmp_dir <- file.path(tempdir(), paste0("csv_export_", gsub("[^[:alnum:]]", "_", report_name))) + written <- tryCatch( + self$export_tables_to_csv(report_name, tmp_dir), + error = function(e) { + shiny::showNotification( + sprintf("Error exporting tables: %s", conditionMessage(e)), + type = "error" + ) + character(0) + } + ) + if (length(written) == 0) { + shiny::showNotification("No tables found in this report.", type = "warning") + return() + } + safe_title <- gsub("[^[:alnum:]_-]", "_", report_name) + if (length(written) == 1L) { + raw_bytes <- readBin(written[[1]], what = "raw", n = file.size(written[[1]])) + self$session$sendCustomMessage("trigger_csv_download", list( + b64 = jsonlite::base64_enc(raw_bytes), + filename = paste0(safe_title, "_tables.csv"), + type = "text/csv" + )) + } else { + zip_path <- file.path(tmp_dir, paste0(safe_title, "_tables.zip")) + zip::zip(zipfile = zip_path, files = written, mode = "cherry-pick") + raw_bytes <- readBin(zip_path, what = "raw", n = file.size(zip_path)) + self$session$sendCustomMessage("trigger_csv_download", list( + b64 = jsonlite::base64_enc(raw_bytes), + filename = paste0(safe_title, "_tables.zip"), + type = "application/zip" + )) + } + }) + }, + + #' Export all tables from a saved report as CSV files + #' @description + #' Loads the report from disk, extracts all table-type content from each card, + #' converts each to a `data.frame` and writes it as a CSV file in `output_dir`. + #' Returns the vector of written file paths, or an empty character vector when + #' no tables are found. + #' @param report_title (character) Title of the report to export. + #' @param output_dir (character) Directory where CSV files will be written. + #' @return character vector of written file paths. + export_tables_to_csv = function(report_title, output_dir) { + report_dir <- self$get_abs_report_path(report_title) + if (!file.exists(file.path(report_dir, "Report.json"))) { + return(character(0)) + } + + reporter <- teal.reporter::Reporter$new() + report_id <- jsonlite::read_json(file.path(report_dir, "Report.json"))$id + reporter$set_id(as.character(report_id)) + reporter$from_jsondir(report_dir) + + tables <- private$extract_tables_from_reporter(reporter) + if (length(tables) == 0) { + return(character(0)) + } + + if (!dir.exists(output_dir)) dir.create(output_dir, recursive = TRUE) + + written <- character(length(tables)) + for (i in seq_along(tables)) { + file_path <- file.path(output_dir, paste0(names(tables)[[i]], ".csv")) + utils::write.table(tables[[i]], file = file_path, sep = ",", col.names = FALSE, row.names = FALSE) + written[[i]] <- file_path + } + written + }, + #' Re-build reports #' @description #' Rebuild reports to include data that has changed. @@ -599,6 +679,62 @@ ReportManager <- R6::R6Class("ReportManager", # nolint: object_name_linter saveRDS(unname(code_list), file.path(path, "code.rds")) }, + #' Extract all table-type content from a Reporter as a named list of data.frames + extract_tables_from_reporter = function(reporter) { + cards <- reporter$get_cards() + result <- list() + for (card_i in seq_along(cards)) { + card <- cards[[card_i]] + card_name <- names(cards)[[card_i]] + card_title <- tryCatch( + teal.reporter::metadata(card)$title, + error = function(e) NULL + ) + if (is.null(card_title) || !nzchar(card_title)) card_title <- card_name + if (is.null(card_title) || !nzchar(card_title)) card_title <- paste0("card_", card_i) + safe_title <- gsub("[^[:alnum:]_-]", "_", card_title) + + # Collect content elements: ReportCard R6 uses $get_content(), teal_card S3 is a plain list + elements <- if (inherits(card, "ReportCard")) card$get_content() else as.list(card) + + tbl_count <- 0L + for (elem in elements) { + # Unwrap TableBlock (used by ReportCard$append_table) + if (inherits(elem, "TableBlock")) { + elem <- tryCatch(elem$get_content(), error = function(e) NULL) + } + df <- NULL + if (inherits(elem, c("TableTree", "ElementaryTable"))) { + df <- tryCatch( + { + as.data.frame( + rtables::matrix_form(elem)$strings, + stringsAsFactors = FALSE + ) + }, + error = function(e) NULL + ) + } else if (inherits(elem, "chunk_output")) { + df <- tryCatch(as.data.frame(elem[[1]]), error = function(e) NULL) + } else if (inherits(elem, "listing_df") || is.data.frame(elem)) { + df <- as.data.frame(elem) + } + if (!is.null(df)) { + tbl_count <- tbl_count + 1L + key <- if (tbl_count == 1L) safe_title else paste0(safe_title, "_", tbl_count) + # Deduplicate key across all cards using a numeric suffix + if (key %in% names(result)) { + n <- 2L + while (paste0(key, "_", n) %in% names(result)) n <- n + 1L + key <- paste0(key, "_", n) + } + result[[key]] <- df + } + } + } + result + }, + #' Register `onSessionEnded` to unlock report when session is closed register_cleanup = function() { if (!is.null(self$session)) { diff --git a/R/tm_report_manager.R b/R/tm_report_manager.R index 8b0eeaa..4f5cc98 100644 --- a/R/tm_report_manager.R +++ b/R/tm_report_manager.R @@ -92,6 +92,17 @@ report_manager_ui <- function(id) { var reportName = $(this).data('report'); Shiny.setInputValue('", ns("release_lock_click"), "', reportName, {priority: 'event'}); }); + Shiny.addCustomMessageHandler('trigger_csv_download', function(msg) { + var bytes = Uint8Array.from(atob(msg.b64), function(c) { return c.charCodeAt(0); }); + var blob = new Blob([bytes], {type: msg.type}); + var url = URL.createObjectURL(blob); + var a = document.createElement('a'); + a.href = url; + a.download = msg.filename; + document.body.appendChild(a); + a.click(); + setTimeout(function() { document.body.removeChild(a); URL.revokeObjectURL(url); }, 100); + }); "))) ) } @@ -104,6 +115,7 @@ report_manager_ui <- function(id) { #' @import shiny teal #' @importFrom DT renderDT #' @importFrom shinyjs toggleState disable enable +#' @importFrom utils write.csv #' @keywords internal report_manager_server <- function(id, reports_path = "reports", auto_save = TRUE, reporter) { moduleServer(id, function(input, output, session) { @@ -114,6 +126,7 @@ report_manager_server <- function(id, reports_path = "reports", auto_save = TRUE # Initialize report manager object rm <- ReportManager$new(reports_path = reports_path, session) + rm$setup_csv_download(input) if (auto_save) { rm$auto_save_observer(reporter) } @@ -473,6 +486,19 @@ report_manager_server <- function(id, reports_path = "reports", auto_save = TRUE lock_icon <- '' } + # CSV download button (available for all reports that have saved content) + report_json <- file.path(rm$get_abs_report_path(report_name), "Report.json") + has_content <- file.exists(report_json) + csv_btn <- if (has_content) { + create_action_button("csv_download_click", report_name, "download", "btn-default", "Download tables as CSV") + } else { + paste0( + '' + ) + } + # Action buttons based on state if (is_active) { # Active report: can edit title, cannot delete, can rebuild @@ -535,7 +561,7 @@ report_manager_server <- function(id, reports_path = "reports", auto_save = TRUE } # Combine all elements with spacing - paste(lock_icon, edit_btn, load_btn, rebuild_btn, delete_btn, sep = " ") + paste(lock_icon, edit_btn, load_btn, rebuild_btn, delete_btn, csv_btn, sep = " ") }, character(1)) } else { df$actions <- character(0) diff --git a/man/ReportManager.Rd b/man/ReportManager.Rd index 8a74ae6..09b8093 100644 --- a/man/ReportManager.Rd +++ b/man/ReportManager.Rd @@ -50,6 +50,8 @@ Initialize \code{ReportManager}} \item \href{#method-ReportManager-auto_save_observer}{\code{ReportManager$auto_save_observer()}} \item \href{#method-ReportManager-unlock_report_public}{\code{ReportManager$unlock_report_public()}} \item \href{#method-ReportManager-release_lock}{\code{ReportManager$release_lock()}} + \item \href{#method-ReportManager-setup_csv_download}{\code{ReportManager$setup_csv_download()}} + \item \href{#method-ReportManager-export_tables_to_csv}{\code{ReportManager$export_tables_to_csv()}} \item \href{#method-ReportManager-rebuild_report}{\code{ReportManager$rebuild_report()}} \item \href{#method-ReportManager-clone}{\code{ReportManager$clone()}} } @@ -379,12 +381,60 @@ Release lock on current report (keep report loaded but make it read-only)} \if{html}{\out{
}} \describe{ \item{\code{report_title}}{(character) Title of the report to release lock from -Re-build reports} +Set up CSV download observer} } \if{html}{\out{
}} } } +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-ReportManager-setup_csv_download}{}}} +\subsection{\code{ReportManager$setup_csv_download()}}{ + Registers the \code{observeEvent} that handles CSV download clicks. +Call once from \code{moduleServer} after initialization. + \subsection{Usage}{ + \if{html}{\out{
}} + \preformatted{ReportManager$setup_csv_download(input)} + \if{html}{\out{
}} + } + \subsection{Arguments}{ + \if{html}{\out{
}} + \describe{ + \item{\code{input}}{Shiny input object from \code{moduleServer} +Export all tables from a saved report as CSV files} + } + \if{html}{\out{
}} + } +} + +\if{html}{\out{
}} +\if{html}{\out{}} +\if{latex}{\out{\hypertarget{method-ReportManager-export_tables_to_csv}{}}} +\subsection{\code{ReportManager$export_tables_to_csv()}}{ + Loads the report from disk, extracts all table-type content from each card, +converts each to a \code{data.frame} and writes it as a CSV file in \code{output_dir}. +Returns the vector of written file paths, or an empty character vector when +no tables are found. + \subsection{Usage}{ + \if{html}{\out{
}} + \preformatted{ReportManager$export_tables_to_csv(report_title, output_dir)} + \if{html}{\out{
}} + } + \subsection{Arguments}{ + \if{html}{\out{
}} + \describe{ + \item{\code{report_title}}{(character) Title of the report to export.} + \item{\code{output_dir}}{(character) Directory where CSV files will be written.} + } + \if{html}{\out{
}} + } + \subsection{Returns}{ + character vector of written file paths. +Re-build reports + } +} + \if{html}{\out{
}} \if{html}{\out{}} \if{latex}{\out{\hypertarget{method-ReportManager-rebuild_report}{}}} @@ -408,6 +458,7 @@ Lock report so that it can't be overwritten by another user Unlock report Save creator information Save code from each card as \code{code.rds} in the report directory. +Extract all table-type content from a Reporter as a named list of data.frames Register \code{onSessionEnded} to unlock report when session is closed} } \if{html}{\out{}} diff --git a/tests/testthat/test-ReportManager.R b/tests/testthat/test-ReportManager.R new file mode 100644 index 0000000..ebff079 --- /dev/null +++ b/tests/testthat/test-ReportManager.R @@ -0,0 +1,300 @@ +# Helpers --------------------------------------------------------------- + +make_rm <- function(reports_path) { + shiny::isolate(ReportManager$new(reports_path = reports_path, session = NULL)) +} + +make_report_on_disk <- function(reports_path, report_title, df = NULL) { + report_dir <- file.path(reports_path, report_title) + dir.create(report_dir, recursive = TRUE) + + card_file <- "card_001.rds" + saveRDS(if (is.null(df)) list("no_table") else list(df), file.path(report_dir, card_file)) + + jsonlite::write_json( + list( + name = "teal Reporter", version = "1", id = report_title, + cards = stats::setNames( + list(list(name = "card_001", path = card_file)), + "teal_card" + ), + metadata = list() + ), + file.path(report_dir, "Report.json"), + auto_unbox = TRUE + ) +} + +# initialize ------------------------------------------------------------ + +testthat::test_that("initialize sets reports_path field", { + tmp <- withr::local_tempdir() + rm <- make_rm(tmp) + + testthat::expect_equal(rm$reports_path, tmp) +}) + +# list_reports ---------------------------------------------------------- + +testthat::test_that("list_reports returns one row per report directory", { + tmp <- withr::local_tempdir() + dir.create(file.path(tmp, "report_a")) + dir.create(file.path(tmp, "report_b")) + rm <- make_rm(tmp) + + result <- shiny::isolate(rm$list_reports()) + + testthat::expect_equal(nrow(result), 2L) + testthat::expect_setequal(result$reports, c("report_a", "report_b")) +}) + +testthat::test_that("list_reports reads created_by from .creator.rds", { + tmp <- withr::local_tempdir() + dir.create(file.path(tmp, "report_x")) + saveRDS("alice", file.path(tmp, "report_x", ".creator.rds")) + rm <- make_rm(tmp) + + result <- shiny::isolate(rm$list_reports()) + + testthat::expect_equal(result$created_by, "alice") +}) + +testthat::test_that("list_reports reads locked_by from .lockfile.rds", { + tmp <- withr::local_tempdir() + dir.create(file.path(tmp, "locked_report")) + saveRDS("bob", file.path(tmp, "locked_report", ".lockfile.rds")) + rm <- make_rm(tmp) + + result <- shiny::isolate(rm$list_reports()) + + testthat::expect_equal(result$locked_by, "bob") +}) + +testthat::test_that("list_reports returns Never for last_rebuild when .rebuild_time.rds absent", { + tmp <- withr::local_tempdir() + dir.create(file.path(tmp, "report_no_rebuild")) + rm <- make_rm(tmp) + + result <- shiny::isolate(rm$list_reports()) + + testthat::expect_equal(result$last_rebuild, "Never") +}) + +# get_abs_report_path --------------------------------------------------- + +testthat::test_that("get_abs_report_path concatenates reports_path and title", { + tmp <- withr::local_tempdir() + rm <- make_rm(tmp) + + testthat::expect_equal(rm$get_abs_report_path("my_report"), file.path(tmp, "my_report")) +}) + +# set_current_report_title ---------------------------------------------- + +testthat::test_that("set_current_report_title sets title from character", { + tmp <- withr::local_tempdir() + rm <- make_rm(tmp) + + shiny::isolate(rm$set_current_report_title("my_report")) + + testthat::expect_equal(shiny::isolate(rm$current_report_title()), "my_report") +}) + +# is_locked_by_other ---------------------------------------------------- + +testthat::test_that("is_locked_by_other returns FALSE when no lockfile exists", { + tmp <- withr::local_tempdir() + dir.create(file.path(tmp, "report_a")) + rm <- make_rm(tmp) + + result <- shiny::isolate(rm$is_locked_by_other("report_a", verbose = FALSE)) + + testthat::expect_false(result) +}) + +testthat::test_that("is_locked_by_other returns TRUE when lockfile exists and report is not mine", { + tmp <- withr::local_tempdir() + dir.create(file.path(tmp, "report_a")) + saveRDS("other_user", file.path(tmp, "report_a", ".lockfile.rds")) + rm <- make_rm(tmp) + + result <- shiny::isolate(rm$is_locked_by_other("report_a", verbose = FALSE)) + + testthat::expect_true(result) +}) + +testthat::test_that("is_locked_by_other returns FALSE when report is locked by me", { + tmp <- withr::local_tempdir() + dir.create(file.path(tmp, "report_a")) + saveRDS( + ifelse(interactive(), Sys.getenv("USER"), self$session$user), + file.path(tmp, "report_a", ".lockfile.rds") + ) + rm <- make_rm(tmp) + rm$my_locked_report <- "report_a" + + result <- shiny::isolate(rm$is_locked_by_other("report_a", verbose = FALSE)) + + testthat::expect_false(result) +}) + +# delete_report --------------------------------------------------------- + +testthat::test_that("delete_report removes the report directory", { + tmp <- withr::local_tempdir() + dir.create(file.path(tmp, "to_delete")) + rm <- make_rm(tmp) + + shiny::isolate(rm$delete_report("to_delete")) + + testthat::expect_false(dir.exists(file.path(tmp, "to_delete"))) +}) + +testthat::test_that("delete_report does not remove a report locked by another user", { + tmp <- withr::local_tempdir() + dir.create(file.path(tmp, "locked")) + saveRDS("other_user", file.path(tmp, "locked", ".lockfile.rds")) + rm <- make_rm(tmp) + + shiny::isolate(rm$delete_report("locked")) + + testthat::expect_true(dir.exists(file.path(tmp, "locked"))) +}) + +# rename_report --------------------------------------------------------- + +testthat::test_that("rename_report renames the directory on disk", { + tmp <- withr::local_tempdir() + dir.create(file.path(tmp, "old_name")) + rm <- make_rm(tmp) + + shiny::isolate(rm$rename_report("old_name", "new_name", + reporter = list(set_id = function(...) NULL, to_jsondir = function(...) NULL) + )) + + testthat::expect_false(dir.exists(file.path(tmp, "old_name"))) + testthat::expect_true(dir.exists(file.path(tmp, "new_name"))) +}) + +testthat::test_that("rename_report errors when new name already exists", { + tmp <- withr::local_tempdir() + dir.create(file.path(tmp, "report_a")) + dir.create(file.path(tmp, "report_b")) + rm <- make_rm(tmp) + + testthat::expect_error( + shiny::isolate(rm$rename_report("report_a", "report_b", reporter = list())) + ) +}) + +# reset ----------------------------------------------------------------- + +testthat::test_that("reset sets current_report_title to NULL", { + tmp <- withr::local_tempdir() + rm <- make_rm(tmp) + shiny::isolate(rm$current_report_title("some_report")) + + shiny::isolate(rm$reset()) + + testthat::expect_null(shiny::isolate(rm$current_report_title())) +}) + +testthat::test_that("reset sets read_only_mode to FALSE", { + tmp <- withr::local_tempdir() + rm <- make_rm(tmp) + shiny::isolate(rm$read_only_mode(TRUE)) + + shiny::isolate(rm$reset()) + + testthat::expect_false(shiny::isolate(rm$read_only_mode())) +}) + +# release_lock ---------------------------------------------------------- + +testthat::test_that("release_lock removes the lockfile", { + tmp <- withr::local_tempdir() + dir.create(file.path(tmp, "report_a")) + saveRDS("me", file.path(tmp, "report_a", ".lockfile.rds")) + rm <- make_rm(tmp) + rm$my_locked_report <- "report_a" + + shiny::isolate(rm$release_lock("report_a")) + + testthat::expect_false(file.exists(file.path(tmp, "report_a", ".lockfile.rds"))) +}) + +testthat::test_that("release_lock sets my_locked_report to NULL", { + tmp <- withr::local_tempdir() + dir.create(file.path(tmp, "report_a")) + saveRDS("me", file.path(tmp, "report_a", ".lockfile.rds")) + rm <- make_rm(tmp) + rm$my_locked_report <- "report_a" + + shiny::isolate(rm$release_lock("report_a")) + + testthat::expect_null(rm$my_locked_report) +}) + +# export_tables_to_csv -------------------------------------------------- + +testthat::test_that("export_tables_to_csv returns character(0) when report has no tables", { + tmp <- withr::local_tempdir() + make_report_on_disk(tmp, "no_tables") + rm <- make_rm(tmp) + + result <- shiny::isolate(rm$export_tables_to_csv("no_tables", file.path(tmp, "out"))) + + testthat::expect_equal(result, character(0)) +}) + +testthat::test_that("export_tables_to_csv writes a CSV and returns its path", { + tmp <- withr::local_tempdir() + df <- data.frame(a = 1:3, b = c("x", "y", "z"), stringsAsFactors = FALSE) + make_report_on_disk(tmp, "report_with_table", df) + rm <- make_rm(tmp) + out_dir <- file.path(tmp, "out") + + result <- shiny::isolate(rm$export_tables_to_csv("report_with_table", out_dir)) + + testthat::expect_length(result, 1L) + testthat::expect_true(file.exists(result[[1L]])) + written <- utils::read.csv(result[[1L]], header = FALSE, stringsAsFactors = FALSE) + testthat::expect_equal(nrow(written), 3L) +}) + +testthat::test_that("export_tables_to_csv creates output_dir when it does not exist", { + tmp <- withr::local_tempdir() + make_report_on_disk(tmp, "report_dir_test", data.frame(x = 1:2)) + rm <- make_rm(tmp) + out_dir <- file.path(tmp, "new_subdir", "csv_out") + + shiny::isolate(rm$export_tables_to_csv("report_dir_test", out_dir)) + + testthat::expect_true(dir.exists(out_dir)) +}) + +testthat::test_that("export_tables_to_csv writes one CSV per card when multiple cards contain tables", { + tmp <- withr::local_tempdir() + report_dir <- file.path(tmp, "multi_card") + dir.create(report_dir) + saveRDS(list(data.frame(a = 1:2)), file.path(report_dir, "card_1.rds")) + saveRDS(list(data.frame(b = 3:4)), file.path(report_dir, "card_2.rds")) + jsonlite::write_json( + list( + name = "teal Reporter", version = "1", id = "multi_card", + cards = list( + teal_card = list(name = "card_001", path = "card_1.rds"), + teal_card.1 = list(name = "card_002", path = "card_2.rds") + ), + metadata = list() + ), + file.path(report_dir, "Report.json"), + auto_unbox = TRUE + ) + rm <- make_rm(tmp) + + result <- shiny::isolate(rm$export_tables_to_csv("multi_card", file.path(tmp, "out_multi"))) + + testthat::expect_length(result, 2L) + testthat::expect_true(all(file.exists(result))) +})