我创建了一个应用程序，其中代码在闪亮的应用程序之外工作，但不在应用程序内部。除了简单的李克特图外，一切正常。代码很多，很抱歉，但重要的代码在最后。
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 = "ESS9", 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:"
),
) # 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(
plot.data <- subset(dataset, select=c(av.select)),
plot.data <- as_factor(plot.data),
plot.data <- droplevels(plot.data, exclude = c("Weiß nicht", "Verweigert", "Keine Antwort")),
plot.data <- as.data.frame(plot.data),
plot.data.g <- likert(plot.data[,1, drop=FALSE]),
plot(plot.data.g) +
ggtitle(q_text) +
xlab("Frage")
)
}
shinyApp(ui, server)
错误发生在 output$plot 函数的最后一段代码中。不知何故，我无法充分地对数据集进行子集化，以便为 likert-package 做好准备。
非常感谢任何帮助，因为我已经调试该代码好几天了。
非常感谢！
