问题
In Shiny Dashboard in a Tab I am plotting graphs one below the another, based on the selection of checkbox inputs. When the check boxes are selected accordingly the graphs will get displayed one below the another. Kindly find the code below which i used.
library(shiny)
library(shinydashboard)
library(shinyWidgets)
library(dplyr)
d <-
data.frame(
year = c(1995, 1995, 1995, 1996, 1996, 1996, 1997, 1997, 1997),
Product_Name = c(
"Table",
"Chair",
"Bed",
"Table",
"Chair",
"Bed",
"Table",
"Chair",
"Bed"
),
Product_desc = c("X", "X", "X", "Y", "Y", "Y", "Z", "Z", "Z"),
Cost = c(1, 2, 3, 4, 2, 3, 4, 5, 6)
)
ui <- shinyUI(fluidPage(
useShinydashboard(),
tabPanel(
"Plot",
sidebarLayout(
sidebarPanel(
radioButtons(
"Choose",
"Choose One",
c("Year" = "p", "Numbers" = "l")
),
uiOutput('checkbox'),
#width = 2,
position = "bottom"),
mainPanel(uiOutput("graph"),
uiOutput("graph_1"))
)
)
))
server <- function(input, output, session) {
z_1 <- reactiveValues(years = NULL)
z_2 <- reactiveValues(numbers = NULL)
observeEvent(input$X, {
z_1$years <- input$X
})
observeEvent(input$X_1, {
z_2$numbers <- input$X_1
})
output$checkbox <- renderUI({
if (input$Choose == "p") {
checkboxGroupInput("X",
"year",
choices = (unique(d$year)),selected = z_1$years)
} else{
checkboxGroupInput("X_1",
"Numbers",
choices = c("1","2","3","4"), ,selected = z_2$numbers)
}
})
output$graph <- renderUI({
ntabs = length(input$X)
if(input$Choose == "p"){
myTabs = lapply(seq_len(ntabs), function(i) {
fluidRow(plotOutput(paste0("plot", i)))
})
}else return(NULL)
})
output$graph_1 <- renderUI({
ntabs = length(input$X_1)
if(input$Choose == "l"){
myTabs = lapply(seq_len(ntabs), function(i) {
fluidRow(plotOutput(paste0("plot_1", i)))
})
}else return(NULL)
})
observe (lapply(length(input$X), function(i) {
output[[paste0("plot", i)]] <- renderPlot({
if (length(input$X) > 0) {
d %>%
ggplot(aes(Product_Name, Cost)) +
geom_col(aes(fill = Product_desc),
position = position_dodge(preserve = "single")) +
facet_wrap( ~ input$X[i],
scales = "free_x",
strip.position = "bottom") +
theme(strip.placement = "outside") +
theme_bw()
}
})
}))
observe (lapply(length(input$X_1), function(i) {
output[[paste0("plot_1", i)]] <- renderPlot({
if (length(input$X_1) > 0) {
d %>%
ggplot(aes(Product_Name, Cost)) +
theme(strip.placement = "outside") +
theme_bw()
}
})
}))
}
shinyApp(ui, server)
What I am trying to do now is I "Wanted to download these plots" which are getting dynamically generated based on the user check box input. If the user had generated 1 graph I wanted to download it. If the user had generated 3 graphs then i want to download all the generated graphs in one single jpeg file.
I tried using downloadHandler, but unfortunately i was very very unsuccessful in it.
The issue which I am facing in this case is as the graphs are dynamic in Nature I am not able to store or write a code in the downloadHandler. The dynamic Nature of the Graph is making it difficult.
Can someone please suggest me how to overcome this.
回答1:
Shiny Modules [*] would be a neat possibility here.
Note. I did not fully understand what you tried with your dynamic checkboxGroup, so I replaced it by a static one. Also I was not quite clear what you want to plot in particular. This is however anyways not crucial to the problem at hand, which can be described as follows
Download a dynamic amount of figures in one file.
So here we go, explanation below.
Setup
library(shiny)
library(dplyr)
library(gridExtra)
d <- data.frame(
year = c(1995, 1995, 1995, 1996, 1996, 1996, 1997, 1997, 1997),
Product_Name = c("Table", "Chair", "Bed", "Table", "Chair", "Bed", "Table",
"Chair", "Bed"),
Product_desc = rep(LETTERS[24:26], each = 3),
Cost = c(1, 2, 3, 4, 2, 3, 4, 5, 6)
)
Shiny Modules
plot_ui <- function(id) {
ns <- NS(id)
plotOutput(ns("graph"))
}
plot_server <- function(input, output, session, my_data, graph_type) {
get_graph <- reactive({
base_plot <- ggplot(my_data,
aes(Product_Name, Cost)) +
theme(strip.placement = "outside") +
theme_bw()
if (graph_type() == "b") {
res <- base_plot +
geom_col(aes(fill = Product_desc),
position = position_dodge(preserve = "single")) +
facet_wrap(~year)
} else if (graph_type() == "p") {
res <- base_plot +
geom_point()
}
res
})
output$graph <- renderPlot({
get_graph()
})
list(graph = get_graph)
}
Main App
ui <- fluidPage(
titlePanel("Modules to the Rescue!"),
sidebarLayout(
sidebarPanel(
radioButtons(
"type",
"Graph Type",
c(Bars = "b", Points = "p")
),
checkboxGroupInput("selector",
"Year",
choices = unique(d$year)),
downloadButton("download", "Download Graphs")
),
mainPanel(div(id = "container", div("test content")))
)
)
server <- function(input, output, session) {
## store active plot handlers
all_plots <- reactiveVal()
## counter to ensure unique ids for the module uis
cnt <- reactiveVal(0)
## when we change selector draw plots anew
observe({
## remove all existing plots
removeUI("#container *", immediate = TRUE, multiple = TRUE)
## for each selection create a new plot
## SIDE EFFECT: create the UI
handlers <- lapply(input$selector, function(x) {
cnt(isolate(cnt()) + 1)
my_dat <- d %>%
dplyr::filter(year == x)
new_id <- paste("plot", isolate(cnt()))
insertUI("#container", ui = plot_ui(new_id))
callModule(plot_server, new_id,
my_data = my_dat,
graph_type = reactive(input$type))
})
all_plots(handlers)
})
output$download <- downloadHandler(
filename = function() {
paste0("plots-", Sys.Date(), ".png")
}, content = function(file) {
my_plots <- all_plots()
ggsave(file,
plot = marrangeGrob(lapply(my_plots, function(handle) handle$graph()),
ncol = 1, nrow = length(my_plots)))
}
)
}
shinyApp(ui, server)
Explanation
(The linked document describes in depth what modules are doing so I focus on I used them, rather on how they work in general.)
- We create a module whihc does the plotting for us.
- The module creates a reactive which produces the plot.
- This reactive is used twice: once in the
renderPlotfunction to render the plot, and once as a return parameter of the module. - In the main app, we keep track about all created modules (
all_plots), through which we can communicate with the model and in particular to retrieve the plot. - To draw the plots, we listen to the
checkboxGroupand whenever there is a change we dynamically remove all plots, and add them afresh and updateall_plotsthrough which we can in the last step retrieve the plots for thedownloadHandler. - In the
downloadHandlerwe loop through all plots and usegridExtra::marrangeto put all of theggplotsinto one file viaggsave.
[*] Note that I still use the old callModule syntax as I have noi yet upgraded shiny.
回答2:
I had to adjust your data as product_desc was not clearly available for each year. I defined it as Product_desc = c("X", "Y", "Z", "X", "Y", "Z", "X", "Y", "Z") Then a reactive dataframe was defined. Next you need to create an object to save. Lastly, you need to place download buttons. Download handler will let you download. You can enhance it further by changing how facets are displayed.
The following code generates the required output:
ui <- shinyUI(fluidPage(
useShinydashboard(),
tabPanel(
"Plot",
sidebarLayout(
sidebarPanel(
uiOutput('checkbox'),
#width = 2,
position = "bottom"),
mainPanel(#uiOutput("graph"),
plotOutput("mygraph"),
#DT::dataTableOutput("testtable"),
uiOutput("saveplotsbtn")
)
)
)
))
server <- function(input, output, session) {
session_store <- reactiveValues()
output$checkbox <- renderUI({
checkboxGroupInput("year", "year", choices = (unique(d$year)))
})
output$graph <- renderUI({
# create tabPanel with datatable in it
req(input$year)
tabPanel("Plots",
fluidRow(lapply(as.list(paste0("plot", seq_along(input$year))), plotOutput)))
})
observe(lapply(length(input$year), function(i) {
#because expressions are evaluated at app init
#print("I am in Render")
output[[paste0("plot", i)]] <- renderPlot({
#print ("bbb")
if (length(input$year) > 0) {
d %>%
ggplot(aes(Product_Name, Cost)) +
geom_col(aes(fill = Product_desc),
position = position_dodge(preserve = "single")) +
facet_wrap( ~ input$year[i],
scales = "free_x",
strip.position = "bottom") +
theme(strip.placement = "outside") +
theme_bw()
}
})
}))
output$saveplotsbtn <- renderUI({
tagList(
div(style="display: block; height: 20px; width: 5px;",HTML("<br>")),
div(style="display: inline; padding: 50px; color: #ad1d28; font-size: 28px ; width: 190px;",HTML("Save Graph as <br>")),
div(style="display: block; padding: 5px 350px 15px 50px ;",
downloadBttn("savePDF",
HTML(" PDF"),
style = "fill",
color = "danger",
size = "lg",
block = TRUE,
no_outline = TRUE
) ),
div(style="display: block; width: 5px;",HTML("<br>")),
div(style="display: block; padding: 5px 350px 15px 50px;",
downloadBttn("savePNG",
label= " PNG",
style = "fill",
color = "warning",
size = "lg",
block = TRUE,
no_outline = TRUE
) )
)
})
mydf <- eventReactive(input$year ,{
req(input$year)
data <- d[d$year %in% input$year,]
data
})
output$testtable <- DT::renderDataTable(
mydf(),
class = "display nowrap compact",
options = list( # options
scrollX = TRUE # allow user to scroll wide tables horizontally
)
)
output$mygraph <- renderPlot({
if(is.null(mydf())){
myplot <- NULL
}
else{
myplot <- ggplot(data=mydf(), aes(Product_Name, Cost, fill = Product_desc)) +
geom_bar(#aes(fill = factor(Product_desc)),
stat = "identity" , # position = "dodge",
position = position_dodge(preserve = "single")) +
facet_wrap( ~ year,
scales = "free_x",
strip.position = "bottom") +
theme(strip.placement = "outside") +
theme_bw()
}
session_store$plt <- myplot
session_store$plt
})
output$savePNG <- downloadHandler(
filename = function(){
paste0('myplot', Sys.Date(), '.png', sep='')
},
content = function(file) {
ggsave(file, plot = session_store$plt, width = 6, height = 5, dpi = 100, units = "in",
device="png", path=input$file$datapath)
}
)
output$savePDF <- downloadHandler(
filename = function(){
paste0('myplot', Sys.Date(), '.pdf', sep='')
},
content = function(file) {
ggsave(file, plot = session_store$plt, width = 6, height = 5, dpi = 100, units = "in",
device="pdf", path=input$file$datapath)
}
)
}
shinyApp(ui, server)
You get the following output:
来源：https://stackoverflow.com/questions/62378430/how-to-download-graphs-which-are-dynamic-in-r-shiny