I am building a Shiny app to display variables of the "European Social Survey" (table and graph). Therefore I created conditional panels with "selectInput" where the user can select which variable should be displayed. In a second step I want to group the displayed variable by e.g. gender. For doing so I included a checkbox. If this checkbox is TRUE a further conditional panel shows up where the user can choose the independent variable.
I tried to group the plot by using the facet_grid command - without success. Further I tried the generate a very simple crosstable (trying both a datatable command with a dataframe and a table command; latter in the expample below) - also without success.
Any advice?
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(tidyverse)
library(haven)
library(likert)
library(DT)
library(plotly)
levels.netusoft <- c('Sehr wenig', 'Etwas', 'Stark', 'Sehr stark', 'Verweigert', 'Weiß nicht', 'Keine Antwort')
levels.ppltrst <- c('1', '2', '3', '4', '5', '6', 'Verweigert', 'Weiß nicht', 'Keine Antwort')
levels.polintr <- c('Überhaupt nicht', 'Sehr wenig', 'Etwas', 'Stark', 'Sehr stark', 'Verweigert', 'Weiß nicht', 'Keine Antwort')
levels.psppsgva <- c('Überhaupt nicht fähig', 'Wenig fähig', 'Ziemlich fähig', 'Sehr fähig', 'Vollkommen fähig', 'Verweigert', 'Weiß nicht', 'Keine Antwort')
levels.actrolga <- c('Wenig fähig', 'Ziemlich fähig', 'Sehr fähig', 'Vollkommen fähig', 'Verweigert', 'Weiß nicht', 'Keine Antwort')
levels.gndr <- c('männlich', 'weiblich')
dataset <- data.frame('netusoft'=factor(sample(levels.netusoft[1:7], 100, replace=TRUE)),
'ppltrst'=factor(sample(levels.ppltrst[1:8], 100, replace=TRUE)),
'polintr'=factor(sample(levels.polintr[1:8], 100, replace=TRUE)),
'psppsgva'=factor(sample(levels.psppsgva[1:8], 100, replace=TRUE)),
'actrolga'=factor(sample(levels.actrolga[1:7], 100, replace=TRUE)),
'gndr'=factor(sample(levels.gndr[1:2], 100, replace=TRUE)),
check.names=FALSE)
# ----- UI
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = "European Social Survey Österreich Dashboard", titleWidth = 300),
dashboardSidebar(width = 300,
selectInput(inputId='round', label="Wählen Sie eine ESS Runde aus",
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"),
selected = "9", selectize = FALSE), #end selectinput
conditionalPanel(
condition = "input.round == '9'",
selectInput(inputId='battery', label="Wählen Sie Themenfeld aus",
c("A: Medien-, Internetnutzung, Soziales Vertrauen" = "A",
"B: Politische Variablen, Immigration" = "B"), selectize = FALSE), #end selectinput
), #end conditionalPanel
conditionalPanel(
condition = "input.round == '9' && input.battery == 'A'",
selectInput(inputId = "avA_9", label = "Wählen Sie eine Frage aus",
c("A2|Häufigkeit Internetnutzung" = "netusoft",
"A4|Vertrauen in Mitmenschen" = "ppltrst"), selectize = FALSE), #end selectInput
), #end conditionalPanel
conditionalPanel(
condition = "input.round == '9' && input.battery == 'B'",
selectInput(inputId = "avB_9", label = "Wählen Sie eine Frage aus",
c("B1|Interesse an Politik" = "polintr",
"B2|Politische Mitsprachem?glichkeit" = "psppsgva",
"B3|Fähigkeit politischen Engagements " = "actrolga"), selectize = FALSE) #end selectInput
), #end conditionalPanel
checkboxInput(
inputId = "group",
label = "Daten gruppieren",
value = FALSE), #end checkbox
conditionalPanel(
condition = "input.group==true",
selectInput(
inputId = "UV",
label = "Daten gruppieren nach:",
c("Geschlecht" = "gndr")
) # end conditionalPanel
)
), # end dashboardSidebar
dashboardBody(
fluidRow(
box(width = 7, status = "info", solidHeader = TRUE,
title = "Table:",
dataTableOutput("tabelle", width = "100%")
),
box(width = 8, status = "info", solidHeader = TRUE,
title = "Graph:",
plotOutput("plot", width = "auto", height = 500)
)
) # end fluidRow
) #end dashboardBody
)
)
server <- function(input, output) {
av.select <- reactive({
if (input$battery == "A" && input$round == "9") {
av.select <- input$avA_9
}
else if (input$battery == "B" && input$round == "9") {
av.select <- input$avB_9
}
return(av.select)
})
#Plotting the data
plot.data <- reactive({
data <- subset(dataset, select=c(av.select(), input$UV))
data <- data[complete.cases(data)==1,] %>%
mutate_all(as_factor) %>%
droplevels(exclude = c("Weiß nicht", "Verweigert", "Keine Antwort")) %>%
as.data.frame()
})
output$plot <- renderPlot({
plot.data.g <- likert(plot.data()[,1, drop=FALSE])
p <- plot(plot.data.g)
if(input$group==TRUE) {
p <- plot(plot.data.g) + facet_grid(.~input$UV)
}
p
})
#Creating the table
output$tabelle <- renderDataTable({
x <- av.select()
dataset %>%
count(!!as.symbol(x)) %>%
mutate(Antwortkategorie=as_factor(!!as.symbol(x))) %>%
mutate(n=n) %>%
mutate(Prozent = prop.table(n)) %>%
mutate('Kum. Prozent' = cumsum(Prozent)) %>%
as.data.frame() -> for.table
y <- input$UV
test_tab <- table(x, y) %>% as.data.frame()
if(input$group==FALSE){
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)
}
else if(input$group==TRUE){
table(x, y)
}
})
}
shinyApp(ui, server)
Your code had a couple of issues, so I rewrote some parts of it:
I would suggest to provide an explicit level argument to factor to make sure that the subsequent plots and tables are in order (and not sorted alphabetically which would be the default). Secondly, your subsets selected almost always the entire level set so I removed them:
set.seed(1) ## for reproducibility
levels.netusoft <- c("Sehr wenig", "Etwas", "Stark", "Sehr stark", "Verweigert",
"Weiß nicht", "Keine Antwort")
levels.ppltrst <- c("1", "2", "3", "4", "5", "6", "Verweigert", "Weiß nicht",
"Keine Antwort")
levels.polintr <- c("Überhaupt nicht", "Sehr wenig", "Etwas", "Stark", "Sehr stark",
"Verweigert", "Weiß nicht", "Keine Antwort")
levels.psppsgva <- c("Überhaupt nicht fähig", "Wenig fähig", "Ziemlich fähig",
"Sehr fähig", "Vollkommen fähig", "Verweigert", "Weiß nicht",
"Keine Antwort")
levels.actrolga <- c("Wenig fähig", "Ziemlich fähig", "Sehr fähig", "Vollkommen fähig",
"Verweigert", "Weiß nicht", "Keine Antwort")
levels.gndr <- c("männlich", "weiblich")
dataset <- data.frame("netusoft" = factor(sample(levels.netusoft, 100,
replace = TRUE),
levels.netusoft),
"ppltrst" = factor(sample(levels.ppltrst, 100,
replace = TRUE),
levels.ppltrst),
"polintr" = factor(sample(levels.polintr, 100,
replace = TRUE),
levels.polintr),
"psppsgva" = factor(sample(levels.psppsgva, 100,
replace = TRUE),
levels.psppsgva),
"actrolga" = factor(sample(levels.actrolga, 100,
replace = TRUE),
levels.actrolga),
"gndr" = factor(sample(levels.gndr, 100,
replace = TRUE),
levels.gndr),
check.names = FALSE)
I cleaned the list of needed libraries and added the needed likert library:
library(shiny)
library(shinydashboard)
library(dplyr)
library(likert)
library(DT)
library(ggplot2)
library(likert)
Mostly unchanged, but a small thing to make your life easier and to save you some ifs later. Instead of using conditionalPanel for the question, I refered the conditional control to the server using an uiOutput/renderUI construct. In this way we can have one input$question which simply holds the proper question depending on the selection of the battery.
ui <- fluidPage(
dashboardPage(
dashboardHeader(title = "European Social Survey Österreich Dashboard",
titleWidth = 300),
dashboardSidebar(width = 300,
selectInput(inputId = "round",
label = "Wählen Sie eine ESS Runde aus",
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"),
selected = "9", selectize = FALSE),
#end selectinput
conditionalPanel(
condition = "input.round == '9'",
selectInput(inputId = "battery",
label = "Wählen Sie Themenfeld aus",
c("A: Medien-, Internetnutzung, Soziales Vertrauen" = "A",
"B: Politische Variablen, Immigration" = "B"),
selectize = FALSE), #end selectinput
uiOutput("question_placeholder")
),
checkboxInput(
inputId = "group",
label = "Daten gruppieren",
value = FALSE), #end checkbox
conditionalPanel(
condition = "input.group == true",
selectInput(
inputId = "UV",
label = "Daten gruppieren nach:",
c("Geschlecht" = "gndr")
) # end conditionalPanel
)
), # end dashboardSidebar
dashboardBody(
fluidRow(
box(width = 7, status = "info", solidHeader = TRUE,
title = "Table:",
dataTableOutput("tabelle", width = "100%")
),
box(width = 8, status = "info", solidHeader = TRUE,
title = "Graph:",
plotOutput("plot", width = "auto", height = 500)
)
) # end fluidRow
) #end dashboardBody
)
)
Here I made some simplifications, explanations afterwards.
server <- function(input, output, session) {
get_data <- reactive({
req(input$question)
if (input$group) {
dataset %>%
select(Antwortkategorie = input$question, req(input$UV)) %>%
group_by(grp = !!as.symbol(input$UV), Antwortkategorie)
} else {
dataset %>%
select(Antwortkategorie = input$question) %>%
group_by(Antwortkategorie)
}
})
output$question_placeholder <- renderUI({
if (input$battery == "A") {
choices <- c("A2|Häufigkeit Internetnutzung" = "netusoft",
"A4|Vertrauen in Mitmenschen" = "ppltrst")
} else if (input$battery == "B") {
choices <- c("B1|Interesse an Politik" = "polintr",
"B2|Politische Mitsprachemöglichkeit" = "psppsgva",
"B3|Fähigkeit politischen Engagements " = "actrolga")
}
selectInput(inputId = "question",
label = "Wählen Sie eine Frage aus",
choices,
selectize = FALSE)
})
output$tabelle <- renderDataTable({
datatable(get_data() %>%
summarize(n = n()) %>%
mutate(Prozent = n / sum(n),
"Kum. Prozent" = cumsum(Prozent)),
rownames = FALSE) %>%
formatPercentage(c("Prozent","Kum. Prozent"), 1)
})
output$plot <- renderPlot({
dat <- req(get_data())
lik <- likert(dat %>% ungroup() %>% select(Antwortkategorie) %>%
as.data.frame(),
grouping = if (input$group) dat %>% pull(grp))
plot(lik)
})
}
The reactive get_data returns the relevant columns from dataset. That is the proper question plus the grouping (if selected). It relies on dplyr::group_by to add the respective grouping layers. I group by Antwortkategorie as well, as I will use summarise(n = n()) instead of count(Antwortkategorie) for finer control.
renderUI: based on the the selection of battery we add different choices to the selectInput. With this approach we can always refer to the question as input$question and no need of additional branching later.
renderDataTable: uses get_data() to receive the data which is already (thanks to the logic in get_data) accordingly grouped. All we have to do is to calculate counts using n() and percentages. You can see that if you select a grouping variable the table is updated accordingly. (percentages are always relativ to the grouping)
renderPlot: likert knows a parameter grouping, which, if not NULL, takes care of the grouping. Thus, all we have to do is to provide it to likert. There is a nuisance with likert that it can't deal with tibbles, hence, the explicit cast to data.frame. The ungroup is necessary becaus eby default select will always select the grouping elements on top of the explicitely selected ones.