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

Question

I want to build an app by shinydashboard that work like this:

• textInput
• Submit actionbutton to update value box based in input text
• valuebox (to show input text)
• Tabbox with 5 tabpanel
• Each tabpanel has histogram with different data and rendered by Highcharter
• VerbatimTextOutput to indivate which tabpanel chosen

This is my code:

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)

Problems:

• valuebox dissapear
• highchart didn't appear

I made only 1 histogram with conditions to save the efeciency. but it looks didn't work well.

This is what the result looked like

Please help me guys

Answer 1

The issue is that the the binding between an id in the UI and on the server side has to be unique. However, in your dashboard the id="hist" appears more than once in the UI, i.e. you have a duplicated binding.

This could be seen by 1. opening the dashboard in the Browser, 2. opening the dev tools 3. having a look the console output which shows a JS error message "Duplicate binding for id hist".

Not sure about your final result but to solve this issue you could e.g. add one highchartOutput per panel. To this end:

1. I have put the plotting code in a separate function make_hc
2. Added an highchartOutput for each of your panels or datasets, e.g.

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

3. This way we get 5 outputs with unique ids which could be put inside the respective panels in the UI.

Full reproducible code:

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)