Highcharter - Click event to filter data from graph

Question

I am using highcharterand I want to be able to add a click event to my graph that when I click on a bar (whether its top level or drilldown), it filters the data table below it to contain the same information.

I've checked this SO question which shows how to implement the the Java to R to contain a click function but not how to use that information to filter data / choose the correct data set.

Hyperlink bar chart in Highcharter

Any help would be greatly appreciated! An example code is below:

library (shiny)
library (shinydashboard)
library (dplyr)
library (tibble)
library (highcharter)
library(shinyjs)
library (DT)

rm(list=ls())
header <- dashboardHeader()
sidebar <- dashboardSidebar()

body <- dashboardBody(
  fluidRow(
    box(
      tags$head(tags$style(HTML("#OnTime{height:25vh !important;} "))),
      title = "On Time", status = "primary", solidHeader = TRUE, width = 6,
      highchartOutput("OnTime")
    )
  ),
  fluidRow(
    box(
      title = "WIP Table", status = "primary", solidHeader = TRUE,
      DT::dataTableOutput("Table")
    )
  )
)

ui <- dashboardPage(header, sidebar, body)

server <- function(input, output) {

  Customer <- c("England", "France", "US", "Canada", "England", "France", "US", "Canada", "England")
  OnTime <- c("On Time", "On Time", "Overdue", "On Time", "Overdue", "On Time", "Overdue","On Time", "On Time")
  Gate <- c(1,2,3,2,3,2,1,2,3)
  Quantity <- c(1,1,1,1,1,1,1,1,1)

  data <- data.frame(Customer,OnTime,Gate, Quantity)

  output$OnTime <- renderHighchart({

    Lvl1GroupingStatus <- aggregate(data$Quantity, by = list(data$OnTime),FUN=sum)
    Lvl1dfStatus <- data_frame(name = Lvl1GroupingStatus$Group.1,y = Lvl1GroupingStatus$x,drilldown = tolower(name))

    Lvl2WIPOverDue <- data[data$OnTime == "Overdue",]
    Lvl2WIPOverDueb <- aggregate(Lvl2WIPOverDue$Quantity, by = list(Lvl2WIPOverDue$Customer),FUN=sum)
    Lvl2dfWIPOverDue <- arrange(data_frame(name = Lvl2WIPOverDueb$Group.1,value = Lvl2WIPOverDueb$x),desc(value))

    Lvl2WIPOnTime <- data[data$OnTime == "On Time",]
    Lvl2WIPOnTimeb <- aggregate(Lvl2WIPOnTime$Quantity, by = list(Lvl2WIPOnTime$Customer),FUN=sum)
    Lvl2dfWIPOnTime <- arrange(data_frame(name = Lvl2WIPOnTimeb$Group.1,value = Lvl2WIPOnTimeb$x),desc(value))

    highchart() %>%
      hc_chart(type = "column") %>%
      hc_xAxis(type = "category") %>%
      hc_legend(enabled = FALSE) %>%
      hc_yAxis(gridLineWidth = 0) %>%
      hc_plotOptions(series = list(column = list(stacking = "normal"), borderWidth=0,dataLabels = list(enabled = TRUE))) %>%
      hc_add_series(data=Lvl1dfStatus,name="Status", colorByPoint = TRUE,colors = c("#003395","#D20000")) %>%

      hc_drilldown(
        allowPointDrilldown = TRUE,
        series = list(
          list(id = "overdue", data = list_parse2(Lvl2dfWIPOverDue), name="Customer"),
          list(id = "on time", data = list_parse2(Lvl2dfWIPOnTime), name="Customer")

        )
      )
  })


  output$Table <- DT::renderDataTable({ data})

}

#Combines Dasboard and Data together
shinyApp(ui, server)

Answer 1

Solved it with the help of this SO post!

How to know information about the clicked bar in highchart column r shiny plot

Hope this helps other people!

library (shiny)
library (shinydashboard)
library (dplyr)
library (tibble)
library (highcharter)
library(shinyjs)
library (DT)

rm(list=ls())
header <- dashboardHeader()
sidebar <- dashboardSidebar()

body <- dashboardBody(
  fluidRow(
    box(
      tags$head(tags$style(HTML("#OnTime{height:20vh !important;} "))),
      title = "On Time", status = "primary", solidHeader = TRUE, width = 6,
      highchartOutput("OnTime")
    )
  ),
  fluidRow(
    box(
      title = "WIP Table", status = "primary", solidHeader = TRUE,
      DT::dataTableOutput("Table")
    )
  ),
  fluidRow(
    box(
      textOutput("text")
    )
  )
)

ui <- dashboardPage(header, sidebar, body)

server <- function(input, output) {

  Customer <- c("England", "France", "US", "Canada", "England", "France", "US", "Canada", "England")
  OnTime <- c("On Time", "On Time", "Overdue", "On Time", "Overdue", "On Time", "Overdue","On Time", "On Time")
  Gate <- c(1,2,3,2,3,2,1,2,3)
  Quantity <- c(1,1,1,1,1,1,1,1,1)

  data <- data.frame(Customer,OnTime,Gate, Quantity)

  output$OnTime <- renderHighchart({

    Lvl1GroupingStatus <- aggregate(data$Quantity, by = list(data$OnTime),FUN=sum)
    Lvl1dfStatus <- data_frame(name = Lvl1GroupingStatus$Group.1,y = Lvl1GroupingStatus$x,drilldown = tolower(name))

    Lvl2WIPOverDue <- data[data$OnTime == "Overdue",]
    Lvl2WIPOverDueb <- aggregate(Lvl2WIPOverDue$Quantity, by = list(Lvl2WIPOverDue$Customer),FUN=sum)
    Lvl2dfWIPOverDue <- arrange(data_frame(name = Lvl2WIPOverDueb$Group.1,value = Lvl2WIPOverDueb$x),desc(value))

    Lvl2WIPOnTime <- data[data$OnTime == "On Time",]
    Lvl2WIPOnTimeb <- aggregate(Lvl2WIPOnTime$Quantity, by = list(Lvl2WIPOnTime$Customer),FUN=sum)
    Lvl2dfWIPOnTime <- arrange(data_frame(name = Lvl2WIPOnTimeb$Group.1,value = Lvl2WIPOnTimeb$x),desc(value))

    ClickFunction <- JS("function(event) {Shiny.onInputChange('Clicked', event.point.name);}")

    highchart() %>%
      hc_chart(type = "column") %>%
      hc_xAxis(type = "category") %>%
      hc_legend(enabled = FALSE) %>%
      hc_yAxis(gridLineWidth = 0) %>%
      hc_plotOptions(series = list(column = list(stacking = "normal"), 
                                   borderWidth=0,
                                   dataLabels = list(enabled = TRUE),
                                   events = list(click = ClickFunction)
                                   )
                     ) %>%
      hc_add_series(data=Lvl1dfStatus,name="Status", colorByPoint = TRUE,colors = c("#003395","#D20000")) %>%

      hc_drilldown(
        allowPointDrilldown = TRUE,
        series = list(
          list(id = "overdue", data = list_parse2(Lvl2dfWIPOverDue), name="Customer"),
          list(id = "on time", data = list_parse2(Lvl2dfWIPOnTime), name="Customer")

        )
      )
  })

  makeReactiveBinding("outputText")

  observeEvent(input$Clicked, {
    outputText <<- paste0(input$Clicked)
    })

  output$text <- renderText({
    outputText
    })

  output$Table <- DT::renderDataTable({

    temp <- data
    rowcheck <- temp[temp$OnTime == input$Clicked,]

    if (nrow(rowcheck)!=0) {
      temp <- temp[temp$OnTime == input$Clicked,]
      Lvl1Click <<- input$Clicked
    }
    else {
      temp <- temp[temp$OnTime == Lvl1Click,]
      temp <- temp[temp$Customer == input$Clicked,]
    }

    return (temp)

    })
}

#Combines Dasboard and Data together
shinyApp(ui, server)