我想通过 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),runif(1,4,12)))
set.seed(2)
Con <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(3)
Agr <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(4)
Emo <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(5)
Int <- round(rnorm(500,runif(1,25,35),runif(1,4,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",
highchartOutput(
"hist"
)
),
tabPanel(
"Agreeableness",
"This is Agreeableness",
highchartOutput(
"hist"
)
),
tabPanel(
"Emotional Stability",
"This is Emotional Stability",
highchartOutput(
"hist"
)
),
tabPanel(
"Intelligent",
"This is Intelligent",
highchartOutput(
"hist"
)
)
)
),
fluidRow(
box(
"Personality in a nutshell", br(),
"Second row of personality explanation",
verbatimTextOutput(
"tabset1selected"
),
width = 12,
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)
问题:
我只制作了 1 个带有条件的直方图以节省效率。但看起来效果不佳。
请帮帮我
答案 0 :(得分: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())
})
id
的输出,这些输出可以放在 UI 的各个面板中。完整的可重现代码:
library(shiny)
library(shinydashboard)
library(highcharter)
### Data ================================================
set.seed(1)
Ext <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(2)
Con <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(3)
Agr <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(4)
Emo <- round(rnorm(500,runif(1,25,35),runif(1,4,12)))
set.seed(5)
Int <- round(rnorm(500,runif(1,25,35),runif(1,4,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"
),
width = 12,
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)