R highcharter、valuebox、eventreactive 不能一起工作

Question

我想通过 shinydashboard 构建一个像这样工作的应用程序：

textInput
提交 actionbutton 以根据输入文本更新值框
valuebox（显示输入文本）
Tabbox 和 5 tabpanel
每个 tabpanel 都有不同数据的直方图并由 Highcharter 渲染
VerbatimTextOutput 指示选择了哪个标签面板

这是我的代码：

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)

问题：

值框消失
highchart 没有出现

为了节省效率，我只制作了一张有条件的直方图。但看起来效果不佳。

结果是这样的

请大家帮帮我

Answer 1

问题是 UI 中的 id 与服务器端的绑定必须是唯一的。但是，在您的仪表板中，id="hist" 在 UI 中出现不止一次，即您有重复的绑定。

这可以通过 1. 在浏览器中打开仪表板，2. 打开开发工具 3. 查看控制台输出，其中显示 JS 错误消息“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),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)

R highcharter、valuebox、eventreactive 不能一起工作

R highcharter, valuebox, eventreactive didn't work together in shiny

r

highcharts

shiny

shinydashboard