带有反应式输入和 Likert 绘图输出的闪亮仪表板应用程序

Question

我创建了一个应用程序，其中代码在闪亮的应用程序外部运行，但不在应用程序内部运行。除了简单的李克特图之外，一切都正常。代码有点多，不过重要的代码在最后

library(shiny)
library(shinydashboard)
library(tidyverse)
library(likert)

levels.nwspol <- c('Sehr wenig', 'Etwas', 'Stark', 'Sehr stark', 'Verweigert', 'Weiß nicht', 'Keine Antwort')
levels.psppgva <- c('Überhaupt nicht', 'Sehr wenig', 'Etwas', 'Stark', 'Sehr stark', 'Verweigert', 'Weiß nicht', 'Keine Antwort')
levels.actrolga <- c('Überhaupt nicht fähig', 'Wenig fähig', 'Ziemlich fähig', 'Sehr fähig', 'Vollkommen fähig', 'Verweigert', 'Weiß nicht', 'Keine Antwort')
levels.cptppola <- c('Vertraue meinen Fähigkeiten überhaupt nicht', 
                    'Vertraue meinen Fähigkeiten ein bisschen', 
                    'Vertraue meinen Fähigkeiten ziemlich', 
                    'Vertraue meinen Fähigkeiten sehr', 
                    'Vertraue meinen Fähigkeiten voll und ganz', 'Verweigert', 'Weiß nicht', 'Keine Antwort')
dataset <- data.frame('nwspol'=factor(sample(levels.psppgva[1:7], 100, replace=TRUE)),
                    'psppgva'=factor(sample(levels.psppgva[1:8], 100, replace=TRUE)),
                    'actrolga'=factor(sample(levels.actrolga[1:8], 100, replace=TRUE)),
                    'psppipla'=factor(sample(levels.psppgva[1:8], 100, replace=TRUE)),
                    'cptppola'=factor(sample(levels.cptppola[1:8], 100, replace=TRUE)),
                    check.names=FALSE)

# ----- UI
ui <- fluidPage(
  dashboardPage(
    dashboardHeader(title = "ESS9", titleWidth = 300),
    dashboardSidebar(width = 300,
                     sidebarMenu(
                       menuItem(h3("ESS Runde:"), tabName = "round"), 
                       selectInput(inputId='round', label="",  
                                   c("ESS 1" = "1",
                                     "ESS 2" = "2",
                                     "ESS 3" = "3",
                                     "ESS 4" = "4",
                                     "ESS 5" = "5",
                                     "ESS 7" = "7",
                                     "ESS 8" = "8",
                                     "ESS 9" = "9")), #end selectinput
                       menuItem(h3("Fragenbatterie:"), tabName = "fb"), 
                       conditionalPanel(
                         condition = "input.round == '9'",
                         selectInput(inputId='battery', label="",  
                                     c("A: Medien-, Internetnutzung, Soziales Vertrauen" = "A",
                                       "B: Politische Variablen, Immigration" = "B",
                                       "C: Wohlbefinden, Exklusion, Diskriminierung, Identität" = "C",
                                       "D: Modul: Lebensplanung" = "D",
                                       "G: Modul: Gerechtigkeit und Fairness" = "G")), #end selectinput
                       ), #end conditionalPanel
                       menuItem(h3("Frage"), tabName = "qu"),
                       conditionalPanel(
                         condition = "input.round == '9' && input.battery == 'A'",
                         selectInput(inputId = "avA", label = "Frage?", 
                                     c("A1|Konsum Nachrichten Politik" = "nwspol", 
                                       "A2|Häufigkeit Internetnutzung" = "netusoft", 
                                       "A3|Dauer/Tag Internet" = "netustm", 
                                       "A4|Vertrauen in Mitmenschen" = "ppltrst", 
                                       "A5|Fairness Mitmenschen" = "pplfair", 
                                       "A6|Hilfsbereitschaft Mitmenschen" = "pplhlp")), #end selectInput
                       ), #end conditionalPanel 
                       conditionalPanel(
                         condition = "input.round == '9' && input.battery == 'B'",
                         selectInput(inputId = "avB", label = "Frage?", 
                                     c("B1|Interesse an Politik" = "polintr", 
                                       "B2|Politische Mitsprachemöglichkeit" = "psppsgva", 
                                       "B3|Fähigkeit politischen Engagements " = "actrolga", 
                                       "B4|Möglichkeit Beeinflussung Politik" = "psppipla", 
                                       "B5|Möglichkeit Einfluss auf Politik" = "cptppola")) #end selectInput
                       ) #end conditionalPanel
                     )), # end dashboardSidebar
    
    dashboardBody(
      
      fluidRow(
        valueBoxOutput("essrunde"),
        valueBoxOutput("battery"),
        valueBoxOutput("av")
      ), # end fluidRow
      
      fluidRow(
        valueBoxOutput("cases.ex.na"),
        valueBoxOutput("cases.inc.na"),
        valueBoxOutput("resp.rate")
      ), # end fluidRow
      
      fluidRow(
        uiOutput("qu.text")
      ), # end fluidRow
      
      fluidRow(
        box(
          width = 6, status = "info", solidHeader = TRUE,
          title = "Graphische Darstellung:",
          plotOutput("plot", width = "100%", height = 600)
        ),
        box(
          width = 6, status = "info", solidHeader = TRUE,
          title = "Tabellarische Darstellung:"
        ),
      ) # end fluidRow
    ) #end dashboardBody
  )
)

server <- function(input, output) {
  
  #Auswahl der gewählten Batterie (muss in einer reactive-Umgebung sein!)
  av.select <- reactive({
    if (input$battery == "A") {
      av.select <- input$avA
    }
    else if (input$battery == "B") {
      av.select <- input$avB
    }
    else if (input$battery == "C") {
      av.select <- input$avC
    }
    else if (input$battery == "D") {
      av.select <- input$avD
    }
    else if (input$battery == "E") {
      av.select <- input$avE
    }
    else if (input$battery == "F") {
      av.select <- input$avF
    }
    else if (input$battery == "G") {
      av.select <- input$avG
    }
    return(av.select)
  })
  
  #Fragentext extrahieren
  
  q_text <- reactive({
    dataset %>%
      select(av.select()) -> for.text
    q_text <- attr(for.text[[1]], "label")
    return(q_text)
  })
  
  #Definition erste Reihe valueBox
  
  output$essrunde <- renderValueBox({
    valueBox(tags$p("ESS Runde:", style = "font-size: 60%;"), 
             tags$p(input$round, style = "font-size: 120%;"), 
             icon = icon("list"), 
             color = "red")
  })
  
  output$battery <- renderValueBox({
    valueBox(tags$p("Fragenbatterie:", style = "font-size: 60%;"), 
             tags$p(input$battery, style = "font-size: 120%;"), 
             icon = icon("list"), 
             color = "red")
  })
  
  output$av <- renderValueBox({
    valueBox(tags$p("Gewählte Variable:", style = "font-size: 60%;"),
             tags$p(av.select(), style = "font-size: 120%;"), 
             icon = icon("list"), 
             color = "red")
  })
  
  #Definition zweite Reihe valueBox  
  
  output$cases.ex.na <- renderValueBox({
    cases <- subset(dataset, select=c(av.select()))
    valueBox(tags$p("Fallzahl (ohne dk/na):", style = "font-size: 60%;"),
             tags$p(sum(complete.cases(cases)), style = "font-size: 120%;"),
             icon = icon("list"))
  })
  
  output$cases.inc.na <- renderValueBox({
    cases <- subset(dataset, select=c(av.select()))
    valueBox(tags$p("Fehlende Fälle (inkl. dk/na):", style = "font-size: 60%;"),
             tags$p(sum(sum(is.na(cases))), style = "font-size: 120%;"),
             icon = icon("list"))
  })
  
  output$resp.rate <- renderValueBox({
    valueBox(tags$p("Rücklaufquote:", style = "font-size: 60%;"),
             tags$p("52,1%", style = "font-size: 120%;"), 
             icon = icon("list-ol"))
  })
  
  #Definition dritte Reihe valueBox  
  
  output$qu.text <- renderUI({
    valueBox(tags$p("Fragentext:", style = "font-size: 60%;"),
             tags$p(q_text(), style = "font-size: 120%;"), 
             color = "green",
             width = 12)
  })
  
  #Plotting the data  
  output$plot <- renderPlot(
    plot.data <- subset(dataset, select=c(av.select)),
    plot.data <- as_factor(plot.data),
    plot.data <- droplevels(plot.data, exclude = c("Weiß nicht", "Verweigert", "Keine Antwort")),
    plot.data <- as.data.frame(plot.data),
    
    plot.data.g <- likert(plot.data[,1, drop=FALSE]),
    
    plot(plot.data.g) + 
      ggtitle(q_text) + 
      xlab("Frage")
  )
  
}    

shinyApp(ui, server)

错误发生在output$plot函数的最后一段代码中。不知何故，我无法充分地对数据集进行子集化，以便为 Likert 包做好准备。

Answer 1

您的代码有两个问题。首先，在 renderPlot 中，您必须将代码括在大括号中。还。您删除逗号来分隔行。其次，要从反应中获取值，您必须像函数一样调用它们，例如

av.select()

。试试这个：

#Plotting the data  
  output$plot <- renderPlot({
    plot.data <- subset(dataset, select=c(av.select()))
    plot.data <- as_factor(plot.data)
    plot.data <- droplevels(plot.data, exclude = c("Weiß nicht", "Verweigert", "Keine Antwort"))
    plot.data <- as.data.frame(plot.data)
    
    #browser()
    
    plot.data.g <- likert(plot.data[,1, drop=FALSE])
    
    plot(plot.data.g) + 
      ggtitle(q_text()) + 
      xlab("Frage")}
  )