R Shiny: downloadHandler — проблема в аргументе содержимого

У меня есть приложение Shiny, и я хочу загрузить график в формате png с помощью кнопки загрузки и команды «downloadHandler». Как вы можете видеть в приведенном ниже коде, он должен использовать input$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)
Стоит ли изучать PHP в 2023-2024 годах?
Стоит ли изучать PHP в 2023-2024 годах?
Привет всем, сегодня я хочу высказать свои соображения по поводу вопроса, который я уже много раз получал в своем сообществе: "Стоит ли изучать PHP в...
Поведение ключевого слова "this" в стрелочной функции в сравнении с нормальной функцией
Поведение ключевого слова "this" в стрелочной функции в сравнении с нормальной функцией
В JavaScript одним из самых запутанных понятий является поведение ключевого слова "this" в стрелочной и обычной функциях.
Приемы CSS-макетирования - floats и Flexbox
Приемы CSS-макетирования - floats и Flexbox
Здравствуйте, друзья-студенты! Готовы совершенствовать свои навыки веб-дизайна? Сегодня в нашем путешествии мы рассмотрим приемы CSS-верстки - в...
Тестирование функциональных ngrx-эффектов в Angular 16 с помощью Jest
В системе управления состояниями ngrx, совместимой с Angular 16, появились функциональные эффекты. Это здорово и делает код определенно легче для...
Концепция локализации и ее применение в приложениях React ⚡️
Концепция локализации и ее применение в приложениях React ⚡️
Локализация - это процесс адаптации приложения к различным языкам и культурным требованиям. Это позволяет пользователям получить опыт, соответствующий...
Пользовательский скаляр GraphQL
Пользовательский скаляр GraphQL
Листовые узлы системы типов GraphQL называются скалярами. Достигнув скалярного типа, невозможно спуститься дальше по иерархии типов. Скалярный тип...
0
0
18
1
Перейти к ответу Данный вопрос помечен как решенный

Ответы 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"
  )

Другие вопросы по теме