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