From e415af72e24948b9e69ecd06b17ec3810eb8cf97 Mon Sep 17 00:00:00 2001 From: Mike Briganti <86301883+mikebriganti@users.noreply.github.com> Date: Fri, 31 Jan 2025 09:10:26 -0500 Subject: [PATCH 1/7] Update Reporter.R Signed-off-by: Mike Briganti <86301883+mikebriganti@users.noreply.github.com> --- R/Reporter.R | 126 +++++++++++++++++++++++++++++++++------------------ 1 file changed, 83 insertions(+), 43 deletions(-) diff --git a/R/Reporter.R b/R/Reporter.R index 37716ad99..64e668852 100644 --- a/R/Reporter.R +++ b/R/Reporter.R @@ -18,21 +18,25 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' initialize = function() { private$cards <- list() - private$reactive_add_card <- shiny::reactiveVal(0) + private$reactive_add_card <- shiny::reactiveVal(Sys.time()) invisible(self) }, + #' @description Trigger reactive card update, needed for additional appended user-text to update UI + trigger_reactive_add_card = function() { + private$reactive_add_card(Sys.time()) # sys.time chosen to update UI + }, #' @description Append one or more `ReportCard` objects to the `Reporter`. #' #' @param cards (`ReportCard`) or a list of such objects #' @return `self`, invisibly. - #' @examplesIf require("ggplot2") + #' @examples #' library(ggplot2) #' library(rtables) #' #' card1 <- ReportCard$new() #' #' card1$append_text("Header 2 text", "header2") - #' card1$append_text("A paragraph of default text") + #' card1$append_text("A paragraph of default text", "header2") #' card1$append_plot( #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() #' ) @@ -40,10 +44,11 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' card2 <- ReportCard$new() #' #' card2$append_text("Header 2 text", "header2") - #' card2$append_text("A paragraph of default text") + #' card2$append_text("A paragraph of default text", "header2") #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) #' table_res2 <- build_table(lyt, airquality) #' card2$append_table(table_res2) + #' card2$append_table(iris) #' #' reporter <- Reporter$new() #' reporter$append_cards(list(card1, card2)) @@ -56,14 +61,14 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' @description Retrieves all `ReportCard` objects contained in the `Reporter`. #' #' @return A (`list`) of [`ReportCard`] objects. - #' @examplesIf require("ggplot2") + #' @examples #' library(ggplot2) #' library(rtables) #' #' card1 <- ReportCard$new() #' #' card1$append_text("Header 2 text", "header2") - #' card1$append_text("A paragraph of default text") + #' card1$append_text("A paragraph of default text", "header2") #' card1$append_plot( #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() #' ) @@ -71,10 +76,11 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' card2 <- ReportCard$new() #' #' card2$append_text("Header 2 text", "header2") - #' card2$append_text("A paragraph of default text") + #' card2$append_text("A paragraph of default text", "header2") #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) #' table_res2 <- build_table(lyt, airquality) #' card2$append_table(table_res2) + #' card2$append_table(iris) #' #' reporter <- Reporter$new() #' reporter$append_cards(list(card1, card2)) @@ -82,19 +88,20 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. get_cards = function() { private$cards }, + #' @description Compiles and returns all content blocks from the [`ReportCard`] in the `Reporter`. #' #' @param sep An optional separator to insert between each content block. #' Default is a `NewpageBlock$new()`object. #' @return `list()` list of `TableBlock`, `TextBlock`, `PictureBlock` and `NewpageBlock`. - #' @examplesIf require("ggplot2") + #' @examples #' library(ggplot2) #' library(rtables) #' #' card1 <- ReportCard$new() #' #' card1$append_text("Header 2 text", "header2") - #' card1$append_text("A paragraph of default text") + #' card1$append_text("A paragraph of default text", "header2") #' card1$append_plot( #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() #' ) @@ -102,10 +109,11 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' card2 <- ReportCard$new() #' #' card2$append_text("Header 2 text", "header2") - #' card2$append_text("A paragraph of default text") + #' card2$append_text("A paragraph of default text", "header2") #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) #' table_res2 <- build_table(lyt, airquality) #' card2$append_table(table_res2) + #' card2$append_table(iris) #' #' reporter <- Reporter$new() #' reporter$append_cards(list(card1, card2)) @@ -205,7 +213,7 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' @description #' Reinitializes a `Reporter` instance by copying the report cards and metadata from another `Reporter`. #' @param reporter (`Reporter`) instance to copy from. - #' @return invisibly self + #' @return `self`, invisibly. #' @examples #' reporter <- Reporter$new() #' reporter$from_reporter(reporter) @@ -220,6 +228,7 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' @param output_dir (`character(1)`) a path to the directory where files will be copied. #' @return `named list` representing the `Reporter` instance, including version information, #' metadata, and report cards. + #' #' @examples #' reporter <- Reporter$new() #' tmp_dir <- file.path(tempdir(), "testdir") @@ -227,7 +236,7 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' reporter$to_list(tmp_dir) to_list = function(output_dir) { checkmate::assert_directory_exists(output_dir) - rlist <- list(name = "teal Reporter", version = "1", id = self$get_id(), cards = list()) + rlist <- list(version = "1", cards = list()) rlist[["metadata"]] <- self$get_metadata() for (card in self$get_cards()) { # we want to have list names being a class names to indicate the class for $from_list @@ -242,7 +251,6 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' @param rlist (`named list`) representing a `Reporter` instance. #' @param output_dir (`character(1)`) a path to the directory from which files will be copied. #' @return `self`, invisibly. - #' @note if Report has an id when converting to JSON then It will be compared to the currently available one. #' @examples #' reporter <- Reporter$new() #' tmp_dir <- file.path(tempdir(), "testdir") @@ -250,32 +258,23 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' dir.create(tmp_dir) #' reporter$from_list(reporter$to_list(tmp_dir), tmp_dir) from_list = function(rlist, output_dir) { - id <- self$get_id() checkmate::assert_list(rlist) checkmate::assert_directory_exists(output_dir) - stopifnot("Report JSON has to have name slot equal to teal Reporter" = rlist$name == "teal Reporter") - stopifnot("Loaded Report id has to match the current instance one" = rlist$id == id) - if (rlist$version %in% c("1")) { + if (rlist$version == "1") { new_cards <- list() cards_names <- names(rlist$cards) cards_names <- gsub("[.][0-9]*$", "", cards_names) for (iter_c in seq_along(rlist$cards)) { card_class <- cards_names[iter_c] card <- rlist$cards[[iter_c]] - new_card <- eval(str2lang(card_class))$new() + new_card <- eval(str2lang(sprintf("%s$new()", card_class))) new_card$from_list(card, output_dir) new_cards <- c(new_cards, new_card) } } else { - stop( - sprintf( - "The provided %s reporter version is not supported.", - rlist$version - ) - ) + stop("The provided version is not supported") } self$reset() - self$set_id(rlist$id) self$append_cards(new_cards) self$append_metadata(rlist$metadata) invisible(self) @@ -291,8 +290,7 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. to_jsondir = function(output_dir) { checkmate::assert_directory_exists(output_dir) json <- self$to_list(output_dir) - cat( - jsonlite::toJSON(json, auto_unbox = TRUE, force = TRUE), + cat(jsonlite::toJSON(json, auto_unbox = TRUE, force = TRUE), file = file.path(output_dir, "Report.json") ) output_dir @@ -300,7 +298,6 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' @description Reinitializes a `Reporter` from a `JSON ` file and files in a specified directory. #' @param output_dir (`character(1)`) a path to the directory with files, `JSON` and statics. #' @return `self`, invisibly. - #' @note if Report has an id when converting to JSON then It will be compared to the currently available one. #' @examples #' reporter <- Reporter$new() #' tmp_dir <- file.path(tempdir(), "jsondir") @@ -310,31 +307,74 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' reporter$from_jsondir(tmp_dir) from_jsondir = function(output_dir) { checkmate::assert_directory_exists(output_dir) + checkmate::assert_true(length(list.files(output_dir)) > 0) dir_files <- list.files(output_dir) - stopifnot("There has to be at least one file in the loaded directory" = length(dir_files) > 0) - stopifnot("Report.json file has to be in the loaded directory" = "Report.json" %in% basename(dir_files)) - json <- jsonlite::read_json(file.path(output_dir, "Report.json")) + which_json <- grep("json$", dir_files) + json <- jsonlite::read_json(file.path(output_dir, dir_files[which_json])) self$reset() self$from_list(json, output_dir) invisible(self) }, - #' @description Set the `Reporter` id - #' Optionally add id to a `Reporter` which will be compared when it is rebuilt from a list. - #' The id is added to the downloaded file name. - #' @param id (`character(1)`) a Report id. - #' @return `self`, invisibly. - set_id = function(id) { - private$id <- id + #' @description Removes a block from a given `ReportCard` + #' + #' @param card_id (`numeric`) The id of the `ReportCard`. + #' @param block_id (`numeric`) The id of the removed block in the `ReportCard`. + #' @return self invisibly. + #' @examples + #' card1 <- ReportCard$new() + #' + #' card1$append_text("Header 2 text", "header2") + #' card1$append_text("A paragraph of default text", "header2") + #' + #' card2 <- ReportCard$new() + #' + #' card2$append_text("Header 2 text", "header2") + #' card2$append_text("A paragraph of default text", "header2") + #' + #' reporter <- Reporter$new() + #' reporter$append_cards(list(card1, card2)) + #' reporter$remove_block_from_card(2, 1) + #' reporter$get_blocks() + #' + remove_block_from_card = function(card_id, block_id) { + checkmate::assert_number(card_id, lower = 1, upper = length(private$cards)) + private$cards[[card_id]]$remove_block(block_id) invisible(self) }, - #' @description Get the `Reporter` id - #' @return `character(1)` the `Reporter` id. - get_id = function() { - private$id + #' @description Appends additional user-entered text to a block in the `ReportCard` + #' + #' @param card_id (`numeric`) The id of the `ReportCard`. + #' @param text (`character`) Text to be added to block of the `ReportCard`. + #' @param block_id (`numeric`) The id of the block. + #' @return self invisibly. + add_text = function(card_id, text) { + checkmate::assert_number(card_id, lower = 1, upper = length(private$cards)) + private$cards[[card_id]]$append_text(as.character(text), "verbatim") + invisible(self) + }, + #' @description Modify user-entered text to a block in the `ReportCard` + #' + #' @param card_id (`numeric`) The id of the `ReportCard`. + #' @param text (`character`) Text to be modified in block of the `ReportCard`. + #' @param block_id (`numeric`) The id of the block. + #' @return self invisibly. + modify_text = function(card_id, block_id, text) { + checkmate::assert_number(card_id, lower = 1, upper = length(private$cards)) + as.list(private$cards[[as.numeric(card_id)]]$get_content()[[as.numeric(block_id)]])$set_content(as.character(text)) + invisible(self) + }, + #' @description Retrieve user entered text of a block in the `ReportCard` + #' + #' @param card_id (`numeric`) The id of the `ReportCard`. + #' @param block_id (`numeric`) The id of the block. + #' @return user-entered block text. + get_text = function(card_id, block_id) { + checkmate::assert_number(card_id, lower = 1, upper = length(private$cards)) + private$cards[[as.numeric(card_id)]]$get_content()[[as.numeric(block_id)]]$get_content() } + ), private = list( - id = "", cards = list(), metadata = list(), reactive_add_card = NULL, From ee178a35b6d03009dce07c7f9964499feae8c64f Mon Sep 17 00:00:00 2001 From: Mike Briganti <86301883+mikebriganti@users.noreply.github.com> Date: Fri, 31 Jan 2025 09:19:32 -0500 Subject: [PATCH 2/7] Update Reporter.R Signed-off-by: Mike Briganti <86301883+mikebriganti@users.noreply.github.com> --- R/Reporter.R | 126 ++++++++++++++++++--------------------------------- 1 file changed, 43 insertions(+), 83 deletions(-) diff --git a/R/Reporter.R b/R/Reporter.R index 64e668852..37716ad99 100644 --- a/R/Reporter.R +++ b/R/Reporter.R @@ -18,25 +18,21 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' initialize = function() { private$cards <- list() - private$reactive_add_card <- shiny::reactiveVal(Sys.time()) + private$reactive_add_card <- shiny::reactiveVal(0) invisible(self) }, - #' @description Trigger reactive card update, needed for additional appended user-text to update UI - trigger_reactive_add_card = function() { - private$reactive_add_card(Sys.time()) # sys.time chosen to update UI - }, #' @description Append one or more `ReportCard` objects to the `Reporter`. #' #' @param cards (`ReportCard`) or a list of such objects #' @return `self`, invisibly. - #' @examples + #' @examplesIf require("ggplot2") #' library(ggplot2) #' library(rtables) #' #' card1 <- ReportCard$new() #' #' card1$append_text("Header 2 text", "header2") - #' card1$append_text("A paragraph of default text", "header2") + #' card1$append_text("A paragraph of default text") #' card1$append_plot( #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() #' ) @@ -44,11 +40,10 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' card2 <- ReportCard$new() #' #' card2$append_text("Header 2 text", "header2") - #' card2$append_text("A paragraph of default text", "header2") + #' card2$append_text("A paragraph of default text") #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) #' table_res2 <- build_table(lyt, airquality) #' card2$append_table(table_res2) - #' card2$append_table(iris) #' #' reporter <- Reporter$new() #' reporter$append_cards(list(card1, card2)) @@ -61,14 +56,14 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' @description Retrieves all `ReportCard` objects contained in the `Reporter`. #' #' @return A (`list`) of [`ReportCard`] objects. - #' @examples + #' @examplesIf require("ggplot2") #' library(ggplot2) #' library(rtables) #' #' card1 <- ReportCard$new() #' #' card1$append_text("Header 2 text", "header2") - #' card1$append_text("A paragraph of default text", "header2") + #' card1$append_text("A paragraph of default text") #' card1$append_plot( #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() #' ) @@ -76,11 +71,10 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' card2 <- ReportCard$new() #' #' card2$append_text("Header 2 text", "header2") - #' card2$append_text("A paragraph of default text", "header2") + #' card2$append_text("A paragraph of default text") #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) #' table_res2 <- build_table(lyt, airquality) #' card2$append_table(table_res2) - #' card2$append_table(iris) #' #' reporter <- Reporter$new() #' reporter$append_cards(list(card1, card2)) @@ -88,20 +82,19 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. get_cards = function() { private$cards }, - #' @description Compiles and returns all content blocks from the [`ReportCard`] in the `Reporter`. #' #' @param sep An optional separator to insert between each content block. #' Default is a `NewpageBlock$new()`object. #' @return `list()` list of `TableBlock`, `TextBlock`, `PictureBlock` and `NewpageBlock`. - #' @examples + #' @examplesIf require("ggplot2") #' library(ggplot2) #' library(rtables) #' #' card1 <- ReportCard$new() #' #' card1$append_text("Header 2 text", "header2") - #' card1$append_text("A paragraph of default text", "header2") + #' card1$append_text("A paragraph of default text") #' card1$append_plot( #' ggplot(iris, aes(x = Petal.Length)) + geom_histogram() #' ) @@ -109,11 +102,10 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' card2 <- ReportCard$new() #' #' card2$append_text("Header 2 text", "header2") - #' card2$append_text("A paragraph of default text", "header2") + #' card2$append_text("A paragraph of default text") #' lyt <- analyze(split_rows_by(basic_table(), "Day"), "Ozone", afun = mean) #' table_res2 <- build_table(lyt, airquality) #' card2$append_table(table_res2) - #' card2$append_table(iris) #' #' reporter <- Reporter$new() #' reporter$append_cards(list(card1, card2)) @@ -213,7 +205,7 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' @description #' Reinitializes a `Reporter` instance by copying the report cards and metadata from another `Reporter`. #' @param reporter (`Reporter`) instance to copy from. - #' @return `self`, invisibly. + #' @return invisibly self #' @examples #' reporter <- Reporter$new() #' reporter$from_reporter(reporter) @@ -228,7 +220,6 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' @param output_dir (`character(1)`) a path to the directory where files will be copied. #' @return `named list` representing the `Reporter` instance, including version information, #' metadata, and report cards. - #' #' @examples #' reporter <- Reporter$new() #' tmp_dir <- file.path(tempdir(), "testdir") @@ -236,7 +227,7 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' reporter$to_list(tmp_dir) to_list = function(output_dir) { checkmate::assert_directory_exists(output_dir) - rlist <- list(version = "1", cards = list()) + rlist <- list(name = "teal Reporter", version = "1", id = self$get_id(), cards = list()) rlist[["metadata"]] <- self$get_metadata() for (card in self$get_cards()) { # we want to have list names being a class names to indicate the class for $from_list @@ -251,6 +242,7 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' @param rlist (`named list`) representing a `Reporter` instance. #' @param output_dir (`character(1)`) a path to the directory from which files will be copied. #' @return `self`, invisibly. + #' @note if Report has an id when converting to JSON then It will be compared to the currently available one. #' @examples #' reporter <- Reporter$new() #' tmp_dir <- file.path(tempdir(), "testdir") @@ -258,23 +250,32 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' dir.create(tmp_dir) #' reporter$from_list(reporter$to_list(tmp_dir), tmp_dir) from_list = function(rlist, output_dir) { + id <- self$get_id() checkmate::assert_list(rlist) checkmate::assert_directory_exists(output_dir) - if (rlist$version == "1") { + stopifnot("Report JSON has to have name slot equal to teal Reporter" = rlist$name == "teal Reporter") + stopifnot("Loaded Report id has to match the current instance one" = rlist$id == id) + if (rlist$version %in% c("1")) { new_cards <- list() cards_names <- names(rlist$cards) cards_names <- gsub("[.][0-9]*$", "", cards_names) for (iter_c in seq_along(rlist$cards)) { card_class <- cards_names[iter_c] card <- rlist$cards[[iter_c]] - new_card <- eval(str2lang(sprintf("%s$new()", card_class))) + new_card <- eval(str2lang(card_class))$new() new_card$from_list(card, output_dir) new_cards <- c(new_cards, new_card) } } else { - stop("The provided version is not supported") + stop( + sprintf( + "The provided %s reporter version is not supported.", + rlist$version + ) + ) } self$reset() + self$set_id(rlist$id) self$append_cards(new_cards) self$append_metadata(rlist$metadata) invisible(self) @@ -290,7 +291,8 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. to_jsondir = function(output_dir) { checkmate::assert_directory_exists(output_dir) json <- self$to_list(output_dir) - cat(jsonlite::toJSON(json, auto_unbox = TRUE, force = TRUE), + cat( + jsonlite::toJSON(json, auto_unbox = TRUE, force = TRUE), file = file.path(output_dir, "Report.json") ) output_dir @@ -298,6 +300,7 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' @description Reinitializes a `Reporter` from a `JSON ` file and files in a specified directory. #' @param output_dir (`character(1)`) a path to the directory with files, `JSON` and statics. #' @return `self`, invisibly. + #' @note if Report has an id when converting to JSON then It will be compared to the currently available one. #' @examples #' reporter <- Reporter$new() #' tmp_dir <- file.path(tempdir(), "jsondir") @@ -307,74 +310,31 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' reporter$from_jsondir(tmp_dir) from_jsondir = function(output_dir) { checkmate::assert_directory_exists(output_dir) - checkmate::assert_true(length(list.files(output_dir)) > 0) dir_files <- list.files(output_dir) - which_json <- grep("json$", dir_files) - json <- jsonlite::read_json(file.path(output_dir, dir_files[which_json])) + stopifnot("There has to be at least one file in the loaded directory" = length(dir_files) > 0) + stopifnot("Report.json file has to be in the loaded directory" = "Report.json" %in% basename(dir_files)) + json <- jsonlite::read_json(file.path(output_dir, "Report.json")) self$reset() self$from_list(json, output_dir) invisible(self) }, - #' @description Removes a block from a given `ReportCard` - #' - #' @param card_id (`numeric`) The id of the `ReportCard`. - #' @param block_id (`numeric`) The id of the removed block in the `ReportCard`. - #' @return self invisibly. - #' @examples - #' card1 <- ReportCard$new() - #' - #' card1$append_text("Header 2 text", "header2") - #' card1$append_text("A paragraph of default text", "header2") - #' - #' card2 <- ReportCard$new() - #' - #' card2$append_text("Header 2 text", "header2") - #' card2$append_text("A paragraph of default text", "header2") - #' - #' reporter <- Reporter$new() - #' reporter$append_cards(list(card1, card2)) - #' reporter$remove_block_from_card(2, 1) - #' reporter$get_blocks() - #' - remove_block_from_card = function(card_id, block_id) { - checkmate::assert_number(card_id, lower = 1, upper = length(private$cards)) - private$cards[[card_id]]$remove_block(block_id) - invisible(self) - }, - #' @description Appends additional user-entered text to a block in the `ReportCard` - #' - #' @param card_id (`numeric`) The id of the `ReportCard`. - #' @param text (`character`) Text to be added to block of the `ReportCard`. - #' @param block_id (`numeric`) The id of the block. - #' @return self invisibly. - add_text = function(card_id, text) { - checkmate::assert_number(card_id, lower = 1, upper = length(private$cards)) - private$cards[[card_id]]$append_text(as.character(text), "verbatim") - invisible(self) - }, - #' @description Modify user-entered text to a block in the `ReportCard` - #' - #' @param card_id (`numeric`) The id of the `ReportCard`. - #' @param text (`character`) Text to be modified in block of the `ReportCard`. - #' @param block_id (`numeric`) The id of the block. - #' @return self invisibly. - modify_text = function(card_id, block_id, text) { - checkmate::assert_number(card_id, lower = 1, upper = length(private$cards)) - as.list(private$cards[[as.numeric(card_id)]]$get_content()[[as.numeric(block_id)]])$set_content(as.character(text)) + #' @description Set the `Reporter` id + #' Optionally add id to a `Reporter` which will be compared when it is rebuilt from a list. + #' The id is added to the downloaded file name. + #' @param id (`character(1)`) a Report id. + #' @return `self`, invisibly. + set_id = function(id) { + private$id <- id invisible(self) }, - #' @description Retrieve user entered text of a block in the `ReportCard` - #' - #' @param card_id (`numeric`) The id of the `ReportCard`. - #' @param block_id (`numeric`) The id of the block. - #' @return user-entered block text. - get_text = function(card_id, block_id) { - checkmate::assert_number(card_id, lower = 1, upper = length(private$cards)) - private$cards[[as.numeric(card_id)]]$get_content()[[as.numeric(block_id)]]$get_content() + #' @description Get the `Reporter` id + #' @return `character(1)` the `Reporter` id. + get_id = function() { + private$id } - ), private = list( + id = "", cards = list(), metadata = list(), reactive_add_card = NULL, From 5165dc11a697b86b5d3db35082e59229d8ba614c Mon Sep 17 00:00:00 2001 From: Mike Briganti <86301883+mikebriganti@users.noreply.github.com> Date: Fri, 31 Jan 2025 09:25:17 -0500 Subject: [PATCH 3/7] Update Reporter.R for editing capabilities Signed-off-by: Mike Briganti <86301883+mikebriganti@users.noreply.github.com> --- R/Reporter.R | 63 +++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 62 insertions(+), 1 deletion(-) diff --git a/R/Reporter.R b/R/Reporter.R index 37716ad99..053294e91 100644 --- a/R/Reporter.R +++ b/R/Reporter.R @@ -18,9 +18,13 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' initialize = function() { private$cards <- list() - private$reactive_add_card <- shiny::reactiveVal(0) + private$reactive_add_card <- shiny::reactiveVal(Sys.time()) invisible(self) }, + #' @description Trigger reactive card update, needed for additional appended user-text to update UI + trigger_reactive_add_card = function() { + private$reactive_add_card(Sys.time()) # sys.time chosen to update UI + }, #' @description Append one or more `ReportCard` objects to the `Reporter`. #' #' @param cards (`ReportCard`) or a list of such objects @@ -331,6 +335,63 @@ Reporter <- R6::R6Class( # nolint: object_name_linter. #' @return `character(1)` the `Reporter` id. get_id = function() { private$id + }, + #' @description Removes a block from a given `ReportCard` + #' + #' @param card_id (`numeric`) The id of the `ReportCard`. + #' @param block_id (`numeric`) The id of the removed block in the `ReportCard`. + #' @return self invisibly. + #' @examples + #' card1 <- ReportCard$new() + #' + #' card1$append_text("Header 2 text", "header2") + #' card1$append_text("A paragraph of default text", "header2") + #' + #' card2 <- ReportCard$new() + #' + #' card2$append_text("Header 2 text", "header2") + #' card2$append_text("A paragraph of default text", "header2") + #' + #' reporter <- Reporter$new() + #' reporter$append_cards(list(card1, card2)) + #' reporter$remove_block_from_card(2, 1) + #' reporter$get_blocks() + #' + remove_block_from_card = function(card_id, block_id) { + checkmate::assert_number(card_id, lower = 1, upper = length(private$cards)) + private$cards[[card_id]]$remove_block(block_id) + invisible(self) + }, + #' @description Appends additional user-entered text to a block in the `ReportCard` + #' + #' @param card_id (`numeric`) The id of the `ReportCard`. + #' @param text (`character`) Text to be added to block of the `ReportCard`. + #' @param block_id (`numeric`) The id of the block. + #' @return self invisibly. + add_text = function(card_id, text) { + checkmate::assert_number(card_id, lower = 1, upper = length(private$cards)) + private$cards[[card_id]]$append_text(as.character(text), "verbatim") + invisible(self) + }, + #' @description Modify user-entered text to a block in the `ReportCard` + #' + #' @param card_id (`numeric`) The id of the `ReportCard`. + #' @param text (`character`) Text to be modified in block of the `ReportCard`. + #' @param block_id (`numeric`) The id of the block. + #' @return self invisibly. + modify_text = function(card_id, block_id, text) { + checkmate::assert_number(card_id, lower = 1, upper = length(private$cards)) + as.list(private$cards[[as.numeric(card_id)]]$get_content()[[as.numeric(block_id)]])$set_content(as.character(text)) + invisible(self) + }, + #' @description Retrieve user entered text of a block in the `ReportCard` + #' + #' @param card_id (`numeric`) The id of the `ReportCard`. + #' @param block_id (`numeric`) The id of the block. + #' @return user-entered block text. + get_text = function(card_id, block_id) { + checkmate::assert_number(card_id, lower = 1, upper = length(private$cards)) + private$cards[[as.numeric(card_id)]]$get_content()[[as.numeric(block_id)]]$get_content() } ), private = list( From 671e1f8257222df0ff303c41914276f8bcaed6df Mon Sep 17 00:00:00 2001 From: Mike Briganti <86301883+mikebriganti@users.noreply.github.com> Date: Fri, 31 Jan 2025 09:30:06 -0500 Subject: [PATCH 4/7] Update ReportCard.R Signed-off-by: Mike Briganti <86301883+mikebriganti@users.noreply.github.com> --- R/ReportCard.R | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/R/ReportCard.R b/R/ReportCard.R index 34967041f..3986199c0 100644 --- a/R/ReportCard.R +++ b/R/ReportCard.R @@ -256,6 +256,21 @@ ReportCard <- R6::R6Class( # nolint: object_name_linter. } self$set_name(name) invisible(self) + }, + #' @description Removes a block from this `ReportCard`. + #' @param block_id (`numeric`) the removed block number. + #' @return `self`, invisibly. + #' @examples + #' + #' card <- ReportCard$new()$append_text("Some text") + #' card$append_text("Another text") + #' + #' card$remove_block(1) + #' card$get_content() + remove_block = function(block_id) { + checkmate::assert_number(block_id, lower = 1, upper = length(private$content), finite = TRUE) + private$content <- private$content[-c(block_id)] + invisible(self) } ), private = list( From 3b4f0279713c4f64b3f04fcbc2eda2dcc3754f18 Mon Sep 17 00:00:00 2001 From: Mike Briganti <86301883+mikebriganti@users.noreply.github.com> Date: Fri, 31 Jan 2025 09:31:37 -0500 Subject: [PATCH 5/7] Create Editor.R Signed-off-by: Mike Briganti <86301883+mikebriganti@users.noreply.github.com> --- R/Editor.R | 556 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 556 insertions(+) create mode 100644 R/Editor.R diff --git a/R/Editor.R b/R/Editor.R new file mode 100644 index 000000000..d562a52d1 --- /dev/null +++ b/R/Editor.R @@ -0,0 +1,556 @@ +#' Report previewer module +#' +#' @description `r lifecycle::badge("experimental")` +#' +#' Module offers functionalities to visualize, manipulate, +#' and interact with report cards that have been added to a report. +#' It includes a previewer interface to see the cards and options to modify the report before downloading. +#' +#' For more details see the vignette: `vignette("previewerReporter", "teal.reporter")`. +#' +#' @details `r global_knitr_details()` +#' +#' @name reporter_editor +#' +#' @param id (`character(1)`) `shiny` module instance id. +#' @param reporter (`Reporter`) instance. +#' @param global_knitr (`list`) of `knitr` parameters (passed to `knitr::opts_chunk$set`) +#' for customizing the rendering process. +#' @inheritParams reporter_download_inputs +#' +#' @return `NULL`. +NULL + +#' @rdname reporter_editor +#' @export +reporter_editor_ui <- function(id) { + ns <- shiny::NS(id) + + shiny::fluidRow( + add_editor_js(ns), + add_previewer_css(), + shiny::tagList( + shiny::tags$div(class = "col-md-3", shiny::tags$div(class = "well", shiny::uiOutput(ns("encoding")))), + shiny::tags$div(class = "col-md-9", shiny::tags$div(id = "reporter_previewer", shiny::uiOutput(ns("pcards")))) + ) + ) +} + +#' @rdname reporter_editor +#' @export +reporter_editor_srv <- function(id, + reporter, + global_knitr = getOption("teal.reporter.global_knitr"), + rmd_output = c( + "html" = "html_document", + "pdf" = "pdf_document", + "powerpoint" = "powerpoint_presentation", + "word" = "word_document" + ), + rmd_yaml_args = list( + author = "NEST", + title = "Report", + date = as.character(Sys.Date()), + output = "html_document", + toc = FALSE + )) { + checkmate::assert_class(reporter, "Reporter") + checkmate::assert_subset(names(global_knitr), names(knitr::opts_chunk$get())) + checkmate::assert_subset( + rmd_output, + c("html_document", "pdf_document", "powerpoint_presentation", "word_document"), + empty.ok = FALSE + ) + checkmate::assert_list(rmd_yaml_args, names = "named") + checkmate::assert_names( + names(rmd_yaml_args), + subset.of = c("author", "title", "date", "output", "toc"), + must.include = "output" + ) + checkmate::assert_true(rmd_yaml_args[["output"]] %in% rmd_output) + + shiny::moduleServer(id, function(input, output, session) { + ns <- session$ns + + teal.reporter::reset_report_button_srv("resetButtonPreviewer", reporter) + + output$encoding <- shiny::renderUI({ + reporter$get_reactive_add_card() + shiny::tagList( + shiny::tags$h3("Download the Report"), + shiny::tags$hr(), + reporter_download_inputs( + rmd_yaml_args = rmd_yaml_args, + rmd_output = rmd_output, + showrcode = any_rcode_block(reporter), + session = session + ), + htmltools::tagAppendAttributes( + shiny::tags$a( + id = ns("download_data_prev"), + class = "btn btn-primary shiny-download-link", + href = "", + target = "_blank", + download = NA, + shiny::tags$span("Download Report", shiny::icon("download")) + ), + class = if (length(reporter$get_cards())) "" else "disabled" + ), + teal.reporter::reset_report_button_ui(ns("resetButtonPreviewer"), label = "Reset Report") + ) + }) + + output$pcards <- shiny::renderUI({ + reporter$get_reactive_add_card() + input$card_remove_id + input$card_down_id + input$card_up_id + input$block_remove_event + input$block_add_event + input$block_modify_event + + cards <- reporter$get_cards() + + if (length(cards)) { + shiny::tags$div( + class = "panel-group accordion", + id = "reporter_previewer_panel", + lapply(seq_along(cards), function(ic) { + previewer_collapse_item(ic, cards[[ic]]$get_name(), cards[[ic]]$get_content()) + }) + ) + } else { + shiny::tags$div( + id = "reporter_previewer_panel_no_cards", + shiny::tags$p(class = "text-danger mt-4", shiny::tags$strong("No Cards added")) + ) + } + }) + + shiny::observeEvent(input$card_remove_id, { + shiny::showModal( + shiny::modalDialog( + title = "Remove the Report Card", + shiny::tags$p( + shiny::HTML( + sprintf( + "Do you really want to remove the card %s from the Report?", + input$card_remove_id + ) + ) + ), + footer = shiny::tagList( + shiny::tags$button( + type = "button", + class = "btn btn-secondary", + `data-dismiss` = "modal", + `data-bs-dismiss` = "modal", + NULL, + "Cancel" + ), + shiny::actionButton(ns("remove_card_ok"), "OK", class = "btn-danger") + ) + ) + ) + }) + + shiny::observeEvent(input$remove_card_ok, { + reporter$remove_cards(input$card_remove_id) + shiny::removeModal() + }) + + shiny::observeEvent(input$block_add_event, { + shiny::showModal( + shiny::modalDialog( + title = "Select Title", + selectInput(ns("selectTitle"), + label = "Select Title", + choices = c("Generate Custom Title & Footer", unique(titles$TABLE.ID)), + selected = "Generate Custom Title & Footer"), + footer = shiny::tagList( + shiny::tags$button( + type = "button", + class = "btn btn-secondary", + `data-dismiss` = "modal", + `data-bs-dismiss` = "modal", + NULL, + "Cancel" + ), + shiny::actionButton(ns("submit_text"), "Change title", class = "btn-danger") + ) + ) + ) + }) + + verboseTitle <- reactive({ + titles %>% + dplyr::filter(titles$TABLE.ID == input$selectTitle, titles$IDENTIFIER == "TITLE") %>% + dplyr::mutate(TEXT = paste0(TABLE.ID, ": ", TEXT)) %>% + dplyr::select(TEXT) + }) + + footer <- reactive({ + titles %>% + dplyr::filter(titles$TABLE.ID == input$selectTitle, titles$IDENTIFIER != "TITLE") %>% + dplyr::select(TEXT) %>% + dplyr::summarise(TEXT = paste(TEXT, collapse = "\n")) + }) + + shiny::observeEvent(input$submit_text, { + reporter$modify_text(as.integer(input$block_add_event[1]), 1, verboseTitle()) + + temp <- reporter$get_text(as.integer(input$block_add_event[1]), 3) + + reporter$remove_block_from_card(as.integer(input$block_add_event[1]), 3) + + reporter$add_text(as.integer(input$block_add_event[1]), footer()) + + reporter$add_text(as.integer(input$block_add_event[1]), as.character(temp)) + + reporter$trigger_reactive_add_card() + + shiny::removeModal() + }) + + shiny::observeEvent(input$block_modify_event, { + shiny::showModal( + shiny::modalDialog( + title = "Modify Text", + shiny::textAreaInput(ns("user_input"), + label = "Modify Text:", + value = reporter$get_text(card_id = as.numeric(input$block_modify_event[1]), block_id = input$block_modify_event[2]), + width = "100%", + height = "200px"), + footer = shiny::tagList( + shiny::tags$button( + type = "button", + class = "btn btn-secondary", + `data-dismiss` = "modal", + `data-bs-dismiss` = "modal", + NULL, + "Cancel" + ), + shiny::actionButton(ns("submit_text2"), "Change text", class = "btn-danger") + ) + ) + ) + }) + + shiny::observeEvent(input$submit_text2, { + reporter$modify_text(as.integer(input$block_modify_event[1]), input$block_modify_event[2], input$user_input) + + reporter$trigger_reactive_add_card() + + shiny::removeModal() + }) + + shiny::observeEvent(input$card_up_id, { + if (input$card_up_id > 1) { + reporter$swap_cards(as.integer(input$card_up_id), as.integer(input$card_up_id - 1)) + } + }) + + shiny::observeEvent(input$card_down_id, { + if (input$card_down_id < length(reporter$get_cards())) { + reporter$swap_cards(as.integer(input$card_down_id), as.integer(input$card_down_id + 1)) + } + }) + + shiny::observeEvent(input$block_remove_event, { + reporter$remove_block_from_card(as.integer(input$block_remove_event[1]), as.integer(input$block_remove_event[2])) + }) + + output$download_data_prev <- shiny::downloadHandler( + filename = function() { + paste("report_", format(Sys.time(), "%y%m%d%H%M%S"), ".zip", sep = "") + }, + content = function(file) { + shiny::showNotification("Rendering and Downloading the document.") + shinybusy::block(id = ns("download_data_prev"), text = "", type = "dots") + input_list <- lapply(names(rmd_yaml_args), function(x) input[[x]]) + names(input_list) <- names(rmd_yaml_args) + if (is.logical(input$showrcode)) global_knitr[["echo"]] <- input$showrcode + report_render_and_compress(reporter, input_list, global_knitr, file) + shinybusy::unblock(id = ns("download_data_prev")) + }, + contentType = "application/zip" + ) + }) +} + +#' @noRd +#' @keywords internal +block_to_editor_html <- function(card_id, block_id, block) { + b_content <- block$get_content() + if (inherits(block, "TextBlock")) { + shiny::tags$span( + class = paste("row", "align-middle"), + switch(block$get_style(), + header1 = shiny::tags$h1(class = "col-md-9", b_content), + header2 = shiny::tags$h2(class = "col-md-9", b_content), + header3 = shiny::tags$h3(class = "col-md-9", b_content), + header4 = shiny::tags$h4(class = "col-md-9", b_content), + verbatim = shiny::tags$pre(b_content), + shiny::tags$pre(b_content) + ), + shiny::tags$div(class="col-md-2", title = "Delete or modify text", + block_delete_button("block_delete", "trash", card_id, block_id, style = ""), + block_modify_button("block_modify", "pencil", card_id, block_id, style = "") + ) + ) + } else if (inherits(block, "RcodeBlock")) { + better_panel_item( + title = "R Code", + title_buttons = block_delete_button(class_name = "block_delete", "trash", card_id, block_id, style = "width:50px;height:25px;margin-left:20px;padding:2px"), + shiny::tags$pre(b_content) + ) + } else if (inherits(block, "PictureBlock")) { + shiny::tags$img(src = knitr::image_uri(b_content)) + } else if (inherits(block, "TableBlock")) { + b_table <- readRDS(b_content) + shiny::tags$pre(flextable::htmltools_value(b_table)) + } else if (inherits(block, "NewpageBlock")) { + shiny::tags$br() + } else { + stop("Unknown block class") + } +} + +#' @noRd +#' @keywords internal +add_previewer_css <- function() { + shiny::tagList( + shiny::singleton(shiny::tags$head(shiny::includeCSS(system.file("css/Previewer.css", package = "teal.reporter")))), + shiny::singleton(shiny::tags$head(shiny::includeCSS(system.file("css/custom.css", package = "teal.reporter")))) + ) +} + +#' @noRd +#' @keywords internal +add_editor_js <- function(ns) { + shiny::singleton( + shiny::tags$head( + shiny::tags$script( + shiny::HTML( + sprintf( + ' + $(document).ready(function(event) { + $("body").on("click", "span.card_remove_id", function() { + let val = $(this).data("cardid"); + Shiny.setInputValue("%s", val, {priority: "event"}); + }); + + $("body").on("click", "span.card_up_id", function() { + let val = $(this).data("cardid"); + Shiny.setInputValue("%s", val, {priority: "event"}); + }); + + $("body").on("click", "span.card_down_id", function() { + let val = $(this).data("cardid"); + Shiny.setInputValue("%s", val, {priority: "event"}); + }); + }); + function removeCardBlock(element) { + let cardId = element.dataset.cardid; + let blockId = element.dataset.blockid; + Shiny.setInputValue("%s", [cardId, blockId], {priority: "event"}); + } + function addText(element) { + let cardId = element.dataset.cardid; + let blockId = element.dataset.blockid; + Shiny.setInputValue("%s", [cardId, blockId], {priority: "event"}); + } + function modifyTitle(element, event) { + + if (event) { + console.log("Preventing collapse"); + event.preventDefault(); + event.stopPropagation(); + } + + let cardId = element.dataset.cardid; + let blockId = element.dataset.blockid; + Shiny.setInputValue("%s", [cardId, blockId], {priority: "event"}); + } + ', + ns("card_remove_id"), + ns("card_up_id"), + ns("card_down_id"), + ns("block_remove_event"), + ns("block_add_event"), + ns("block_modify_event") + ) + ) + ) + ) + ) +} + +#' @noRd +#' @keywords internal +block_delete_button <- function(class_name, icon_name, card_idx, block_idx, style = "") { + checkmate::assert_string(class_name) + checkmate::assert_string(icon_name) + checkmate::assert_int(card_idx) + checkmate::assert_int(block_idx) + + shiny::tags$button( + class = paste(class_name, "btn", "btn-danger", "btn-lg"), + style = style, + onclick = "removeCardBlock(this)", + `data-blockid` = block_idx, + `data-cardid` = card_idx, + shiny::icon(icon_name, sprintf("fa-%sx", 1L)) + ) +} + +#' @noRd +#' @keywords internal +block_add_button <- function(class_name, icon_name, card_idx, block_idx, style = "", addedText) { + checkmate::assert_string(class_name) + checkmate::assert_string(icon_name) + checkmate::assert_string(addedText) + checkmate::assert_int(card_idx) + checkmate::assert_int(block_idx) + + shiny::tags$button( + class = paste(class_name, "btn", "btn-success", "btn-lg"), + style = style, + onclick = "addText(this)", + `data-blockid` = block_idx, + `data-cardid` = card_idx, + shiny::tagList( + shiny::icon(icon_name, class = sprintf("fa-%sx", 1L)), + addedText + ) + ) +} + +#' @noRd +#' @keywords internal +block_modify_button <- function(class_name, icon_name, card_idx, block_idx, style = "") { + checkmate::assert_string(class_name) + checkmate::assert_string(icon_name) + checkmate::assert_int(card_idx) + checkmate::assert_int(block_idx) + + shiny::tags$button( + class = paste(class_name, "btn", "btn-warning", "btn-lg"), + style = style, + onclick = "modifyTitle(this, event)", + `data-blockid` = block_idx, + `data-cardid` = card_idx, + shiny::icon(icon_name, sprintf("fa-%sx", 1L)) + ) +} + +#' @noRd +#' @keywords internal +nav_previewer_icon <- function(name, icon_name, idx, size = 1L) { + checkmate::assert_string(name) + checkmate::assert_string(icon_name) + checkmate::assert_int(size) + + shiny::tags$span( + class = paste(name, "icon_previewer"), + # data field needed to record clicked card on the js side + `data-cardid` = idx, + shiny::icon(icon_name, sprintf("fa-%sx", size)) + ) +} + +#' @noRd +#' @keywords internal +nav_previewer_icons <- function(idx, size = 1L) { + shiny::tags$span( + class = "preview_card_control", + nav_previewer_icon(name = "card_remove_id", icon_name = "xmark", idx = idx, size = size), + nav_previewer_icon(name = "card_up_id", icon_name = "arrow-up", idx = idx, size = size), + nav_previewer_icon(name = "card_down_id", icon_name = "arrow-down", idx = idx, size = size) + ) +} + +#' @noRd +#' @keywords internal +previewer_collapse_item <- function(idx, card_name, card_blocks) { + shiny::tags$div( + .renderHook = function(x) { + # get bs version + version <- get_bs_version() + + if (version == "3") { + shiny::tags$div( + id = paste0("panel_card_", idx), + class = "panel panel-default", + shiny::tags$div( + class = "panel-heading overflow-auto", + shiny::tags$div( + class = "panel-title", + shiny::tags$span( + nav_previewer_icons(idx = idx), + shiny::tags$a( + class = "accordion-toggle block py-3 px-4 -my-3 -mx-4", + `data-toggle` = "collapse", + `data-parent` = "#reporter_previewer_panel", + href = paste0("#collapse", idx), + shiny::tags$h4(paste0("Card ", idx, ": ", card_name), shiny::icon("caret-down")) + ) + ) + ) + ), + shiny::tags$div( + id = paste0("collapse", idx), + class = "collapse out", + shiny::tags$div( + class = "panel-body", + shiny::tags$div( + block_add_button("block_add", "edit", card_id = idx, block_id = 1, style = "margin-left:20px;", "Select Title & Footer") + # block_add_button("block_add2", "plus", card_id = idx, block_id = 1, style = "", "Create New Title & Footer") + ), + shiny::tags$div(id = paste0("card", idx), lapply(seq_along(card_blocks), function(block_id) { + block_to_editor_html(card_id = idx, block_id = block_id, block = card_blocks[[block_id]]) + })) + ) + ) + ) + } else { + shiny::tags$div( + id = paste0("panel_card_", idx), + class = "card", + shiny::tags$div( + class = "overflow-auto", + shiny::tags$div( + class = "card-header", + shiny::tags$span( + nav_previewer_icons(idx = idx), + shiny::tags$a( + class = "accordion-toggle block py-3 px-4 -my-3 -mx-4", + # bs4 + `data-toggle` = "collapse", + # bs5 + `data-bs-toggle` = "collapse", + href = paste0("#collapse", idx), + shiny::tags$h4(paste0("Card ", idx, ": ", card_name), shiny::icon("caret-down")) + ) + ) + ) + ), + shiny::tags$div( + id = paste0("collapse", idx), + class = "collapse out", + # bs4 + `data-parent` = "#reporter_previewer_panel", + # bs5 + `data-bs-parent` = "#reporter_previewer_panel", + shiny::tags$div( + class = "card-body", + shiny::tags$div(id = paste0("card", idx), lapply(seq_along(card_blocks), function(block_id) { + block_to_editor_html(card_id = idx, block_id = block_id, block = card_blocks[[block_id]]) + })) + ) + ) + ) + } + } + ) +} From 9b749985829fc86fcdccc794510ef259af26cfe9 Mon Sep 17 00:00:00 2001 From: Mike Briganti <86301883+mikebriganti@users.noreply.github.com> Date: Fri, 31 Jan 2025 09:53:34 -0500 Subject: [PATCH 6/7] Create testApp.R Signed-off-by: Mike Briganti <86301883+mikebriganti@users.noreply.github.com> --- testApp.R | 93 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 93 insertions(+) create mode 100644 testApp.R diff --git a/testApp.R b/testApp.R new file mode 100644 index 000000000..ddcd7a739 --- /dev/null +++ b/testApp.R @@ -0,0 +1,93 @@ +library(shiny) +library(DT) +library(ggplot2) +library(teal.reporter) +library(xlsx) +library(dplyr) + +# replace this with medra version +medraVersion = "1.0" + +titles <- xlsx::read.xlsx("R/titles.xlsx", "Sheet1") %>% + dplyr::filter(dplyr::row_number() > 1) %>% + mutate(TEXT = case_when( + grepl("\\&meddrav\\..", TEXT) ~ gsub("\\&meddrav\\..", medraVersion, TEXT), + grepl("~\\{super a\\}", TEXT) ~ gsub("~\\{super a\\}", "ᵃ", TEXT), + grepl("~\\{super b\\}", TEXT) ~ gsub("~\\{super b\\}", "ᵇ", TEXT), + grepl("~\\{super c\\}", TEXT) ~ gsub("~\\{super c\\}", "ᶜ", TEXT), + grepl("~\\{super d\\}", TEXT) ~ gsub("~\\{super d\\}", "ᵈ", TEXT), + grepl("~\\{super e\\}", TEXT) ~ gsub("~\\{super e\\}", "ᵉ", TEXT), + grepl("~\\{super f\\}", TEXT) ~ gsub("~\\{super f\\}", "ᶠ", TEXT), + grepl("~\\{super g\\}", TEXT) ~ gsub("~\\{super g\\}", "ᵍ", TEXT), + grepl("~\\{super h\\}", TEXT) ~ gsub("~\\{super h\\}", "ʰ", TEXT), + grepl("~\\{super i\\}", TEXT) ~ gsub("~\\{super i\\}", "ⁱ", TEXT), + TRUE ~ TEXT + )) + +titles[nrow(titles) + 1,] = c("Generate Custom Title & Footer", + "TITLE", "Click Yellow Button To Modify This Title") + +titles[nrow(titles) + 1,] = c("Generate Custom Title & Footer", + "FOOTNOTE1", "Click Yellow Button To Modify This Footer") + +devtools::load_all() + +ui <- fluidPage( + titlePanel(""), + tabsetPanel( + tabPanel( + "main App", + tags$br(), + sidebarLayout( + sidebarPanel( + uiOutput("encoding") + ), + mainPanel( + plotOutput("dist_plot") + ) + ) + ), + ### REPORTER + tabPanel( + "Editor", + reporter_editor_ui("editor") + ) + ### + ) +) +server <- function(input, output, session) { + + output$encoding <- renderUI({ + tagList( + ### REPORTER + simple_reporter_ui("simple_reporter"), + ### + ) + }) + plot <- reactive({ + ggplot(data = mtcars, aes(x = mpg)) + + geom_histogram(binwidth = 8) + }) + output$dist_plot <- renderPlot(plot()) + + ### REPORTER + reporter <- Reporter$new() + card_fun <- function(card = ReportCard$new(), comment) { + card$set_name("Plot Module") + card$append_text("My plot", "header2") + card$append_plot(plot()) + card$append_rcode("x <- mtcars$mpg", + echo = TRUE, + eval = FALSE + ) + + if (!comment == "") { + card$append_text("Comment", "header3") + card$append_text(comment) + } + card + } + simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) + reporter_editor_srv("editor", reporter) +} +shinyApp(ui, server) From a640ea3cdf204808b30c524dbe623af986f49916 Mon Sep 17 00:00:00 2001 From: Mike Briganti <86301883+mikebriganti@users.noreply.github.com> Date: Fri, 31 Jan 2025 09:56:33 -0500 Subject: [PATCH 7/7] add title.xlsx example file Signed-off-by: Mike Briganti <86301883+mikebriganti@users.noreply.github.com> --- R/titles.xlsx | Bin 0 -> 11539 bytes 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 R/titles.xlsx diff --git a/R/titles.xlsx b/R/titles.xlsx new file mode 100644 index 0000000000000000000000000000000000000000..e0494e576f843c4d9f6a5db2634ca14eee3ae785 GIT binary patch literal 11539 zcmeHN1y>wtvmRW71smKYxI4ief@_e$ZSde8BsdJgf`s4%cPB{j-~oaJ2%g~Xa3|Tl zUv}BOzuuvYi^0FaUr$A^`9hfDCIO z>FD5Q;oxSh>E&eMYRKvdwx`H}hh@kHz(Vi;@AmEpH?k@M_WerzY?(MC~a_T&nT z&S&ok7*47y=P^^|R&}M4LoBP6@7m408eT(&L)Ut`k~cEAas^f|cij)Bs4ZPMYJU`@ z6{Eh4m=4t{@fYzeUMh(s3`QV_tG5l$b0DZN9wv83DTZu`mHkMYL@FCN;Ro<=fZ{V* zH(+#)juq(H?R4My3#GSB(joSC@Wc_?a@>cI+6(KvZ8-8$uXYpHA}@5M)+(W(-AAuP zo{H;Ak-`UkZjo}N zIVB+M%}lBBj=W}^NyzN^fx&qnDDE<2P!Z7AYSi24fblZJ;Ej5YC4eC71^F^txO~d` z#-K#+4e9|lDYHmevoKqVs!1#s&c5(O-H?%39LIV5_+pLQ{*NE9cRivx)C0b+f=+6) zR3n0H7l?3IllmnOR=(`_n*@mmyrjLVco$Wurj+a$jYLJi$A*7G-D`}ww`~Dx9pXrc zeiyxIyj`=|w4bN>KeI^(q=qs2+aG@xiQs0cviA}h#Yi?1OVLM!vR$P z=IC7{qoy2CM|Xw;0MMY0ZtP-V@5;vd^Y~u}|9|Y&e_49zp=GxG z=_|MSC}aeLge$>WQfG+NzV*O-waUr1egj@Fv8f1(9}ytW6>c z*t~?D$la}6XU5{KZ_e@kD);2dS(@FOpC&Yk}1Ix4ZDv?HGa)7=>b*RKRs-v*b}`B>Rm`E001WR4o`bF4@Va}Q%6U; zpJ6ml8|=8kk9FriaT{)5ZY;SH508VVE%vHjz2$wN-M%PgBH;?ybkkm==>6?Jp9*sR z(2tKVs4Kb7)(%^Rxdu)*{qzV&rQ`-@JETbaxRDjTWM(Z*?waIE+im1R^}^6b`a66n zCvJpqZX32q37#>HyhR6?xR`7xXeEG$xanz=NsX`(h3r@rO2u%A4YY%ol{P|(sw)lq zPp=aKB2Z=?rCpHHk)$gOW@1{mK)_y9hL5-x!3b~pjO?=4sDmx=sf&rze4@$rP7$OaSg~E3G_amHcl1U!HfF2^YiHEV z2?()5J5qXq5vLuo{8Af1wsiRsy1<9%ut0qt9V+BSr16_vaJfLM(PXeN_h%j_Ex(@p z5ls*gLbB}}HRa_p;W;jX}S!??77Yp z<9w|ckpY4DFR2Lu^_o~kq}f=FaMUW)t&nrw^ec_75zS1g6ha^|{IpXwvbuekFT51rc-_y%ɉw zLbx^gL34K^#7`Z}uMA}DUp zn!Esida*A(Hg@{FZ-HAXZxo9U_}+C+G&zCCf@YEjfr5Sl#P4Zb?AEnEJYKy|z5AFBfVWzoQn^jBXLSM(~TH$Gv!zKEN;^0P)R`a&c zRfW^8A~rJpze)SVG~StzZ_l4j!k4gc0}QY0NWOCjl#&t540ll;><@Ck>6uIFp1jZJ z4=3;zXVp|8W7W*?Z8KOfEbk~xv*snfZA-nIA_LuXXY;O+cx$D5 zwcLgQ@6i6uv%zi0R`}4^$p`grA^jFLI5H9qqM&(q=n~p3ro?`g zecuQj-N?iqPV-p!#L$^uLSNM@izbLm?#YLJxh58KMvyWyW5TG%hHm2bTa`L? zN!$^p3fYgFAz!QWKKPFynJJX68ul1`6_-CZ`F^{z8vb27JqZjT5tp!1oa3J%h}Ihq zT;ZJ%ack7D%WdqgupF>=4Ac?N(@*X_e8tErz3a>ett_NGCO;6dZpPRd~(4j z`K0Kw`Nh)d8Ct)^Y9)kukfX&hD`)O$Fy5CsYqCeKqj=5I$gxuL_vhW^t1aw~7VAXM z*VVG}6UQ$wI84Er+8^SCWN*bIU|vojiR@Y3L&_Z%oj8 zqIFArV}lyN{r#`Q>qG;LE($E^hKWi5qo1v$eC=0cahwnD8I`BL3dz91G0NNpx;|Ce zLtl7aYb4Vo*SWbZlJ3(bXX)U=>GVSZBBD#H<>4PY#~{KYGT>pM46n1lgWYvtzT6&} zF{$PBzI`VIcsv`Z2Ld7>Y^&vYihc2Z9n^=(YtJ}C!=!U=TJ@Lk&GyDAOi@jz@Lp?<+X%nLfJ7}KKn zp0u}ozX)%WOJ6%#8=@N-^x%FH`FICzfqU2C(H_mNl3}37y&vn2gY7}Ux59InlHCHD zk)jh%tQptoHa~}s?@cCwpM*x(7#=$t)jD@vGr+A6#C)*>1T?iH(sSo6Ni{L!W0nq% z4sn5YRNv2i6sb`QpncKqMW(j7qKjN3QwM@UjZ&aNNGZLuG7N8wCK$+hbR|l zG*RfBo}(PpDiOY>ps%lKPmg#-Kx)r&zIrq26xQs$D?T_zi48d_#nWWdft9L`m*tK! z=*;xrpYRUM>(UDWj><8mVgaAe``)*ecuLaJ&?28%xxh69OBMT?SxARfMz33BC894r zYLcr8mc_1+f+dIf`ns%C`$lR1a=9oy!zCYXbEW~Apb z724EY4{5LL&^Y<#cir3c`b{H<;&1g0Ix2LC>dLf`9L4aBjXP%M3^G-^JBj0a`0x+f zn1*GBdx%xLtaeA$q=Co*-_)9So%%MjKEadtMie>52~IC_Mjhd0vtAR2sSq z_+RW?e0$axM@IVeW_-ehcW;@Q)zSBI*DApOmg8#mJ0BZ)z_-33&bt|M(aZJC(Oa?p z>?SF;cHg7<8hW<&tCRD6GM{AwSj@o#QRN7!hJNh1O~x%t^i>5F#1&tmE0lr}j0^x6 z^Lx1h$#NNrrRekY#@-gDY|o3pnZ9#UJxm-9?a$qpG7!NI!x6o7vf%4s0*P=I**>3hr@~@~j$hy~Kx;V?3@H_?SqH`Uj@=kV}Sj3hfla3}uIz|oq)$%{6LUX9e zhtpG!IbG7@1W{C6D?V{64t~L0LzckJ6)E>UFx<0z<&XGu*}k}CUwx(V`b5Ghyf;?v z7%=YGn^QEWa;t1})@=HTL37ok$J1L7+&R9c7?Jsy))TmAtn1lu$UjewwH<{t+R}Vo zzK3{!+1$dMGO7>WM8JQu=4EW(yyj+;D4Z8fT7*K)m;XJHmIPl76JHt5v7m8w>^1#C z9m5_5EB==q@!*oUA_WYb49Pe{9%^G|w23MyffV-nGz%_Y$m7~!e))I9yon&gQS^E; zxl(s8^OTvvns3q3X}D%w0V=>U8(1rgdiV9+RIM^i#o>+j+B`XF>YGKp8bII1A|mFI zQWQhv;6;Seg+Oe>A&eRnOPUGy2G`@yEN@Ojo8{>EsY2sw7o$Yq6VWT1SrEyPk$)H1 z$0bi{S?Q}B)`km9xJVwhQnQH#X|>` zhE~{M7^O5Hb~A^yyi-LXJ}acFL78ddOTViu?NSb{yAJMBA?**@bG($Sbw{r$ z`OE7UMZu!jNlrqbC&B)KCEQ@}@gU2H^h6R{CHhFYSu%YiLxZ4nVVeCnx;QJ&RC=Z| zY)rS~L5J5uAD+;yv&kj75Z;e!j&GtoCn%MkgQHwnLydN8uZLyT?0Sc~j`GL{mbFP~ zH_$q0Ti5fEIKuhB#s`YP^!u3~OLJMpM zO)u|6zXV`i?G3uGGGo*aO?+0}>dhwIDKQ<2C^8DpGau=_yH=@Bggmu}ujkq$?FCXN8DF#j zJl5cb=jwvH%BwP7C3TSl7-A)QL>!|0*u6nnauktp$ z8Xi4iY507IN3cLD$Q*6X^TC)2yrlq`;(arQS~vdrV-ZguMdq0_$pBMsnZp9!GR{}- zR#Ud`1vIp^g48fa+wnOeA&1g?WnQ!sA%yjt?S75@L}eM$NsEjrtAwwva6Y|Fx+_<3 z4937TlC})U7QxGoU}vmWKm*6WoEBdfjLCtVk~L@^Bz;>fdk2Yg??zeC)TAKHx3N$i#7k z2?XZqBwilj6te_B5g)AtlxhC{@q^RefXv0NeFY&TYAth~Lc6k}gHwS;LU_4CQwiZK z`qQ$e4hP~q_v+Vs?IRq*D#o+9$PwtKaWmw?cZ6kq{#?wq>59H$B;)NAeyDN2A6#!{ z_W>}g{9@Ttv1ol$QtDr^hm#p3$4djvmo#A7?5(Gcvv~ zYQdoDv%2i`c=G0ou=E8cz9oLUwUuXVz#@xi-cSoChUGU?e5G3AWhDEd*s_})z7eLUF_JZ3icev=L<2)m2k&-*Rf(^`?b6}wJlml8Y(%Qyvd z?gn$=-7IYL&#}Ko>}+J=M5)hIa}iNpp(K~DZkLSd)9jVkV}r57k$UZ?B-nNb(X$N; zIn3C`lUB24LGXI>_<-wJge;Ff?_zG+q%>|B?gPfOTJQAbL%@vzQMh&wWiQn%ZpNBT zKRd=OpU{EuxFJX=9f~fg!AI4owFzf>HHSE#5`T_+>r+Ew(XqbnG`h~4el1)~Y>AP;{J9x6bj^&w zy7Ithj^%@R75|R~Toe}Jc+ezk`x`hF6@`etcwIcSs!%nWTf%PtkF!;=D8=!j8?*8e zUhD&xQN&}V?`^?H#z?hnDs}tJYkoQ}1x3{L?sj7R$b}tpKa9v7jfThz#G8ob$O-gI z?;Zu3if?*z!!i&4IQ6BiT6J>peX2d>JMFgDLDW@|Az*gptj^@;i6&T=JwO5 z*dF}nU^TUII0DI86q)o}$eA;k_FJl&I9a|jVYgs6X9rZj404f1PZO&q>_-C}#Q?`( zsL{CQNyE@wI`4^7fj~l_rE|Jd9>B&w>=CmPx{?Vbp);WqUXuP2Hd?ie;tk5jFqCW{ z5Ni#1))5$qFBt;?Ov3)4=Ae5rg{d~Su6!DTC-iZdBf$>c*sm{&+62pdFa{nMZY`9B-s$5^pGwgT&v; z%53Ab7Ms_?@ajjKJc4m5bgYE{l}U3c*@azJ$J~ ze|d#v9G?yIpjYOgJKmqK(89&l(E3vi92T!dX~)h-;(@FrH{g1g&{Rb9)?kFS7CA=ETZ0u!E4u zaS5-Eiw(~oO;ShV3yDvNs~Qs9^&ly!C`F3a9OU)7RtqbS=O*#w64O%H>hIK*+LnAH z_}18f13|rMvlM#OO0{eJcymn?ee-fTi7)**P30}Yzbz}Al7#s?bU9qmRRf`Cb4N2} z3pbEC$PL7%1TwX-mv^vq{JAvEu}+5&3M|BB9m)l4_!m<}J`U9)rzkRnPf+@0whELd zJ=pe&+m!Fj+i$ogPq{pgI;fi(M{CRBX&bk#7w$wS-o})5)I-SomwwfZs0k@2k z`MD+?^WS~P#@#;6w}??AHE8Lrj@pu{nXcnezsraLo$BJ-D!^{ABp>eTU9so44_zF6 z7Q-BVk4tQ;RckbDZyjomJS{eZfum_q3n%HDp?`^BOm}xbz5cKIaZX4nGlJ^I1)Az$ zL(8;K{iwP)I=Ql$Il5T<)C;uH`QPd+)Np(uYIe{scIXn)H74z7iA`xN_8h99?;DCD zd;1+qni-<$Jj#KByX$!*Zrm?kxhubi>lTM!t{Xt<|}j@+@OuR_~uXJmLhTF zs%yfN!CG};B&411AVj zton~(hnU*1WOM@}+RJGsS>F%|(_>$a$aMT#6Qb{RZ}2)+iBVnJJL6h361P;-3VUSPg-k?Y2Q1i#ix#XwA|lTu{8 z$t`PgcGWvJ62wW;Gr+GBW(S#YRzUFrw>}@{i+zUh!u{ka$Ff`ogaMf1vVx#m z+g=eMe+W&j{~1mgF;9E_phkHIHA<|%8YRfd>AyA!HO4=;49JiQv|}KBE_WljCh`Im z`Q0Fggz!gLseF80Vyg+=M)x&fPI846r`Aezaw1fnKBxOP3b8{?v zWis*a%%vtdSu;KZ;I07BkIHII#DX%9N(u- zhczlQ0ZRt;8e`A=9tEvAXT6pGf)#=@m}_apfY_&}c+bO}l@ljXJy{2k8iG&SrlBJ`aUe+L!Nx)&MiwIN4zLaSd`}GZ3kr2C~wd*R5?bJjm zf+B~-mMDL{Swb682u2}RnfwU6X{ib?x8E*tUY@b3cQ;X>syse=cRPt)U!Bm@q)|st zdnFg4m}ga7quUw`c}bJ}3DTjP(gGKHE8IxVD)9)(@u|*6qQB=-%R$()VNN6B;EJ8I za9g!>c-p?UA$LAi4-$i;%mFQM7wRC}@V@l<#Avt2^kj{^KjfG?)>6Sg;Q8&pWPgeSYyM55w;Uk46;d?E=}j@=>^ham(H z&9$y=t?psdGZ1EQ=G&GAkz|6z&W{@$t2Y zs{Kkb$gfkzw6)4W7N=DRs}eGDBtKS{?W06Jpmhtfps`A&38_Rd5FHFZWkPKpG7E#v)pxwLY4KY8pn<^c zBOZj>MXSqYp!J3*RRwJete^*b*dThZhzl!ea4Eca{bd_Mt{B0{vQMcK`bdh(9V z>}iZalbW;;9x~F&Rdi&v$69A8 zF;wM*^q*Yql1<1^VrX^H`;tC$mVabsouc9O^@(MQ%jX&KSj%xwfo;J@yd<#nWLdlX zJ-`72%K{~i|2_@*`!)aZ>tALgRTcjZ@b@XJzXE)RcKZG@bM;X0;qb_BQAOxD*Mm`# zhr)mFPyZGL0BE88?Ekx4{SfD2NAfq44>Y#@`4Io;Pd-F>*aZ2FqJsUeEs=)+56e}* z0e<`d?@STSc581?Th@Z^&|Kt`AVg8