分组无功输入会生成空输出图
Grouping reactive input generates empty output-plot
我正在构建一个闪亮的应用程序来显示“欧洲社会调查”的变量（table 和图表）。因此，我使用“selectInput”创建了条件面板，用户可以在其中 select 显示哪个变量。在第二步中，我想对显示的变量进行分组，例如性别。为此，我包含了一个复选框。如果此复选框为 TRUE，则会显示进一步的条件面板，用户可以在其中选择自变量：
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
output$plot <- renderPlot(function(){
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() -> plot.data
})
plot.data.g <- likert(items = plot.data[,1, drop=FALSE], grouping = plot.data[,2,drop=FALSE])
if(input$group==FALSE)
{plot(plot.data.g) +
ggtitle(q_text()) +
xlab("Frage")}
if(input$group==TRUE)
{plot(plot.data.g) +
ggtitle(q_text()) +
xlab("Frage") +
labs(x=av.select()) +
facet_grid(input$UV)}
})
#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
print(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)
})
}
shinyApp(ui, server)
我的 question/problem 现在是：如何在服务器端生成对因变量和自变量进行分组？我的代码 returns 一个空图。
您对 output$plot 的定义有几个问题。如果您 运行 将来遇到此类问题，我建议您将问题分解为更小的步骤：从头开始 - 您是否有正确的输入数据？然后进入下一步：你的汇总功能有用吗？等等等等
这里的问题似乎是：
- 你嵌套反应。不要将
reactive 定义放在 renderXXX 调用中。
- 您没有将
renderPlot 中的 reactive 分配给对象。
- 您的
renderPlot 定义了一个从未被调用的函数。
我没有 lickert 包并且不想安装它只是为了回答一个 Whosebug 问题，所以我修改了你的 renderPlot 以生成一个简单的条形图输入数据，我怀疑它接近你想要的。您必须进行明显的修改才能恢复原始情节。
将您当前对 output$plot 的定义替换为：
#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()
data
})
output$plot <- renderPlot({
# plot.data.g <- likert(items = plot.data[,1, drop=FALSE], grouping = plot.data[,2,drop=FALSE])
# p <- plot(plot.data.g) + ggtitle(q_text()) + xlab("Frage")
p <- plot.data() %>% ggplot() + geom_bar(aes(x=netusoft))
if(input$group) {
p <- p + facet_grid(input$UV)
}
p
})
这是根据请求的分组生成的绘图示例。
我正在构建一个闪亮的应用程序来显示“欧洲社会调查”的变量（table 和图表）。因此，我使用“selectInput”创建了条件面板，用户可以在其中 select 显示哪个变量。在第二步中，我想对显示的变量进行分组，例如性别。为此，我包含了一个复选框。如果此复选框为 TRUE，则会显示进一步的条件面板，用户可以在其中选择自变量：
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
output$plot <- renderPlot(function(){
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() -> plot.data
})
plot.data.g <- likert(items = plot.data[,1, drop=FALSE], grouping = plot.data[,2,drop=FALSE])
if(input$group==FALSE)
{plot(plot.data.g) +
ggtitle(q_text()) +
xlab("Frage")}
if(input$group==TRUE)
{plot(plot.data.g) +
ggtitle(q_text()) +
xlab("Frage") +
labs(x=av.select()) +
facet_grid(input$UV)}
})
#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
print(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)
})
}
shinyApp(ui, server)
我的 question/problem 现在是：如何在服务器端生成对因变量和自变量进行分组？我的代码 returns 一个空图。
您对 output$plot 的定义有几个问题。如果您 运行 将来遇到此类问题，我建议您将问题分解为更小的步骤：从头开始 - 您是否有正确的输入数据？然后进入下一步：你的汇总功能有用吗？等等等等
这里的问题似乎是：
- 你嵌套反应。不要将
reactive定义放在renderXXX调用中。 - 您没有将
renderPlot中的reactive分配给对象。 - 您的
renderPlot定义了一个从未被调用的函数。
我没有 lickert 包并且不想安装它只是为了回答一个 Whosebug 问题，所以我修改了你的 renderPlot 以生成一个简单的条形图输入数据，我怀疑它接近你想要的。您必须进行明显的修改才能恢复原始情节。
将您当前对 output$plot 的定义替换为：
#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()
data
})
output$plot <- renderPlot({
# plot.data.g <- likert(items = plot.data[,1, drop=FALSE], grouping = plot.data[,2,drop=FALSE])
# p <- plot(plot.data.g) + ggtitle(q_text()) + xlab("Frage")
p <- plot.data() %>% ggplot() + geom_bar(aes(x=netusoft))
if(input$group) {
p <- p + facet_grid(input$UV)
}
p
})
这是根据请求的分组生成的绘图示例。