rshinylikert

Shiny Dashboard App with reactive input and likert plot output

I have created an app where the code works outside of a shiny app but not inside the app. Everything is working except the simple likert plot. There is a lot of code, but the important code is at the end.

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)

The error happens in the last piece of code in the output$plot function. Somehow I cannot adequately subset the dataset in order to prepare it for the likert-package.

Solution

  • There are two issues with your code. First, in your renderPlot you have to wrap the code in braces. Also. You remove the commas to seperate the lines. Second to get the values from a reactive you have to call them like a function, e.g. av.select(). Try this:

    #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")}
  )

    enter image description here