R highcharter、valuebox、eventreactive 在 shiny 中不能一起工作

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)

問題：

• 價值盒消失
• 高圖沒有出現

我只制作了 1 個直方圖，其中包含保存效率的條件。 但看起來效果不佳。

這就是結果的樣子

請幫幫我

Answer 1

問題是 UI 中的id和服務器端的綁定必須是唯一的。 但是，在您的儀表板中， id="hist"在 UI 中多次出現，即您有一個重復的綁定。

這可以通過以下方式看到：1. 在瀏覽器中打開儀表板，2. 打開開發工具 3. 查看控制台 output，其中顯示 JS 錯誤消息“id hist 的重復綁定”。

不確定您的最終結果，但要解決此問題，您可以例如為每個面板添加一個highchartOutput 。 為此：

1. 我已將繪圖代碼放在單獨的 function make_hc
2. 為每個面板或數據集添加了一個highchartOutput ，例如

output$hist1 <- renderHighchart({ 
    make_hc("Extraversion", update_unicode()) 
})

3. 這樣我們就可以得到 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)