I have created an app where the code works outside of a shiny app but not inside the app. Everything is working except the datatable output. There is a lot of code, sorry for that, but the important code is at the end, the renderDataTable reactive function.
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)
It looks like the following in the stand-alone version, where each response option is listed separately:
In my shinydashboard output I only get one row!
Using mtcars as an example:
> mtcars %>% count(carb)
carb n
1 1 7
2 2 10
3 3 3
4 4 10
5 6 1
6 8 1
Your expected output, I think? But ...
> mtcars %>% count("carb")
"carb" n
1 carb 32
Not what you want. The problem is tidyverse's non-standard evaluation. One solution:
> 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
If that doesn't work, you may need x <- enquo(av.select()) followed by ... count(!! x) ... .