我正在建立一个关于选举行为的闪亮仪表板， 我有3个小部件：性别，地区和政治部分，用户可以选择性别或/和区域或/和政治部分，并且dashborad将根据所选输入显示情节，我在框内放置了一个收音机按钮允许用户选择堆积条形图类型的图：position =＆＃34; stack＆＃34;或者＆＃34; fill＆＃34;，我添加了一个actionbuttom和isolate（）函数，以便在按下按钮之前，页面上的所有输入都不会向服务器发送更新。但是我想要无线电按钮来指示堆叠条形图的类型不被隔离：这是我使用的代码R：
数据框
pff <- read.table(header=TRUE, text='
REGION Q99 Q101
Tunis Nahdha Femme
Tunis Jabha Femme
Tunis NidaaTounes Homme
Tunis Nepasvoter Femme
Tunis Nepasvoter Homme
Tunis Nepasvoter Femme
Tunis NidaaTounes Homme
Tunis Nepasvoter Homme
Tunis Nahdha Femme
Tunis NidaaTounes Femme
Tunis CPR Femme
Tunis Nahdha Femme
Tunis Autres Homme
Tunis Nepasvoter Homme
Tunis Nepasvoter Femme
Tunis Nahdha Homme
Tunis Jabha Homme
Tunis Nepasvoter Femme
Tunis Nahdha Homme
Tunis Nahdha Femme
Tunis JabhaChaabia Homme
Tunis Autres Femme
Tunis Nepasvoter Femme
Tunis NidaaTounes Femme
Tunis Nepasvoter Homme
Tunis NidaaTounes Femme
Tunis Nepasvoter Homme
Tunis NidaaTounes Homme
Tunis Jabha Femme
Tunis NidaaTounes Homme
Tunis Autres Homme
Tunis Nahdha Femme
Tunis Nahdha Homme
Tunis Autres Femme
Tunis Jabha Homme
Tunis Nepasvoter Femme
Tunis Nepasvoter Homme
Tunis CPR Femme
Tunis Nahdha Homme
Tunis Nepasvoter Femme
Tunis Nepasvoter Homme
Tunis Nepasvoter Femme
Tunis Nahdha Homme
Tunis NidaaTounes Femme
Tunis CPR Homme
Tunis CPR Femme
Tunis Nepasvoter Homme
Tunis Autres Homme
Tunis Nahdha Homme
Tunis NidaaTounes Homme
Tunis Nahdha Femme
Tunis Autres Femme
Tunis Nepasvoter Femme
Ariana Nahdha Femme
Ariana CPR Femme
Ariana Nahdha Femme
Ariana Nepasvoter Homme
Ariana NidaaTounes Homme
Ariana CPR Homme
Ariana Nepasvoter Homme
Ariana Nahdha Homme
Ariana Nepasvoter Femme
Ariana NidaaTounes Homme
Ariana CPR Homme
Ariana NidaaTounes Homme
Ariana NidaaTounes Homme
Ariana NidaaTounes Homme
Ariana CPR Femme
Ariana Nahdha Femme
Ariana CPR Femme
Ariana Nahdha Homme
Ariana Nahdha Homme
Ariana CPR Homme
Ariana Nahdha Homme
Ariana Nepasvoter Homme
Ariana NidaaTounes Homme
Ariana NidaaTounes Homme
Ariana Nahdha Homme ')
服务器
library(shiny)
library(ggplot2)
library(ggalt)
library(dplyr)
library(foreign)
library(plotly)
library(scales)
shinyServer(function(input, output) {
dataa<-reactive({
within(as.data.frame(pff),
Q99 <- factor(Q99,
levels=names(sort(table(Q99),
decreasing=FALSE))))})
partii2=reactive({
filter(dataa(), Q99 %in% input$parti, REGION %in% input$region)
})
output$plot1=renderPlotly({
input$action
isolate(
if(!is.null(input$parti) && !is.null(input$region) && input$genre=="Tous"){
if((length(input$region))==1)
{
g <- ggplot(partii2(), aes(x = Q99, y =(..count..)/sum(..count..)))
g <- g + geom_bar(fill="#0f00ee") + labs(title=paste("Vote dans la région de", input$region,"pour",input$parti,sep = " ")) +labs(x="Parti politique", y="")+coord_flip()+scale_y_continuous(labels = percent)+ theme_bw()+theme(panel.border = element_rect(colour = "white"))
}
else{
g <- ggplot(dataa(), aes(x = REGION, y =(..count..)/1200, fill=Q99))
g <- g + geom_bar(position=input$position) + labs(title="vote") +labs(x=" ", y=" ")+labs(fill="Parti Politique")+scale_y_continuous(labels = percent)+ theme_bw()+theme(panel.border = element_rect(colour = "white")) +coord_flip() + geom_text(aes( label = scales::percent(round((..count..)/1200,3 )),y=(..count..)/1200 ),stat= "count", size=4, position = "stack")
}
}
)
})
})
UI
library(shiny)
library(shinydashboard)
library(foreign)
library(plotly)
shinyUI(dashboardPage(skin = "blue",
dashboardHeader(title = h4("Élections",style = "color:white"),
titleWidth = 300
),
dashboardSidebar(id="",
tags$head(
tags$script(
HTML(
"
$(document).ready(function(){
// Bind classes to menu items, easiet to fill in manually
var ids = ['Enquête','dashboard','Prédiction','Données','Échantillon'];
for(i=0; i<ids.length; i++){
$('a[data-value='+ids[i]+']').addClass('my_subitem_class');
}
// Register click handeler
$('.my_subitem_class').on('click',function(){
// Unactive menuSubItems
$('.my_subitem_class').parent().removeClass('active');
})
})
"
)
)),
sidebarMenu(
menuItem(h4(strong("Enquête")), tabName = "Enquête",
menuSubItem("Données",tabName = "Données"),
menuSubItem("Échantillon",tabName = "Échantillon")),
menuItem(h4(strong("Dashboard")), tabName = "dashboard"),
menuItem(h4(strong("Prédiction")), tabName = "Prédiction"))
),
dashboardBody(
tabItems(
tabItem(tabName = "dashboard",h2("Le comportement électoral des citoyens tunisiens", align="center",style = "color:blue"),
fluidRow(
tiltle="filtre",
column(width=4,
box(
title = "Filtre",
status = "primary",
width = 8,
solidHeader = TRUE,
background="navy",
box(
solidHeader = FALSE,
width = 8,
background = "navy" ,
radioButtons("genre", "Genre", c("Homme","Femme","Tous"),"Tous")
),
box(
solidHeader = FALSE,
width = 12,
background = "navy",
selectizeInput("region", label = "Région",
choices = levels(pff$REGION),
selected = "Ariana", multiple=TRUE)
),
box(
solidHeader = FALSE,
width = 12,
background = "navy",
selectizeInput("parti", label = "Parti politique",
choices = levels(pff$Q99),
selected = "CPR", multiple=TRUE)
),
box(
actionButton("action","Mettre à jour!"),
#submitButton("Mettre à jour!",icon("refresh")),
background = "navy"
)
)
),
box(
solidHeader = FALSE ,width = 8,height = 500,
collapsible = TRUE,align="center",
radioButtons("position", "", c("fill","stack"), selected = "fill", inline = TRUE, width = NULL),
plotlyOutput('plot1', height = 400,width = "100%")
)
)# end of fluidrow
)
))))
答案 0 :(得分：0)
这对你有帮助吗？根据这个问题我改变了服务器端：Convert ggplot object to plotly in shiny application
此外，每次进行相关的用户交互时，服务器都会在控制台中显示输入。
observeEvent(c(input$action,input$position), {
output$plot1<-renderPlotly({
getGgplot <- function(inputObj){
g <- ggplot(data.frame())
if(!is.null(inputObj$parti) && !is.null(inputObj$region) && inputObj$genre=="Tous"){
# generate proper ggplot
if((length(inputObj$region))==1)
{
g <- ggplot(inputObj$partii2, aes(x = Q99, y =(..count..)/sum(..count..)))
g <- g + geom_bar(fill="#0f00ee") + labs(title=paste("Vote dans la région de", inputObj$region,"pour",inputObj$parti,sep = " ")) +labs(x="Parti politique", y="")+coord_flip()+scale_y_continuous(labels = percent)+ theme_bw()+theme(panel.border = element_rect(colour = "white"))
}
else{
g <- ggplot(inputObj$dataa, aes(x = REGION, y =(..count..)/1200, fill=Q99))
g <- g + geom_bar(inputObj$position) + labs(title="vote") +labs(x=" ", y=" ")+labs(fill="Parti Politique")+scale_y_continuous(labels = percent)+ theme_bw()+theme(panel.border = element_rect(colour = "white")) +coord_flip() + geom_text(aes( label = scales::percent(round((..count..)/1200,3 )),y=(..count..)/1200 ),stat= "count", size=4, position = inputObj$position)
}
}
return (
g
)
}
inputs <- list(
"parti" = isolate( input$parti ),
"region" = isolate( input$region ),
"genre" = isolate( input$genre ),
"position" = input$position,
"dataa" = dataa(),
"partii2" = partii2(
partiArg = isolate( input$parti ),
regionArg = isolate( input$region )
)
)
print("inputs:")
print(str(inputs))
g <- getGgplot(inputs)
# return ggplot to ggplotly
print(
ggplotly(g)
)
})
})
您的代码似乎还有其他一些问题，但我真的无法弄清问题是什么。即，当情况“类型= Tous，地区= Ariana和Parti politique = CPR，JabhaChaabia”时，我收到了以下警告：
Warning in if (nchar(p$labels$title %||% "") > 0) { :
the condition has length > 1 and only the first element will be used
所以这是我的综合代码，你怎么说？
library(shiny)
library(shinydashboard)
library(ggplot2)
library(ggalt)
library(dplyr)
library(foreign)
library(plotly)
library(scales)
pff <- read.table(header=TRUE, text='
REGION Q99 Q101
Tunis Nahdha Femme
Tunis Jabha Femme
Tunis NidaaTounes Homme
Tunis Nepasvoter Femme
Tunis Nepasvoter Homme
Tunis Nepasvoter Femme
Tunis NidaaTounes Homme
Tunis Nepasvoter Homme
Tunis Nahdha Femme
Tunis NidaaTounes Femme
Tunis CPR Femme
Tunis Nahdha Femme
Tunis Autres Homme
Tunis Nepasvoter Homme
Tunis Nepasvoter Femme
Tunis Nahdha Homme
Tunis Jabha Homme
Tunis Nepasvoter Femme
Tunis Nahdha Homme
Tunis Nahdha Femme
Tunis JabhaChaabia Homme
Tunis Autres Femme
Tunis Nepasvoter Femme
Tunis NidaaTounes Femme
Tunis Nepasvoter Homme
Tunis NidaaTounes Femme
Tunis Nepasvoter Homme
Tunis NidaaTounes Homme
Tunis Jabha Femme
Tunis NidaaTounes Homme
Tunis Autres Homme
Tunis Nahdha Femme
Tunis Nahdha Homme
Tunis Autres Femme
Tunis Jabha Homme
Tunis Nepasvoter Femme
Tunis Nepasvoter Homme
Tunis CPR Femme
Tunis Nahdha Homme
Tunis Nepasvoter Femme
Tunis Nepasvoter Homme
Tunis Nepasvoter Femme
Tunis Nahdha Homme
Tunis NidaaTounes Femme
Tunis CPR Homme
Tunis CPR Femme
Tunis Nepasvoter Homme
Tunis Autres Homme
Tunis Nahdha Homme
Tunis NidaaTounes Homme
Tunis Nahdha Femme
Tunis Autres Femme
Tunis Nepasvoter Femme
Ariana Nahdha Femme
Ariana CPR Femme
Ariana Nahdha Femme
Ariana Nepasvoter Homme
Ariana NidaaTounes Homme
Ariana CPR Homme
Ariana Nepasvoter Homme
Ariana Nahdha Homme
Ariana Nepasvoter Femme
Ariana NidaaTounes Homme
Ariana CPR Homme
Ariana NidaaTounes Homme
Ariana NidaaTounes Homme
Ariana NidaaTounes Homme
Ariana CPR Femme
Ariana Nahdha Femme
Ariana CPR Femme
Ariana Nahdha Homme
Ariana Nahdha Homme
Ariana CPR Homme
Ariana Nahdha Homme
Ariana Nepasvoter Homme
Ariana NidaaTounes Homme
Ariana NidaaTounes Homme
Ariana Nahdha Homme ')
dataa<-function(){
return (
within(as.data.frame(pff),
Q99 <- factor(Q99,
levels=names(sort(table(Q99),
decreasing=FALSE)))
)
)
}
partii2<-function(partiArg,regionArg){
return(
filter(dataa(), Q99 %in% partiArg, REGION %in% regionArg)
)
}
server <- shinyServer(function(input, output) {
observeEvent(c(input$action,input$position), {
output$plot1<-renderPlotly({
getGgplot <- function(inputObj){
g <- ggplot(data.frame())
if(!is.null(inputObj$parti) && !is.null(inputObj$region) && inputObj$genre=="Tous"){
# generate proper ggplot
if((length(inputObj$region))==1)
{
g <- ggplot(inputObj$partii2, aes(x = Q99, y =(..count..)/sum(..count..)))
g <- g + geom_bar(fill="#0f00ee") + labs(title=paste("Vote dans la région de", inputObj$region,"pour",inputObj$parti,sep = " ")) +labs(x="Parti politique", y="")+coord_flip()+scale_y_continuous(labels = percent)+ theme_bw()+theme(panel.border = element_rect(colour = "white"))
}
else{
g <- ggplot(inputObj$dataa, aes(x = REGION, y =(..count..)/1200, fill=Q99))
g <- g + geom_bar(inputObj$position) + labs(title="vote") +labs(x=" ", y=" ")+labs(fill="Parti Politique")+scale_y_continuous(labels = percent)+ theme_bw()+theme(panel.border = element_rect(colour = "white")) +coord_flip() + geom_text(aes( label = scales::percent(round((..count..)/1200,3 )),y=(..count..)/1200 ),stat= "count", size=4, position = inputObj$position)
}
}
return (
g
)
}
inputs <- list(
"parti" = isolate( input$parti ),
"region" = isolate( input$region ),
"genre" = isolate( input$genre ),
"position" = input$position,
"dataa" = dataa(),
"partii2" = partii2(
partiArg = isolate( input$parti ),
regionArg = isolate( input$region )
)
)
print("inputs:")
print(str(inputs))
g <- getGgplot(inputs)
# return ggplot to ggplotly
print(
ggplotly(g)
)
})
})
})
ui <- shinyUI(dashboardPage(skin = "blue",
dashboardHeader(title = h4("Élections",style = "color:white"),
titleWidth = 300
),
dashboardSidebar(id="",
tags$head(
tags$script(
HTML(
"
$(document).ready(function(){
// Bind classes to menu items, easiet to fill in manually
var ids = ['Enquête','dashboard','Prédiction','Données','Échantillon'];
for(i=0; i<ids.length; i++){
$('a[data-value='+ids[i]+']').addClass('my_subitem_class');
}
// Register click handeler
$('.my_subitem_class').on('click',function(){
// Unactive menuSubItems
$('.my_subitem_class').parent().removeClass('active');
})
})
"
)
)),
sidebarMenu(
menuItem(h4(strong("Enquête")), tabName = "Enquête",
menuSubItem("Données",tabName = "Données"),
menuSubItem("Échantillon",tabName = "Échantillon")),
menuItem(h4(strong("Dashboard")), tabName = "dashboard"),
menuItem(h4(strong("Prédiction")), tabName = "Prédiction"))
),
dashboardBody(
tabItems(
tabItem(tabName = "dashboard",h2("Le comportement électoral des citoyens tunisiens", align="center",style = "color:blue"),
fluidRow(
tiltle="filtre",
column(width=4,
box(
title = "Filtre",
status = "primary",
width = 8,
solidHeader = TRUE,
background="navy",
box(
solidHeader = FALSE,
width = 8,
background = "navy" ,
radioButtons("genre", "Genre", c("Homme","Femme","Tous"),"Tous")
),
box(
solidHeader = FALSE,
width = 12,
background = "navy",
selectizeInput("region", label = "Région",
choices = levels(pff$REGION),
selected = "Ariana", multiple=TRUE)
),
box(
solidHeader = FALSE,
width = 12,
background = "navy",
selectizeInput("parti", label = "Parti politique",
choices = levels(pff$Q99),
selected = "CPR", multiple=TRUE)
),
box(
actionButton("action","Mettre à jour!"),
#submitButton("Mettre à jour!",icon("refresh")),
background = "navy"
)
)
),
box(
solidHeader = FALSE ,width = 8,height = 500,
collapsible = TRUE,align="center",
radioButtons("position", "", c("fill","stack"), selected = "fill", inline = TRUE, width = NULL),
plotlyOutput('plot1', height = 400,width = "100%")
)
)# end of fluidrow
)
))))
shinyApp(server = server, ui = ui)
答案 1 :(得分：0)
如果你检查g$labels，你看到了什么？
看起来您允许输入parti的多个选择。
标题的粘贴声明最有可能选择这些并为您提供多个标题，这就是错误所在。
您可以将parti矢量包装为包含collapse=","的附加粘贴语句，或者将原始粘贴中的所有输入设为带c("My title is",c(1,2))的矢量collapse=" "。 / p>
labs(title=paste("Vote dans la région de", inputObj$region,"pour",paste(inputObj$parti,collapse=","),sep = " "))