如何下载 R Shiny 中的动态图表？
How to download graphs which are dynamic in R Shiny?
在 Shiny Dashboard in a Tab 中，我根据复选框输入的选择一个接一个地绘制图表。相应地选中复选框后，图表将一个接一个地显示。
请在下面找到我使用的代码。
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)
我现在想做的是“想要下载这些图”，这些图是根据用户复选框输入动态生成的。如果用户生成了 1 个图表，我想下载它。如果用户生成了 3 个图表，那么我想将所有生成的图表下载到一个 jpeg 文件中。
我尝试使用 downloadHandler，但不幸的是我非常非常不成功。
我在这种情况下面临的问题是，由于图形本质上是动态的，我无法在 downloadHandler 中存储或编写代码。图形的动态特性使其变得困难。
有人可以建议我如何克服这个问题。
我不得不调整你的数据，因为 product_desc 并不是每年都有明确的可用数据。我将其定义为 Product_desc = c("X", "Y", "Z", "X", "Y", "Z", "X", "Y", "Z") 然后定义了一个反应性数据框。接下来您需要创建一个对象来保存。最后，您需要放置下载按钮。下载处理程序会让你下载。您可以通过更改分面的显示方式来进一步增强它。
以下代码生成所需的输出：
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)
您得到以下输出：
Shiny Modules [*] 在这里是个不错的选择。
注意。我没有完全理解你用动态 checkboxGroup 尝试的内容，所以我用静态的替换了它。我也不太清楚什么你想特别策划。然而，无论如何这对手头的问题并不重要，可以描述如下
Download a dynamic amount of figures in one file.
那么我们开始吧，解释如下。
设置
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)
)
闪亮模块
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)
}
主应用程序
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)
说明
（链接文档深入描述了模块在做什么，所以我专注于我使用它们，而不是它们一般如何工作.)
- 我们创建了一个模块来为我们绘图。
- 该模块创建了一个生成情节的反应。
- 这个反应被使用了两次：一次在
renderPlot 函数中渲染绘图，一次作为模块的 return 参数。
- 在主应用程序中，我们跟踪所有创建的模块 (
all_plots)，通过这些模块我们可以与模型通信，特别是检索绘图。
- 为了绘制地块，我们听取
checkboxGroup 并且每当有变化时我们动态删除所有地块，并重新添加它们并更新 all_plots 通过它我们可以在最后一步检索 downloadHandler. 的图
- 在
downloadHandler 中，我们遍历所有图并使用 gridExtra::marrange 通过 ggsave. 将所有 ggplots 放入一个文件中
[*] 请注意，我仍然使用旧的 callModule 语法，因为我还没有升级 shiny。
在 Shiny Dashboard in a Tab 中，我根据复选框输入的选择一个接一个地绘制图表。相应地选中复选框后，图表将一个接一个地显示。 请在下面找到我使用的代码。
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)
我现在想做的是“想要下载这些图”，这些图是根据用户复选框输入动态生成的。如果用户生成了 1 个图表，我想下载它。如果用户生成了 3 个图表，那么我想将所有生成的图表下载到一个 jpeg 文件中。
我尝试使用 downloadHandler，但不幸的是我非常非常不成功。
我在这种情况下面临的问题是，由于图形本质上是动态的，我无法在 downloadHandler 中存储或编写代码。图形的动态特性使其变得困难。
有人可以建议我如何克服这个问题。
我不得不调整你的数据，因为 product_desc 并不是每年都有明确的可用数据。我将其定义为 Product_desc = c("X", "Y", "Z", "X", "Y", "Z", "X", "Y", "Z") 然后定义了一个反应性数据框。接下来您需要创建一个对象来保存。最后，您需要放置下载按钮。下载处理程序会让你下载。您可以通过更改分面的显示方式来进一步增强它。
以下代码生成所需的输出：
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)
您得到以下输出：
Shiny Modules [*] 在这里是个不错的选择。
注意。我没有完全理解你用动态 checkboxGroup 尝试的内容，所以我用静态的替换了它。我也不太清楚什么你想特别策划。然而，无论如何这对手头的问题并不重要，可以描述如下
Download a dynamic amount of figures in one file.
那么我们开始吧，解释如下。
设置
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)
)
闪亮模块
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)
}
主应用程序
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)
说明
（链接文档深入描述了模块在做什么，所以我专注于我使用它们，而不是它们一般如何工作.)
- 我们创建了一个模块来为我们绘图。
- 该模块创建了一个生成情节的反应。
- 这个反应被使用了两次：一次在
renderPlot函数中渲染绘图，一次作为模块的 return 参数。 - 在主应用程序中，我们跟踪所有创建的模块 (
all_plots)，通过这些模块我们可以与模型通信，特别是检索绘图。 - 为了绘制地块，我们听取
checkboxGroup并且每当有变化时我们动态删除所有地块，并重新添加它们并更新all_plots通过它我们可以在最后一步检索downloadHandler. 的图
- 在
downloadHandler中，我们遍历所有图并使用gridExtra::marrange通过ggsave. 将所有
ggplots 放入一个文件中
[*] 请注意，我仍然使用旧的 callModule 语法，因为我还没有升级 shiny。