R Shiny：具有反应值的交叉表和绘图分组
R Shiny: Crosstable and Plot grouping with reactive values
我正在构建一个闪亮的应用程序来显示“欧洲社会调查”的变量（table 和图表）。因此，我使用“selectInput”创建了条件面板，用户可以在其中 select 显示哪个变量。在第二步中，我想对显示的变量进行分组，例如性别。为此，我包含了一个复选框。如果此复选框为真，则会显示一个进一步的条件面板，用户可以在其中选择自变量。
我尝试使用 facet_grid 命令对情节进行分组 - 但没有成功。此外，我尝试生成一个非常简单的 crosstable（同时尝试使用带有数据帧的 datatable 命令和 table 命令；后者在下面的示例中）- 也没有成功。
有什么建议吗？
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)
您的代码有几个问题，所以我重写了其中的一些部分：
数据
我建议为 factor 提供一个明确的 level 参数，以确保后续的绘图和 table 是有序的（而不是按字母顺序排序，这将是默认）。其次，您的子集 select 几乎总是整个级别集，所以我删除了它们：
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)
库
我清理了所需库的列表并添加了所需的 likert 库：
library(shiny)
library(shinydashboard)
library(dplyr)
library(likert)
library(DT)
library(ggplot2)
library(likert)
UI
大部分没有变化，但这是一件小事，可以让您的生活更轻松，并在以后为您节省一些 ifs。我没有使用 conditionalPanel 作为问题，而是使用 uiOutput/renderUI 构造将条件控制引用到服务器。通过这种方式，我们可以得到一个 input$question，它根据电池的 select 离子简单地持有正确的问题。
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
)
)
服务器
这里我做了一些简化，事后解释。
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)
})
}
反应性get_data returns 来自dataset的相关专栏。这是正确的问题加上分组（如果 selected）。它依赖于 dplyr::group_by 添加各自的分组层。我也按 Antwortkategorie 分组，因为我将使用 summarise(n = n()) 而不是 count(Antwortkategorie) 进行更好的控制。
renderUI：在battery的select基础上，我们在selectInput中加入了不同的选择。使用这种方法，我们总是可以将问题称为 input$question 并且以后不需要额外的分支。
renderDataTable：使用get_data()接收已经（感谢get_data中的逻辑）相应分组的数据。我们所要做的就是使用 n() 和百分比计算计数。您可以看到，如果您 select 一个分组变量，那么 table 会相应更新。 （百分比总是相对于分组）
renderPlot：likert 知道一个参数 grouping，如果没有 NULL，它负责分组。因此，我们所要做的就是提供给likert。 likert 有一个麻烦，它无法处理 tibbles，因此，显式转换为 data.frame。 ungroup 是必需的，因为默认情况下 select 将始终 select 分组元素位于显式 select 编辑的元素之上。
@thothal 哇！非常非常感谢你！非常感谢您的帮助！
只有一个问题：通过选择组变量，每个 Antwortkategorie 都显示为“männlich”和“weiblich”，例如：
grp
Antwortkategorie
n
männlich
Sehr wenig
11
männlich
etwas
5
weiblich
Sehr wenig
4
weiblich
etwas
3
如何管理这样的输出：
Variable
männlich
weiblich
Sehr wenig
11
4
etwas
5
3
我正在构建一个闪亮的应用程序来显示“欧洲社会调查”的变量（table 和图表）。因此，我使用“selectInput”创建了条件面板，用户可以在其中 select 显示哪个变量。在第二步中，我想对显示的变量进行分组，例如性别。为此，我包含了一个复选框。如果此复选框为真，则会显示一个进一步的条件面板，用户可以在其中选择自变量。
我尝试使用 facet_grid 命令对情节进行分组 - 但没有成功。此外，我尝试生成一个非常简单的 crosstable（同时尝试使用带有数据帧的 datatable 命令和 table 命令；后者在下面的示例中）- 也没有成功。
有什么建议吗？
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)
您的代码有几个问题，所以我重写了其中的一些部分：
数据
我建议为 factor 提供一个明确的 level 参数，以确保后续的绘图和 table 是有序的（而不是按字母顺序排序，这将是默认）。其次，您的子集 select 几乎总是整个级别集，所以我删除了它们：
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)
库
我清理了所需库的列表并添加了所需的 likert 库：
library(shiny)
library(shinydashboard)
library(dplyr)
library(likert)
library(DT)
library(ggplot2)
library(likert)
UI
大部分没有变化，但这是一件小事，可以让您的生活更轻松，并在以后为您节省一些 ifs。我没有使用 conditionalPanel 作为问题，而是使用 uiOutput/renderUI 构造将条件控制引用到服务器。通过这种方式，我们可以得到一个 input$question，它根据电池的 select 离子简单地持有正确的问题。
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
)
)
服务器
这里我做了一些简化，事后解释。
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)
})
}
反应性
get_datareturns 来自dataset的相关专栏。这是正确的问题加上分组（如果 selected）。它依赖于dplyr::group_by添加各自的分组层。我也按Antwortkategorie分组，因为我将使用summarise(n = n())而不是count(Antwortkategorie)进行更好的控制。renderUI：在battery的select基础上，我们在selectInput中加入了不同的选择。使用这种方法，我们总是可以将问题称为input$question并且以后不需要额外的分支。renderDataTable：使用get_data()接收已经（感谢get_data中的逻辑）相应分组的数据。我们所要做的就是使用n()和百分比计算计数。您可以看到，如果您 select 一个分组变量，那么 table 会相应更新。 （百分比总是相对于分组）renderPlot：likert知道一个参数grouping，如果没有NULL，它负责分组。因此，我们所要做的就是提供给likert。likert有一个麻烦，它无法处理tibbles，因此，显式转换为data.frame。ungroup是必需的，因为默认情况下select将始终 select 分组元素位于显式 select 编辑的元素之上。
@thothal 哇！非常非常感谢你！非常感谢您的帮助！ 只有一个问题：通过选择组变量，每个 Antwortkategorie 都显示为“männlich”和“weiblich”，例如：
| grp | Antwortkategorie | n |
|---|---|---|
| männlich | Sehr wenig | 11 |
| männlich | etwas | 5 |
| weiblich | Sehr wenig | 4 |
| weiblich | etwas | 3 |
如何管理这样的输出：
| Variable | männlich | weiblich |
|---|---|---|
| Sehr wenig | 11 | 4 |
| etwas | 5 | 3 |