带有反应式输入和数据表输出的闪亮仪表板应用程序

问题描述 投票：0回答：1

我创建了一个应用程序，其中代码在闪亮的应用程序外部运行，但不在应用程序内部运行。除了数据表输出之外，一切正常。有很多代码，抱歉，但重要的代码在最后，renderDataTable 反应函数。

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 = "ESS", 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:",
          dataTableOutput("tabelle")
        ),
      ) # 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({
    dataset %>%
      select(av.select()) %>%
      mutate_all(as_factor) %>%
      droplevels(exclude = c("Weiß nicht", "Verweigert", "Keine Antwort")) %>%
      as.data.frame() -> plot.data
    
    plot.data.g <- likert(plot.data[,1, drop=FALSE])
    
    plot(plot.data.g) + 
      ggtitle(q_text()) + 
      xlab("Frage")
  })
  
  output$tabelle <- renderDataTable({
    dataset %>%
      count(av.select()) %>%
      mutate(Antwortkategorie=as_factor(av.select())) %>%
      mutate(n=n) %>%
      mutate(Prozent = prop.table(n)) %>%
      mutate('Kum. Prozent' = cumsum(Prozent)) -> for.table
    
    datatable(for.table[,c(3,2,4,5)], extensions = 'Buttons', options = list(dom = 'Brtip', buttons = c('copy', 'csv', 'excel', 'pdf', 'print'))) %>%
      formatPercentage(c('Prozent','Kum. Prozent'), 1) %>%
      formatStyle(
        'Prozent',
        background = styleColorBar(for.table$Prozent, 'steelblue'),
        backgroundSize = '100% 90%',
        backgroundRepeat = 'no-repeat',
        backgroundPosition = 'center'
      ) 
  })
  
}    

shinyApp(ui, server)

在独立版本中如下所示，其中每个响应选项都单独列出：

独立输出

在我的闪亮仪表板输出中，我只得到一行！

闪亮输出

r shiny datatable
1个回答
1
投票

以

mtcars
为例：

> mtcars %>%  count(carb)
  carb  n
1    1  7
2    2 10
3    3  3
4    4 10
5    6  1
6    8  1

我想你的预期产出是多少？ 但是...

> mtcars %>% count("carb")
  "carb"  n
1   carb 32

不是你想要的。 问题在于tidyverse的不标准的评价。 一种解决方案：

> x <- "carb"
> mtcars %>% count(!! as.symbol(x))
  carb  n
1    1  7
2    2 10
3    3  3
4    4 10
5    6  1
6    8  1

如果这不起作用，您可能需要 

x <- enquo(av.select())
，然后是 
... count(!! x) ...
。

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.