shiny - 具有反应输入和数据表输出的闪亮仪表板应用程序
问题描述
我创建了一个应用程序，其中代码在闪亮的应用程序之外工作，但不在应用程序内部。除数据表输出外，一切正常。有很多代码，很抱歉，但重要的代码在最后，renderDataTable 反应函数。
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)
它在独立版本中如下所示，其中每个响应选项都单独列出：
在我的闪亮仪表板输出中，我只得到一行！
任何建议都非常感谢！
非常感谢你，彼得
解决方案
使用mtcars为例：
> mtcars %>% count(carb)
carb n
1 1 7
2 2 10
3 3 3
4 4 10
5 6 1
6 8 1
你的预期输出，我想？但 ...
> mtcars %>% count("carb")
"carb" n
1 carb 32
不是你想要的。问题是 tidyverse 的非标准评估。一种解决方案：
> 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
如果这不起作用，您可能需要x <- enquo(av.select())后跟... count(!! x) ... .
推荐阅读
- c++ - 不同类型标识符的编译时计数器
- selenium - 找不到 Chromedriver：可执行文件需要在 PATH 中
- python - Python - 在可迭代中搜索项目并按特定顺序创建列表
- adsense - 为什么 Google Ad Manager 收入不显示在 Adsense 中
- html - 链接到同一根文件夹中的新 HTML 页面不起作用
- c# - 授权属性在 JWT 和 asp.net core 2.1 中不起作用
- augmented-reality - 当使用 ARCore 查找平面时出现延迟时，如何使对象放置变得真实？
- c# - Blazor 组件可以在 xml 中作为自然父子级处理吗？
- python - 如何在循环中连接超过 2 个 ndarray(variable)（其中一个是第一个循环中的 EMPTY）
- python - 有没有办法根据使用 pushshift API 的天赋来获取提交或 subreddit？