R Shiny: downloadHandler语言 - content参数中的问题

Question

我有一个闪亮的应用程序，并希望下载一个plot作为png使用downloadButton和命令"downloadHandler"正如您在下面的代码中看到的，它应该使用$question作为文件名。当我点击下载按钮时，我得到的只是&;downplot&;作为文件名，当我试图保存文件时没有反应。表的下载工作正常…任何帮助或建议吗?

library(shiny)
library(shinydashboard)
library(dplyr)
library(likert)
library(DT)
library(ggplot2)
library(likert)

levels.netusoft <- c("Sehr wenig", "Etwas", "Stark", "Sehr stark", "Verweigert", 
"Weiß nicht", "Keine Antwort")
levels.ppltrst <- c("1", "2", "3", "4", "5", "6", "Verweigert", "Weiß nicht", 
"Keine Antwort")
levels.polintr <- c("Überhaupt nicht", "Sehr wenig", "Etwas", "Stark", "Sehr stark", 
"Verweigert", "Weiß nicht", "Keine Antwort")
levels.psppsgva <- c("Überhaupt nicht fähig", "Wenig fähig", "Ziemlich fähig", 
"Sehr fähig", "Vollkommen fähig", "Verweigert", "Weiß nicht", 
"Keine Antwort")
levels.actrolga <- c("Wenig fähig", "Ziemlich fähig", "Sehr fähig", "Vollkommen fähig", 
"Verweigert", "Weiß nicht", "Keine Antwort")
levels.gndr <- c("männlich", "weiblich")
dataset <- data.frame("netusoft" = factor(sample(levels.netusoft, 100, 
replace = TRUE),
levels.netusoft),
"ppltrst" = factor(sample(levels.ppltrst, 100, 
replace = TRUE),
levels.ppltrst),
"polintr" = factor(sample(levels.polintr, 100, 
replace = TRUE),
levels.polintr),
"psppsgva" = factor(sample(levels.psppsgva, 100, 
replace = TRUE),
levels.psppsgva),
"actrolga" = factor(sample(levels.actrolga, 100, 
replace = TRUE),
levels.actrolga),
"gndr" = factor(sample(levels.gndr, 100,
replace = TRUE),
levels.gndr),
check.names = FALSE)

# ----- UI
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = "European Social Survey Österreich Dashboard", 
titleWidth = 300),
dashboardSidebar(width = 300,
selectInput(inputId = "round", 
label = "Wählen Sie eine ESS Runde aus",  
c("ESS 9" = "9"),
selected = "9", selectize = FALSE), 
#end selectinput
conditionalPanel(
condition = "input.round == '9'",
selectInput(inputId = "battery", 
label = "Wählen Sie Themenfeld aus",
c("A: Medien-, Internetnutzung, Soziales Vertrauen" = "A",
"B: Politische Variablen, Immigration" = "B"), 
selectize = FALSE), #end selectinput
uiOutput("question_placeholder")
),
checkboxInput(
inputId = "group",
label = "Daten gruppieren",
value = FALSE), #end checkbox

conditionalPanel(
condition = "input.group == true",
selectInput(
inputId = "UV",
label = "Daten gruppieren nach:",
c("Geschlecht" = "gndr")
) # end conditionalPanel
)
), # end dashboardSidebar
dashboardBody(
fluidRow(
box(width = 7, status = "info", solidHeader = TRUE,
title = "Table:",
dataTableOutput("tabelle", width = "100%")
),

downloadButton("downtable", "Tabelle speichern"),
#  tags$br(),
tags$hr(),

box(width = 8, status = "info", solidHeader = TRUE,
title = "Graph:",
plotOutput("plot", width = "auto", height = 500)
)
), # end fluidRow

downloadButton("downplot", "Grafik speichern"),
#  tags$br(),
tags$hr() # end fluidRow

) #end dashboardBody
)
)
server <- function(input, output, session) {
get_data <- reactive({
req(input$question)
if (input$group) {
dataset %>% 
select(Antwortkategorie = input$question, req(input$UV)) %>% 
group_by(grp = !!as.symbol(input$UV), Antwortkategorie)
} else {
dataset %>% 
select(Antwortkategorie = input$question) %>% 
group_by(Antwortkategorie)
} 
})


output$question_placeholder <- renderUI({
if (input$battery == "A") {
choices <- c("A2|Häufigkeit Internetnutzung" = "netusoft",
"A4|Vertrauen in Mitmenschen" = "ppltrst")
} else if (input$battery == "B") {
choices <- c("B1|Interesse an Politik" = "polintr",
"B2|Politische Mitsprachemöglichkeit" = "psppsgva",
"B3|Fähigkeit politischen Engagements " = "actrolga")
}
selectInput(inputId = "question", 
label = "Wählen Sie eine Frage aus",
choices,
selectize = FALSE)
})

output$tabelle <- renderDataTable({
tab <- datatable(get_data() %>% 
summarize(n = n()) %>% 
mutate(Prozent = n / sum(n),
"Kum. Prozent" = cumsum(Prozent)),
rownames = FALSE) %>% 
formatPercentage(c("Prozent","Kum. Prozent"), 1) 

if(input$group==TRUE) {
tab <- get_data() %>%
summarize(n = n()) %>% 
#  mutate(Prozent = n / sum(n)) %>% 
#  mutate(Prozent = percent((n / sum(n)), accuracy = 0.01)) %>% 
pivot_wider(
#id_cols = grp, #wird angezeigt
names_from = grp,
values_from = n) 
}
tab
})

output$downtable <- downloadHandler(
filename = function() {
paste(input$question, ".csv", sep = "")
},
content = function(file) {

tab <- get_data() %>%  
summarize(n = n()) %>% 
mutate(Prozent = percent((n / sum(n)), accuracy = 0.01)
)

if(input$group==TRUE) {
tab <- get_data() %>%
summarize(n = n()) %>% 
#  mutate(Prozent = n / sum(n)) %>% 
#   mutate(Prozent = percent(n, accuracy = 0.01)) %>% 
pivot_wider(
#id_cols = grp, #wird angezeigt
names_from = grp,
values_from = n) 
}

write.csv(tab, file, row.names = FALSE)
}
)

output$plot <- renderPlot({
dat <- get_data()
lik <- likert(dat %>% ungroup() %>% select(Antwortkategorie) %>% 
as.data.frame(),
grouping = if (input$group) dat %>% pull(grp))
plot(lik)
})
output$downplot <- downloadHandler(
filename = function() {
paste(input$question, ".png", sep = "")
}, 
content = function(file) {
png(file)

dat <- get_data()
lik <- likert(dat %>% ungroup() %>% select(Antwortkategorie) %>% 
as.data.frame(),
grouping = if (input$group) dat %>% pull(grp))
#  print(lik)

dev.off()
},
contentType = "image/png"
)
}
shinyApp(ui, server)

Answer 1

试试这个

myplot <- reactive({
dat <- get_data()
lik <- likert(dat %>% ungroup() %>% select(Antwortkategorie) %>% 
as.data.frame(),
grouping = if (input$group) dat %>% pull(grp))
plot(lik)
})

output$plot <- renderPlot({
myplot()
})

output$downplot <- downloadHandler(
filename = function() {
paste(input$question, ".png", sep = "")
}, 
content = function(file) {
png(file)
print(myplot())
dev.off()
},
contentType = "image/png"
)