diff --git a/DESCRIPTION b/DESCRIPTION index 0a23907..83e18e8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -32,7 +32,8 @@ Imports: scales, shiny (>= 1.1.0), shinybusy, - shinyWidgets (>= 0.6.0) + shinyWidgets (>= 0.6.0), + zip Suggests: officer, rvg, diff --git a/NAMESPACE b/NAMESPACE index 9c23c7a..1e787f1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,6 +26,8 @@ export(safe_ggplot) export(save_ggplot_modal) export(save_ggplot_server) export(save_ggplot_ui) +export(save_multi_ggplot_server) +export(save_multi_ggplot_ui) export(set_i18n) export(updateColorPicker) export(updateDragulaInput) @@ -37,6 +39,7 @@ importFrom(bslib,accordion) importFrom(bslib,accordion_panel) importFrom(bslib,bs_add_rules) importFrom(bslib,bs_theme) +importFrom(bslib,card) importFrom(bslib,layout_sidebar) importFrom(bslib,nav_panel) importFrom(bslib,nav_panel_hidden) @@ -206,6 +209,7 @@ importFrom(shinyWidgets,textInputIcon) importFrom(shinyWidgets,updateNumericInputIcon) importFrom(shinyWidgets,updatePickerInput) importFrom(shinyWidgets,updatePrettyCheckboxGroup) +importFrom(shinyWidgets,updatePrettyToggle) importFrom(shinyWidgets,updateProgressBar) importFrom(shinyWidgets,virtualSelectInput) importFrom(stats,setNames) @@ -215,3 +219,4 @@ importFrom(utils,data) importFrom(utils,head) importFrom(utils,modifyList) importFrom(utils,packageVersion) +importFrom(zip,zip) diff --git a/R/export-history.R b/R/export-history.R new file mode 100644 index 0000000..7b33fb4 --- /dev/null +++ b/R/export-history.R @@ -0,0 +1,423 @@ + +#' @title Save multiple `ggplot` module +#' +#' @description Save multiple `ggplot` objects in various format and retrieve code. +#' +#' @param id Module ID. +#' @param output_format Output formats offered to the user. +#' +#' @returns No value. Use in UI & server in shiny application. +#' @export +#' +#' @importFrom shiny downloadButton actionButton uiOutput +#' @importFrom htmltools tagList tags +#' @importFrom bslib card layout_sidebar sidebar +#' @importFrom shinyWidgets numericInputIcon +#' +#' @name save-ggplot-multi-module +#' +#' @example examples/save-ggplot-multi-module.R +save_multi_ggplot_ui <- function(id, + output_format = c("png", "pdf", "svg", "jpeg", "pptx")) { + ns <- NS(id) + output_format <- match.arg( + arg = output_format, + choices = c("png", "pdf", "svg", "jpeg", "pptx"), + several.ok = TRUE + ) + download_links <- lapply( + X = seq_along(output_format), + FUN = function(i) { + downloadButton( + outputId = ns(paste0("export_", output_format[i])), + label = tagList(ph("download"), output_format[[i]]), + class = "btn-outline-primary d-block my-1 w-100", + icon = NULL + ) + } + ) + + tags$div( + class = "save-multi-ggplot-container", + html_dependency_esquisse(), + card( + fill = FALSE, + layout_sidebar( + uiOutput( + outputId = ns("plots_container"), + class = "row row-cols-md-3 mt-3" + ), + sidebar = sidebar( + position = "right", + open = "always", + tags$div( + class = "save-multi-ggplot-controls", + actionButton( + inputId = ns("select_all"), + label = tagList(ph("selection-inverse"), "(Un)select all"), + class = "btn-outline-primary w-100 active", + `data-bs-toggle` = "button", + `aria-pressed` = "true" + ), + tags$hr(), + downloadButton( + outputId = ns("dl_code"), + label = tagList(ph("code"), "Download code"), + class = "btn-outline-primary w-100 mb-1", + icon = NULL + ), + actionButton( + inputId = ns("view_code"), + label = tagList(ph("eye"), "View all code"), + class = "btn-outline-primary w-100" + ), + tags$hr(), + numericInputIcon( + inputId = ns("width"), + label = "Default width:", + value = 868, + icon = list(NULL, "px"), + width = "100%" + ), + numericInputIcon( + inputId = ns("height"), + label = "Default height:", + value = 400, + icon = list(NULL, "px"), + width = "100%" + ), + download_links + ) + ) + ) + ) + ) +} + +#' @param plot_list_r A `reactive` function returning a list of plots and codes to export. +#' Sub list items can have following names: +#' * `ggobj`: the `ggplot` object producing the plot +#' * `code`: code to produce the chart (optional) +#' * `label`: a label to identify the plot +#' @param filename Name for the file exported. +#' +#' @export +#' +#' @importFrom shiny moduleServer reactiveValues observeEvent renderUI downloadHandler showModal modalDialog +#' showNotification +#' @importFrom shinyWidgets updatePrettyToggle +#' @importFrom htmltools HTML +#' +#' @rdname save-ggplot-multi-module +save_multi_ggplot_server <- function(id, + plot_list_r = reactive(NULL), + filename = "code-ggplot") { + moduleServer( + id, + function(input, output, session) { + + ns <- session$ns + rv <- reactiveValues() + + observeEvent(input$select_all, { + plot_list <- plot_list_r() + value <- isTRUE(input$select_all %% 2 == 0) + lapply( + X = seq_along(plot_list), + FUN = function(i) { + updatePrettyToggle( + session = session, + inputId = paste0("include_plot_", i), + value = value + ) + } + ) + }, ignoreInit = TRUE) + + output$plots_container <- renderUI({ + plot_list <- plot_list_r() + lapply( + X = seq_along(plot_list), + FUN = function(i) { + export_multi_plot_card( + index = i, + obj = plot_list[[i]], + ns = ns, + export_btn_id = "export_plot" + ) + } + ) + }) + + # Export individual plots + observeEvent(input$export_plot, { + plot_list <- plot_list_r() + rv$plot <- plot_list[[input$export_plot]]$ggobj + save_ggplot_modal(ns("export_plot"), "Export plot") + }) + save_ggplot_server("export_plot", rv) + + + # Donwload code + output$dl_code <- downloadHandler( + filename = function() { + if (is.reactive(filename)) + filename <- filename() + paste0(filename, ".R") + }, + content = function(file) { + plot_list <- plot_list_r() + code_file <- tempfile(fileext = ".R") + cat( + "# esquisse code -------\n\n\n", + file = code_file + ) + cat( + paste_code(plot_list, .input = input), + file = code_file, + append = TRUE + ) + file.copy(from = code_file, to = file) + } + ) + + # View code + observeEvent(input$view_code, { + plot_list <- plot_list_r() + showModal(modalDialog( + title = tagList("Code", button_close_modal()), + footer = NULL, + size = "l", + easyClose = TRUE, + HTML(downlit::highlight( + paste_code(plot_list, .input = input), + pre_class = "esquisse-code", + code = TRUE, + classes = downlit::classes_pandoc() + )) + )) + }) + + # Download multi plots + output$export_png <- download_multi_plot_handler(input, plot_list_r, "png", filename) + output$export_pdf <- download_multi_plot_handler(input, plot_list_r, "pdf", filename) + output$export_svg <- download_multi_plot_handler(input, plot_list_r, "svg", filename) + output$export_jpeg <- download_multi_plot_handler(input, plot_list_r, "jpeg", filename) + + output$export_pptx <- downloadHandler( + filename = function() { + if (is.reactive(filename)) + filename <- filename() + paste0(filename, ".pptx") + }, + content = function(file) { + if (requireNamespace(package = "rvg") & requireNamespace(package = "officer")) { + plot_list <- plot_list_r() + ppt <- officer::read_pptx() + ppt <- try({ + for (index in seq_along(plot_list)) { + if (!isTRUE(input[[paste0("include_plot_", index)]])) + next + ppt <- officer::add_slide(x = ppt, layout = "Blank") + ppt <- officer::ph_with( + x = ppt, + value = rvg::dml(ggobj = plot_list[[index]]$ggobj), + location = officer::ph_location_fullsize() + ) + } + ppt + }, silent = FALSE) + if (inherits(ppt, "try-error")) { + shiny::showNotification( + ui = i18n("Export to PowerPoint failed..."), + type = "error", + id = paste("esquisse", sample.int(1e6, 1), sep = "-") + ) + } else { + tmp <- tempfile(pattern = "esquisse", fileext = ".pptx") + print(ppt, target = tmp) + file.copy(from = tmp, to = file) + } + } else { + warn <- "Packages 'officer' and 'rvg' are required to use this functionality." + warning(warn, call. = FALSE) + shiny::showNotification( + ui = warn, + type = "warning", + id = paste("esquisse", sample.int(1e6, 1), sep = "-") + ) + } + } + ) + + } + ) +} + + +#' @importFrom shiny renderPlot actionButton +#' @importFrom shinyWidgets prettyToggle dropMenu numericInputIcon +#' @importFrom htmltools tagAppendAttributes tags HTML tagList +#' @importFrom phosphoricons ph +export_multi_plot_card <- function(index, + obj, + export_btn_id = "export", + ns = identity) { + tags$div( + class = "col mb-2", + tags$div( + class = "card h-100", + renderPlot(obj$ggobj), + tags$div( + class = "card-body", + tags$h5( + class = "card-title", + obj$label + ), + if (!is.null(obj$code)) { + HTML(downlit::highlight( + obj$code, + pre_class = "esquisse-code", + code = TRUE, + classes = downlit::classes_pandoc() + )) + } + ), + tags$div( + class = "card-footer d-flex py-2", + tagAppendAttributes( + prettyToggle( + inputId = ns(paste0("include_plot_", index)), + value = TRUE, + label_on = "Export", + icon_on = icon("check"), + status_on = "success", + status_off = "danger", + label_off = "Don't export", + icon_off = icon("xmark"), + bigger = TRUE, + inline = TRUE + ), + class = "flex-grow-1 mb-0 mt-2" + ), + dropMenu( + actionButton( + inputId = ns(paste0("setting_plot_", index)), + label = tagList(ph("gear", title = "Settings for this plot")), + class = "btn-outline-primary me-2" + ), + numericInputIcon( + inputId = ns(paste0("width_plot_", index)), + label = "Width:", + value = NA, + icon = list(NULL, "px"), + width = "100%" + ), + numericInputIcon( + inputId = ns(paste0("height_plot_", index)), + label = "Height:", + value = NA, + icon = list(NULL, "px"), + width = "100%" + ) + ), + tags$button( + type = "button", + class = "btn btn-outline-primary", + ph("download", title = "Export this plot"), + onclick = sprintf( + "Shiny.setInputValue('%s', %s, {priority: 'event'})", + ns(export_btn_id), index + ) + ) + ) + ) + ) +} + + +#' @importFrom ggplot2 ggsave +#' @importFrom zip zip +export_multi_ggplot <- function(plot_list, + zipfile, + device = c("png", "pdf", "svg", "jpeg"), + width = 868, + height = 400) { + device <- match.arg(device) + plot_dir <- tempfile(pattern = "export_plot_dir") + dir.create(plot_dir) + for (obj in plot_list) { + ggsave( + path = plot_dir, + filename = paste(obj$label, device, sep = "."), + plot = obj$ggobj, + device = device, + dpi = 72, + width = obj$width %||% width / 72, + height = obj$height %||% height / 72, + scale = 1 + ) + } + zip::zip( + zipfile = zipfile, + files = list.files(plot_dir, full.names = TRUE), + mode = "cherry-pick" + ) +} + +#' @importFrom shiny downloadHandler isTruthy +download_multi_plot_handler <- function(input, + plot_list_r, + device, + filename = "export-ggplot") { + downloadHandler( + filename = function() { + if (is.reactive(filename)) + filename <- filename() + paste0(filename, ".zip") + }, + content = function(file) { + plot_list <- plot_list_r() + for (index in seq_along(plot_list)) { + if (isTruthy(input[[paste0("height_plot_", index)]])) + plot_list[[index]]$height <- input[[paste0("height_plot_", index)]] + if (isTruthy(input[[paste0("width_plot_", index)]])) + plot_list[[index]]$width <- input[[paste0("width_plot_", index)]] + } + for (index in seq_along(plot_list)) { + if (!isTRUE(input[[paste0("include_plot_", index)]])) + plot_list[[index]] <- NULL + } + export_multi_ggplot( + plot_list = plot_list, + device = device, + zipfile = file, + width = input$width, + height = input$height + ) + } + ) +} + + + +paste_code <- function(plot_list, .input = list()) { + Reduce( + function(...) paste(..., sep = "\n\n\n"), + dropNulls(lapply( + X = seq_along(plot_list), + FUN = function(index) { + if (!isTRUE(.input[[paste0("include_plot_", index)]])) + return(NULL) + paste( + sprintf("# %s ----\n", plot_list[[index]]$label %||% paste("Plot", index)), + plot_list[[index]]$code, + sep = "\n" + ) + } + )) + ) +} + + + diff --git a/R/export.R b/R/export.R index d8996e9..6b232f8 100644 --- a/R/export.R +++ b/R/export.R @@ -9,7 +9,7 @@ #' @param id Module ID. #' @param output_format Output formats offered to the user. #' -#' @return No value. Use in UI & server of shiny application. +#' @returns No value. Use in UI & server in shiny application. #' @export #' #' @name save-ggplot-module @@ -364,12 +364,12 @@ render_ggplot <- function(id, ns <- session$ns plot_width <- paste0("output_", ns("plot"), "_width") plot_height <- paste0("output_", ns("plot"), "_height") - + observeEvent(input$hidden, { - if (isTRUE(resizable)) + if (isTRUE(resizable)) activate_resizer(id = ns("ggplot-container"), modal = FALSE) }) - + bindEvent( observe({ if ( @@ -392,7 +392,7 @@ render_ggplot <- function(id, width(), height() ) - + output$export_png <- download_plot_fun(gg_fun, "png", filename, session) output$export_pdf <- download_plot_fun(gg_fun, "pdf", filename, session) output$export_svg <- download_plot_fun(gg_fun, "svg", filename, session) @@ -446,8 +446,8 @@ render_ggplot <- function(id, output$plotly <- plotly::renderPlotly({ rv$plot <- gg_fun() plotly::ggplotly( - p = rv$plot, - width = session$clientData[[plot_width]], + p = rv$plot, + width = session$clientData[[plot_width]], height = session$clientData[[plot_height]] ) }) diff --git a/dev/save_multi_ggplot.R b/dev/save_multi_ggplot.R index c3666bd..12e6257 100644 --- a/dev/save_multi_ggplot.R +++ b/dev/save_multi_ggplot.R @@ -5,24 +5,36 @@ library(phosphoricons) library(ggplot2) library(shinyWidgets) library(rlang) +library(esquisse) p1 <- ggplot(mtcars) + geom_point(aes(mpg, disp)) p2 <- ggplot(mtcars) + geom_boxplot(aes(gear, disp, group = gear)) p3 <- ggplot(mtcars) + geom_smooth(aes(disp, qsec)) p4 <- ggplot(mtcars) + geom_bar(aes(carb)) +p5 <- ggplot(presidential) + + geom_segment(aes(y = name, x = start, xend = end)) + + geom_point(aes(y = name, x = start)) + + geom_point(aes(y = name, x = end)) plot_list_test <- list( list(ggobj = p1, code = "ggplot(mtcars) + geom_point(aes(mpg, disp))", label = "Plot 1"), list(ggobj = p2, code = "ggplot(mtcars) + geom_boxplot(aes(gear, disp, group = gear))", label = "Plot 2"), list(ggobj = p3, code = "ggplot(mtcars) + geom_smooth(aes(disp, qsec))", label = "Plot 3"), - list(ggobj = p4, code = "ggplot(mtcars) + geom_bar(aes(carb))", label = "Plot 4") + list(ggobj = p4, code = "ggplot(mtcars) + geom_bar(aes(carb))", label = "Plot 4"), + list(ggobj = p5, code = "ggplot(presidential) + + geom_segment(aes(y = name, x = start, xend = end)) + + geom_point(aes(y = name, x = start)) + + geom_point(aes(y = name, x = end))", label = "Plot 5") ) -card_plot <- function(id, obj) { +export_multi_plot_card <- function(index, + obj, + export_btn_id = "export", + ns = identity) { tags$div( - class = "col", + class = "col mb-2", tags$div( class = "card h-100", renderPlot(obj$ggobj), @@ -32,37 +44,73 @@ card_plot <- function(id, obj) { class = "card-title", obj$label ), - tags$p( - class = "card-text font-monospace bg-body-secondary rounded-2 p-1", - obj$code - ) + if (!is.null(obj$code)) { + HTML(downlit::highlight( + obj$code, + pre_class = "esquisse-code", + code = TRUE, + classes = downlit::classes_pandoc() + )) + } ), tags$div( - class = "card-footer", + class = "card-footer d-flex py-2", htmltools::tagAppendAttributes( prettyToggle( - inputId = id, + inputId = ns(paste0("include_plot_", index)), value = TRUE, - label_on = "Included in export", + label_on = "Export", icon_on = icon("check"), status_on = "success", status_off = "danger", - label_off = "Not included in export", - icon_off = icon("xmark"), - bigger = TRUE + label_off = "Don't export", + icon_off = icon("xmark"), + bigger = TRUE, + inline = TRUE + ), + class = "flex-grow-1 mb-0 mt-2" + ), + dropMenu( + actionButton( + inputId = ns(paste0("setting_plot_", index)), + label = tagList(ph("gear", title = "Settings for this plot")), + class = "btn-outline-primary me-2" ), - class = "my-2" + numericInputIcon( + inputId = ns(paste0("width_plot_", index)), + label = "Width:", + value = NA, + icon = list(NULL, "px"), + width = "100%" + ), + numericInputIcon( + inputId = ns(paste0("height_plot_", index)), + label = "Height:", + value = NA, + icon = list(NULL, "px"), + width = "100%" + ) + ), + tags$button( + type = "button", + class = "btn btn-outline-primary", + ph("download", title = "Export this plot"), + onclick = sprintf( + "Shiny.setInputValue('%s', %s, {priority: 'event'})", + ns(export_btn_id), index + ) ) ) ) ) } -save_multi_ggplot_ui <- function(id, file_format = c("png", "pdf", "svg", "jpeg", "pptx")) { +save_multi_ggplot_ui <- function(id, + file_format = c("png", "pdf", "svg", "jpeg", "pptx")) { ns <- NS(id) file_format <- match.arg( - arg = file_format, - choices = c("png", "pdf", "svg", "jpeg", "pptx"), + arg = file_format, + choices = c("png", "pdf", "svg", "jpeg", "pptx"), several.ok = TRUE ) download_links <- lapply( @@ -79,79 +127,73 @@ save_multi_ggplot_ui <- function(id, file_format = c("png", "pdf", "svg", "jpeg" ) } ) - + tags$div( class = "save-multi-ggplot-container", - tags$div( - class = "save-multi-ggplot-controls", - downloadButton( - outputId = ns("dl_code"), - label = tagList(ph("code"), "Download code"), - class = "btn-outline-primary", - icon = NULL - ), - htmltools::tagAppendAttributes( - dropMenu( - actionButton( - inputId = ns("dl_plots_drop"), - label = tagList("Download plots", ph("caret-circle-down")), - class = "btn-outline-primary", - ), - placement = "bottom-end", + card( + fill = FALSE, + layout_sidebar( + uiOutput( + outputId = ns("plots_container"), + class = "row row-cols-md-3 mt-3" + ), + sidebar = sidebar( + position = "right", + open = "always", tags$div( - style = htmltools::css( - display = "grid", - gridTemplateColumns = "repeat(2, 1fr)", - gridGap = "10px" + class = "save-multi-ggplot-controls", + actionButton( + inputId = ns("select_all"), + label = tagList(ph("selection-inverse"), "(Un)select all"), + class = "btn-outline-primary w-100 active", + `data-bs-toggle` = "button", + `aria-pressed` = "true" ), - tags$div( - class = "pe-2 border-end", - numericInputIcon( - inputId = ns("width"), - label = "Default width:", - value = 868, - icon = list(NULL, "px"), - width = "100%" - ), - numericInputIcon( - inputId = ns("height"), - label = "Default height:", - value = 400, - icon = list(NULL, "px"), - width = "100%" - ) + tags$hr(), + downloadButton( + outputId = ns("dl_code"), + label = tagList(ph("code"), "Download code"), + class = "btn-outline-primary w-100 mb-1", + icon = NULL ), - tags$div( - download_links - ) + actionButton( + inputId = ns("view_code"), + label = tagList(ph("eye"), "View all code"), + class = "btn-outline-primary w-100" + ), + tags$hr(), + numericInputIcon( + inputId = ns("width"), + label = "Default width:", + value = 868, + icon = list(NULL, "px"), + width = "100%" + ), + numericInputIcon( + inputId = ns("height"), + label = "Default height:", + value = 400, + icon = list(NULL, "px"), + width = "100%" + ), + download_links ) - ), - class = "d-inline-block" - ), - actionButton( - inputId = ns("select_all"), - label = tagList("(Un)select all"), - class = "btn-outline-primary float-end" + ) ) - ), - tags$div(class = "clearfix"), - uiOutput( - outputId = ns("plots_container"), - class = "row row-cols-md-3 mt-3" ) ) } save_multi_ggplot_server <- function(id, plot_list_r = reactive(NULL), - filename_code = "code-ggplot.R", - filename_zip = "ggplot.zip") { + filename = "code-ggplot") { moduleServer( id, function(input, output, session) { - + ns <- session$ns - + rv <- reactiveValues() + observeEvent(input$select_all, { plot_list <- plot_list_r() value <- isTRUE(input$select_all %% 2 == 0) @@ -160,76 +202,135 @@ save_multi_ggplot_server <- function(id, FUN = function(i) { updatePrettyToggle( session = session, - inputId = paste0("include_plot_", i), + inputId = paste0("include_plot_", i), value = value ) } ) }, ignoreInit = TRUE) - + output$plots_container <- renderUI({ plot_list <- plot_list_r() lapply( X = seq_along(plot_list), FUN = function(i) { - card_plot( - id = ns(paste0("include_plot_", i)), - obj = plot_list[[i]] + export_multi_plot_card( + index = i, + obj = plot_list[[i]], + ns = ns, + export_btn_id = "export_plot" ) } ) }) - + + # Export individual plots + observeEvent(input$export_plot, { + plot_list <- plot_list_r() + rv$plot <- plot_list[[input$export_plot]]$ggobj + save_ggplot_modal(ns("export_plot"), "Export plot") + }) + save_ggplot_server("export_plot", rv) + + + # Donwload code output$dl_code <- downloadHandler( filename = function() { - if (is.reactive(filename_code)) - filename_code <- filename_code() - filename_code - }, + if (is.reactive(filename)) + filename <- filename() + paste0(filename, ".R") + }, content = function(file) { plot_list <- plot_list_r() code_file <- tempfile(fileext = ".R") cat( - "# Code ----\n\n\n", + "# esquisse code -------\n\n\n", file = code_file ) - lapply( - X = seq_along(plot_list), - FUN = function(i) { - if (!isTRUE(input[[paste0("include_plot_", i)]])) - return(NULL) - cat( - sprintf("# %s ----\n\n", plot_list[[i]]$label), - file = code_file, - append = TRUE - ) - cat( - plot_list[[i]]$code, - file = code_file, - append = TRUE - ) - cat( - "\n\n\n", - file = code_file, - append = TRUE - ) - } + cat( + paste_code(plot_list, .input = input), + file = code_file, + append = TRUE ) file.copy(from = code_file, to = file) } ) - - output$export_png <- download_multi_plot_handler(input, plot_list_r, "png", filename_zip) - output$export_pdf <- download_multi_plot_handler(input, plot_list_r, "pdf", filename_zip) - output$export_svg <- download_multi_plot_handler(input, plot_list_r, "svg", filename_zip) - output$export_jpeg <- download_multi_plot_handler(input, plot_list_r, "jpeg", filename_zip) - + + # View code + observeEvent(input$view_code, { + plot_list <- plot_list_r() + showModal(modalDialog( + title = tagList("Code", esquisse:::button_close_modal()), + footer = NULL, + size = "l", + easyClose = TRUE, + HTML(downlit::highlight( + paste_code(plot_list, .input = input), + pre_class = "esquisse-code", + code = TRUE, + classes = downlit::classes_pandoc() + )) + )) + }) + + # Download multi plots + output$export_png <- download_multi_plot_handler(input, plot_list_r, "png", filename) + output$export_pdf <- download_multi_plot_handler(input, plot_list_r, "pdf", filename) + output$export_svg <- download_multi_plot_handler(input, plot_list_r, "svg", filename) + output$export_jpeg <- download_multi_plot_handler(input, plot_list_r, "jpeg", filename) + + output$export_pptx <- downloadHandler( + filename = function() { + if (is.reactive(filename)) + filename <- filename() + paste0(filename, ".pptx") + }, + content = function(file) { + if (requireNamespace(package = "rvg") & requireNamespace(package = "officer")) { + plot_list <- plot_list_r() + ppt <- officer::read_pptx() + ppt <- try({ + for (index in seq_along(plot_list)) { + if (!isTRUE(input[[paste0("include_plot_", index)]])) + next + ppt <- officer::add_slide(x = ppt, layout = "Blank") + ppt <- officer::ph_with( + x = ppt, + value = rvg::dml(ggobj = plot_list[[index]]$ggobj), + location = officer::ph_location_fullsize() + ) + } + ppt + }, silent = FALSE) + if (inherits(ppt, "try-error")) { + shiny::showNotification( + ui = i18n("Export to PowerPoint failed..."), + type = "error", + id = paste("esquisse", sample.int(1e6, 1), sep = "-") + ) + } else { + tmp <- tempfile(pattern = "esquisse", fileext = ".pptx") + print(ppt, target = tmp) + file.copy(from = tmp, to = file) + } + } else { + warn <- "Packages 'officer' and 'rvg' are required to use this functionality." + warning(warn, call. = FALSE) + shiny::showNotification( + ui = warn, + type = "warning", + id = paste("esquisse", sample.int(1e6, 1), sep = "-") + ) + } + } + ) + } ) } -export_multi_ggplot <- function(plot_list, +export_multi_ggplot <- function(plot_list, zipfile, device = c("png", "pdf", "svg", "jpeg"), width = 868, @@ -250,33 +351,39 @@ export_multi_ggplot <- function(plot_list, ) } zip::zip( - zipfile = zipfile, - files = list.files(plot_dir, full.names = TRUE), + zipfile = zipfile, + files = list.files(plot_dir, full.names = TRUE), mode = "cherry-pick" ) } -download_multi_plot_handler <- function(input, +download_multi_plot_handler <- function(input, plot_list_r, device, - filename_zip = "ggplot.zip") { + filename = "export-ggplot") { downloadHandler( filename = function() { - if (is.reactive(filename_zip)) - filename_zip <- filename_zip() - filename_zip + if (is.reactive(filename)) + filename <- filename() + paste0(filename, ".zip") }, content = function(file) { plot_list <- plot_list_r() - for (i in seq_along(plot_list)) { - if (!isTRUE(input[[paste0("include_plot_", i)]])) - plot_list[[i]] <- NULL + for (index in seq_along(plot_list)) { + if (isTruthy(input[[paste0("height_plot_", index)]])) + plot_list[[index]]$height <- input[[paste0("height_plot_", index)]] + if (isTruthy(input[[paste0("width_plot_", index)]])) + plot_list[[index]]$width <- input[[paste0("width_plot_", index)]] + } + for (index in seq_along(plot_list)) { + if (!isTRUE(input[[paste0("include_plot_", index)]])) + plot_list[[index]] <- NULL } export_multi_ggplot( - plot_list = plot_list_test, - device = device, - zipfile = file, - width = input$width, + plot_list = plot_list, + device = device, + zipfile = file, + width = input$width, height = input$height ) } @@ -284,13 +391,36 @@ download_multi_plot_handler <- function(input, } + +paste_code <- function(plot_list, .input = list()) { + Reduce( + function(...) paste(..., sep = "\n\n\n"), + esquisse:::dropNulls(lapply( + X = seq_along(plot_list), + FUN = function(index) { + if (!isTRUE(.input[[paste0("include_plot_", index)]])) + return(NULL) + paste( + sprintf("# %s ----\n", plot_list[[index]]$label %||% ""), + plot_list[[index]]$code, + sep = "\n" + ) + } + )) + ) +} + + + shinyApp( ui = page_fluid( + theme = bs_theme_esquisse(), + esquisse:::html_dependency_esquisse(), save_multi_ggplot_ui("mod") ), server = function(...) { save_multi_ggplot_server( - id = "mod", + id = "mod", plot_list_r = reactive(plot_list_test) ) } diff --git a/examples/save-ggplot-multi-module.R b/examples/save-ggplot-multi-module.R new file mode 100644 index 0000000..127b28a --- /dev/null +++ b/examples/save-ggplot-multi-module.R @@ -0,0 +1,60 @@ +library(shiny) +library(ggplot2) +library(esquisse) +library(bslib) + +ui <- page_fluid( + theme = bs_theme_esquisse(), + save_multi_ggplot_ui("mod") +) + +server <- function(...) { + + p1 <- ggplot(mtcars) + geom_point(aes(mpg, disp)) + p2 <- ggplot(mtcars) + geom_boxplot(aes(gear, disp, group = gear)) + p3 <- ggplot(mtcars) + geom_smooth(aes(disp, qsec)) + p4 <- ggplot(mtcars) + geom_bar(aes(carb)) + p5 <- ggplot(presidential) + + geom_segment(aes(y = name, x = start, xend = end)) + + geom_point(aes(y = name, x = start)) + + geom_point(aes(y = name, x = end)) + + save_multi_ggplot_server( + id = "mod", + plot_list_r = reactive(list( + list( + ggobj = p1, + code = "ggplot(mtcars) + geom_point(aes(mpg, disp))", + label = "Plot 1" + ), + list( + ggobj = p2, + code = "ggplot(mtcars) + geom_boxplot(aes(gear, disp, group = gear))", + label = "Plot 2" + ), + list( + ggobj = p3, + code = "ggplot(mtcars) + geom_smooth(aes(disp, qsec))", + label = "Plot 3" + ), + list( + ggobj = p4, + code = "ggplot(mtcars) + geom_bar(aes(carb))", + label = "Plot 4" + ), + list( + ggobj = p5, + code = "ggplot(presidential) + + geom_segment(aes(y = name, x = start, xend = end)) + + geom_point(aes(y = name, x = start)) + + geom_point(aes(y = name, x = end))", + label = "Plot 5" + ) + )) + ) +} + +if (interactive()) + shinyApp(ui, server) + + diff --git a/man/save-ggplot-module.Rd b/man/save-ggplot-module.Rd index 04e5fc0..687b1cd 100644 --- a/man/save-ggplot-module.Rd +++ b/man/save-ggplot-module.Rd @@ -30,7 +30,7 @@ save_ggplot_server(id, plot_rv) \item{plot_rv}{A \code{reactiveValues} with a slot \code{plot} containing a \code{ggplot} object.} } \value{ -No value. Use in UI & server of shiny application. +No value. Use in UI & server in shiny application. } \description{ Save a \code{ggplot} object in various format and resize it before saving. diff --git a/man/save-ggplot-multi-module.Rd b/man/save-ggplot-multi-module.Rd new file mode 100644 index 0000000..5ae706a --- /dev/null +++ b/man/save-ggplot-multi-module.Rd @@ -0,0 +1,102 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/export-history.R +\name{save-ggplot-multi-module} +\alias{save-ggplot-multi-module} +\alias{save_multi_ggplot_ui} +\alias{save_multi_ggplot_server} +\title{Save multiple \code{ggplot} module} +\usage{ +save_multi_ggplot_ui( + id, + output_format = c("png", "pdf", "svg", "jpeg", "pptx") +) + +save_multi_ggplot_server( + id, + plot_list_r = reactive(NULL), + filename = "code-ggplot" +) +} +\arguments{ +\item{id}{Module ID.} + +\item{output_format}{Output formats offered to the user.} + +\item{plot_list_r}{A \code{reactive} function returning a list of plots and codes to export. +Sub list items can have following names: +\itemize{ +\item \code{ggobj}: the \code{ggplot} object producing the plot +\item \code{code}: code to produce the chart (optional) +\item \code{label}: a label to identify the plot +}} + +\item{filename}{Name for the file exported.} +} +\value{ +No value. Use in UI & server in shiny application. +} +\description{ +Save multiple \code{ggplot} objects in various format and retrieve code. +} +\examples{ +library(shiny) +library(ggplot2) +library(esquisse) +library(bslib) + +ui <- page_fluid( + theme = bs_theme_esquisse(), + save_multi_ggplot_ui("mod") +) + +server <- function(...) { + + p1 <- ggplot(mtcars) + geom_point(aes(mpg, disp)) + p2 <- ggplot(mtcars) + geom_boxplot(aes(gear, disp, group = gear)) + p3 <- ggplot(mtcars) + geom_smooth(aes(disp, qsec)) + p4 <- ggplot(mtcars) + geom_bar(aes(carb)) + p5 <- ggplot(presidential) + + geom_segment(aes(y = name, x = start, xend = end)) + + geom_point(aes(y = name, x = start)) + + geom_point(aes(y = name, x = end)) + + save_multi_ggplot_server( + id = "mod", + plot_list_r = reactive(list( + list( + ggobj = p1, + code = "ggplot(mtcars) + geom_point(aes(mpg, disp))", + label = "Plot 1" + ), + list( + ggobj = p2, + code = "ggplot(mtcars) + geom_boxplot(aes(gear, disp, group = gear))", + label = "Plot 2" + ), + list( + ggobj = p3, + code = "ggplot(mtcars) + geom_smooth(aes(disp, qsec))", + label = "Plot 3" + ), + list( + ggobj = p4, + code = "ggplot(mtcars) + geom_bar(aes(carb))", + label = "Plot 4" + ), + list( + ggobj = p5, + code = "ggplot(presidential) + + geom_segment(aes(y = name, x = start, xend = end)) + + geom_point(aes(y = name, x = start)) + + geom_point(aes(y = name, x = end))", + label = "Plot 5" + ) + )) + ) +} + +if (interactive()) + shinyApp(ui, server) + + +}