问题描述
我想通过 shinydashboard 构建一个像这样工作的应用：
textInput- 提交
actionbutton以根据输入文本更新值框 -
valueBox（显示输入文本） -
TabBox带有 5 个tabpanel - 每个
tabpanel都有包含不同数据并由 Highcharter 呈现的直方图 -
Verbatimtextoutput表明选择了哪个 tabpanel
这是我的代码：
library(shiny)
library(shinydashboard)
library(highcharter)
### Data ================================================
set.seed(1)
Ext <- round(rnorm(500,runif(1,25,35),4,12)))
set.seed(2)
Con <- round(rnorm(500,12)))
set.seed(3)
Agr <- round(rnorm(500,12)))
set.seed(4)
Emo <- round(rnorm(500,12)))
set.seed(5)
Int <- round(rnorm(500,12)))
### Apps Atribut ========================================
header <- dashboardHeader(
title = "IPIP-BFM-50"
)
sidebar <- dashboardSidebar()
body <- dashboardBody(
fluidRow(
Box(
textInput(
"unicode","Your Unique ID:",placeholder = "Input your unique ID here"
),actionButton(
"ab1_unicode","Submit"
),width = 6
),tags$head(tags$style(HTML(".small-Box {height: 130px}"))),valueBoxOutput(
"vBox1_unicode",width = 6
)
),fluidRow(
tabBox(
title = "Dimensi Big-Five Marker",id = "tabset1",height = "500px",width = 12,tabPanel(
"Extraversion","This is Extraversion",highchartOutput(
"hist"
)
),tabPanel(
"ConscientIoUsness","This is ConscientIoUsness",tabPanel(
"Agreeableness","This is Agreeableness",tabPanel(
"Emotional Stability","This is Emotional Stability",tabPanel(
"Intelligent","This is Intelligent",highchartOutput(
"hist"
)
)
)
),fluidRow(
Box(
"Personality in a nutshell",br(),"Second row of personality explanation",verbatimtextoutput(
"tabset1selected"
),height = "250px"
)
)
)
### Atribut server
### Apps ================================================
ui <- dashboardPage(header,sidebar,body)
server <- function(input,output){
update_unicode <- eventReactive(input$ab1_unicode,{
input$unicode
},ignoreNULL = F)
output$vBox1_unicode <- renderValueBox({
valueBox(
update_unicode(),"Your Unique ID",icon = icon("fingerprint")
)
})
dimension <- function(dim){
if(dim == "Extraversion"){
Ext
} else if(dim == "ConscientIoUsness"){
Con
} else if(dim == "Agreeableness"){
Agr
} else if(dim == "Emotional Stability"){
Emo
} else if(dim == "Intelligent"){
Int
}
}
output$hist <- renderHighchart({
hchart(
dimension(input$tabset1)
) %>%
hc_xAxis(
list(
title = list(
text = "Data"
),plotBands = list(
color = '#3ac9ad',from = update_unicode,to = update_unicode,label = list(
text = "Your score",color = "#9e9e9e",align = ifelse(update_unicode>30,"right","left"),x = ifelse(update_unicode>30,-10,+10)
)
)
)
)
})
output$tabset1selected <- renderText({
input$tabset1
})
}
shinyApp(ui = ui,server = server)
问题：
- 值框消失
- highchart 没有出现
我只制作了 1 个带有条件的直方图以节省效率。但看起来效果不佳。
结果是这样的
请帮帮我
解决方法
问题在于 UI 和服务器端的 id 之间的绑定必须是唯一的。但是，在您的仪表板中，id="hist" 在 UI 中出现不止一次，即您有重复的绑定。
这可以通过 1. 在浏览器中打开仪表板，2. 打开开发工具 3. 查看控制台输出看到，其中显示 JS 错误消息“Duplicate binding for id hist”。
不确定您的最终结果，但要解决此问题，您可以例如每个面板添加一个 highchartOutput。为此：
- 我已将绘图代码放在一个单独的函数中
make_hc - 为您的每个面板或数据集添加了一个
highchartOutput，例如
output$hist1 <- renderHighchart({
make_hc("Extraversion",update_unicode())
})
- 通过这种方式，我们可以得到 5 个带有唯一
id的输出，这些输出可以放在 UI 的各个面板中。
完整的可重现代码：
library(shiny)
library(shinydashboard)
library(highcharter)
### Data ================================================
set.seed(1)
Ext <- round(rnorm(500,runif(1,25,35),4,12)))
set.seed(2)
Con <- round(rnorm(500,12)))
set.seed(3)
Agr <- round(rnorm(500,12)))
set.seed(4)
Emo <- round(rnorm(500,12)))
set.seed(5)
Int <- round(rnorm(500,12)))
### Apps Atribut ========================================
header <- dashboardHeader(
title = "IPIP-BFM-50"
)
sidebar <- dashboardSidebar()
body <- dashboardBody(
fluidRow(
box(
textInput(
"unicode","Your Unique ID:",placeholder = "Input your unique ID here"
),actionButton(
"ab1_unicode","Submit"
),width = 6
),tags$head(tags$style(HTML(".small-box {height: 130px}"))),valueBoxOutput(
"vbox1_unicode",width = 6
)
),fluidRow(
tabBox(
title = "Dimensi Big-Five Marker",id = "tabset1",height = "500px",width = 12,tabPanel(
"Extraversion","This is Extraversion",highchartOutput(
"hist1"
)
),tabPanel(
"Conscientiousness","This is Conscientiousness",highchartOutput(
"hist2"
)
),tabPanel(
"Agreeableness","This is Agreeableness",highchartOutput(
"hist3"
)
),tabPanel(
"Emotional Stability","This is Emotional Stability",highchartOutput(
"hist4"
)
),tabPanel(
"Intelligent","This is Intelligent",highchartOutput(
"hist5"
)
)
)
),fluidRow(
box(
"Personality in a nutshell",br(),"Second row of personality explanation",verbatimTextOutput(
"tabset1selected"
),height = "250px"
)
)
)
### Atribut server
### Apps ================================================
ui <- dashboardPage(header,sidebar,body)
server <- function(input,output){
update_unicode <- eventReactive(input$ab1_unicode,{
input$unicode
},ignoreNULL = F)
output$vbox1_unicode <- renderValueBox({
valueBox(
update_unicode(),"Your Unique ID",icon = icon("fingerprint")
)
})
dimension <- function(dim){
if(dim == "Extraversion"){
Ext
} else if(dim == "Conscientiousness"){
Con
} else if(dim == "Agreeableness"){
Agr
} else if(dim == "Emotional Stability"){
Emo
} else if(dim == "Intelligent"){
Int
}
}
make_hc <- function(x,update_unicode) {
hchart(
dimension(x)
) %>%
hc_xAxis(
list(
title = list(
text = "Data"
),plotBands = list(
color = '#3ac9ad',from = update_unicode,to = update_unicode,label = list(
text = "Your Score",color = "#9e9e9e",align = ifelse(update_unicode>30,"right","left"),x = ifelse(update_unicode>30,-10,+10)
)
)
)
)
}
output$hist1 <- renderHighchart({
make_hc("Extraversion",update_unicode())
})
output$hist2 <- renderHighchart({
make_hc("Conscientiousness",update_unicode())
})
output$hist3 <- renderHighchart({
make_hc("Agreeableness",update_unicode())
})
output$hist4 <- renderHighchart({
make_hc("Emotional Stability",update_unicode())
})
output$hist5 <- renderHighchart({
make_hc("Intelligent",update_unicode())
})
output$tabset1selected <- renderText({
input$tabset1
})
}
shinyApp(ui = ui,server = server)
