R Shiny, how to use highcharts drilldown in shinyapp depending on selectinput widget result?

[ABIS]

I am trying to create a drill down chart using highcharts package, the chart must be dependent on the selectinput results.

The current error is
Error in .getReactiveEnvironment()$currentContext() :
Operation not allowed without an active reactive context. (You tried to do something that can only be done from inside a reactive expression or observer.)

the expected or desired output is to get dynamic plot depending on the selected value.

library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)

x <- c("Farm","Farm","Farm","City","City","City","Ocean","Ocean")
y <- c("Sheep","Sheep","Cow","Car","Bus","Bus","Boat","Boat")
z <- c("Bill","Tracy","Sandy","Bob","Carl","Newt","Fig","Tony")
a <- c(1,1,1,1,1,1,1,1)
b <- c(3,2,5,1,3,5,1,5)
c <- c(4,6,7,7,4,2,1,6)

header <- dashboardHeader()
body <- dashboardBody(
selectInput("selectid","Select a Measurement",choices=c("a","b","c"),selected = "a"),
highchartOutput("Working"))
sidebar <- dashboardSidebar()
ui <- dashboardPage(header, sidebar, body)

server <- function(input, output, session) {
zzz<-reactive({
    select(xxxx,x,y,z,input$selectid)})
print(zzz())
output$Working <- renderHighchart({
    # Make the initial data.
    summarized <- zzz() %>%
        group_by(x) %>%
        summarize(Quantity = sum(input$selectid))
    
    summarized <- arrange(summarized, desc(Quantity))
    tibbled <- tibble(name = summarized$x, y = summarized$Quantity)
    
    # This time, click handler is needed.
    drilldownHandler <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.drilldown);}")
    
    installDrilldownReceiver <- JS("function() {
  var chart = this;
  Shiny.addCustomMessageHandler('drilldown', function(message) {
    var point = chart.get(message.point)
    chart.addSeriesAsDrilldown(point, message.series);
  });
}")
    
    highchart() %>%
        hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
        hc_xAxis(type = "category") %>%
        hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#E4551F") %>%
        hc_plotOptions(column = list(stacking = "normal")) %>%
        hc_drilldown(allowPointDrilldown = TRUE)
})

observeEvent(input$ClickedInput, {
    levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
    resemblences <- c("x", "y", "z")
    dataSubSet <- reactive({
        #browser()
        zzz()
    })
    for (i in 1:length(levels)) {
        dataSubSet() <- zzz()[zzz()[[resemblences[i]]] == levels[i],]
    }
    
    normalized <- data.frame(category = dataSubSet()[[resemblences[length(levels) + 1]]], amount = input$selectid)
    
    summarized <- normalized %>%
        group_by(category) %>%
        summarize(Quantity = sum(amount))
    
    summarized <- arrange(summarized, desc(Quantity))
    
    tibbled <- tibble(name = summarized$category, y = summarized$Quantity)
    
    nextLevelCodes = lapply(tibbled$name, function(fac) {
        paste(c(levels, as.character(fac)), collapse = "_")
    }) %>% unlist
    
    tibbled$id = nextLevelCodes
    
    if (length(levels) < length(resemblences) - 1) {
        tibbled$drilldown = nextLevelCodes
    }
    
    session$sendCustomMessage("drilldown", list(
        series = list(
            type = "column",
            name = paste(levels, sep = "_"),
            data = list_parse(tibbled)
        ),
        point = input$ClickedInput
    ))
})

output$trial <- renderText({input$ClickedInput})
}
shinyApp(ui, server)

[raytong]

Hi @ABIS. Your error is about the print(zzz()) because cannot evaluate reactive expression outsider observer function. Besides of this problem, your code still cannot run because your code have error that directly using input character selectid in select and summarize function. I also modified that. Hope this can help.

library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)

x <- c("Farm","Farm","Farm","City","City","City","Ocean","Ocean")
y <- c("Sheep","Sheep","Cow","Car","Bus","Bus","Boat","Boat")
z <- c("Bill","Tracy","Sandy","Bob","Carl","Newt","Fig","Tony")
a <- c(1,1,1,1,1,1,1,1)
b <- c(3,2,5,1,3,5,1,5)
c <- c(4,6,7,7,4,2,1,6)

xxxx <- data.frame(x, y, z, a, b, c, stringsAsFactors = FALSE)

header <- dashboardHeader()
body <- dashboardBody(
  selectInput("selectid","Select a Measurement",choices=c("a","b","c"),selected = "a"),
  highchartOutput("Working"))
sidebar <- dashboardSidebar()
ui <- dashboardPage(header, sidebar, body)

server <- function(input, output, session) {
  zzz<-reactive({
    select(xxxx,one_of(c("x", "y", "z", input$selectid)))})

  output$Working <- renderHighchart({
    # Make the initial data.
    summarized <- zzz() %>%
      group_by(x) %>%
      summarize(Quantity = sum(!!sym(input$selectid)))

    summarized <- arrange(summarized, desc(Quantity))
    tibbled <- tibble(name = summarized$x, y = summarized$Quantity)
    
    # This time, click handler is needed.
    drilldownHandler <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.drilldown);}")
    
    installDrilldownReceiver <- JS("function() {
                                   var chart = this;
                                   Shiny.addCustomMessageHandler('drilldown', function(message) {
                                   var point = chart.get(message.point)
                                   chart.addSeriesAsDrilldown(point, message.series);
                                   });
  }")
    
    highchart() %>%
      hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
      hc_xAxis(type = "category") %>%
      hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#E4551F") %>%
      hc_plotOptions(column = list(stacking = "normal")) %>%
      hc_drilldown(allowPointDrilldown = TRUE)
})
  
  observeEvent(input$ClickedInput, {
    levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
    resemblences <- c("x", "y", "z")
    dataSubSet <- reactive({
      #browser()
      zzz()
    })
    for (i in 1:length(levels)) {
      dataSubSet() <- zzz()[zzz()[[resemblences[i]]] == levels[i],]
    }
    
    normalized <- data.frame(category = dataSubSet()[[resemblences[length(levels) + 1]]], amount = input$selectid)
    
    summarized <- normalized %>%
      group_by(category) %>%
      summarize(Quantity = sum(amount))
    
    summarized <- arrange(summarized, desc(Quantity))
    
    tibbled <- tibble(name = summarized$category, y = summarized$Quantity)
    
    nextLevelCodes = lapply(tibbled$name, function(fac) {
      paste(c(levels, as.character(fac)), collapse = "_")
    }) %>% unlist
    
    tibbled$id = nextLevelCodes
    
    if (length(levels) < length(resemblences) - 1) {
      tibbled$drilldown = nextLevelCodes
    }
    
    session$sendCustomMessage("drilldown", list(
      series = list(
        type = "column",
        name = paste(levels, sep = "_"),
        data = list_parse(tibbled)
      ),
      point = input$ClickedInput
    ))
  })
  
  output$trial <- renderText({input$ClickedInput})
  }
shinyApp(ui, server)

[ABIS]

Thank you @raytong for your response, your solution soleved the part of the problem but it's not working when I m trying to drill down, how can we fix this?

[raytong]

@ABIS. From your code, it cannot get what you want to chart to drill down. Can you explain clear about it.

[ABIS]

thank you again @raytong, my request simply is to enable the user to drilldown on the plot but the plot measurement is based on the select input, your solution managed to change the plot automatically but to drill down on after each change on the selectinput, still unsolved.
here is an example without the selectinput try it yourself and drill down on each column

 library (shinyjs)
 library (tidyr)
 library (data.table)
 library (highcharter)
 library (dplyr)
 library (shinydashboard)
 library (shiny)

 x <- c("Farm","Farm","Farm","City","City","City","Ocean","Ocean")
 y <- c("Sheep","Sheep","Cow","Car","Bus","Bus","Boat","Boat")
 z <- c("Bill","Tracy","Sandy","Bob","Carl","Newt","Fig","Tony")
 a <- c(1,1,1,1,1,1,1,1)

 dat <- data.frame(x,y,z,a)

 header <- dashboardHeader()
 body <- dashboardBody(
   highchartOutput("Working")
   )
 sidebar <- dashboardSidebar()
 ui <- dashboardPage(header, sidebar, body)

 server <- function(input, output, session) {
   output$Working <- renderHighchart({
     # Make the initial data.
     summarized <- dat %>%
       group_by(x) %>%
       summarize(Quantity = sum(a))

     summarized <- arrange(summarized, desc(Quantity))
     tibbled <- tibble(name = summarized$x, y = summarized$Quantity)

     # This time, click handler is needed.
     drilldownHandler <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.drilldown);}")

 # Also a message receiver for later async drilldown data has to be set.
 # Note in the JS: message.point is going to be the point ID. Highcharts addSeriesAsDrilldown need a point to attach
     #   the drilldown series to. This is retrieved via chart.get which takes the ID of any Highcharts Element.
     #   This means: IDs are kind of important here, so keep track of what you assign.
 installDrilldownReceiver <- JS("function() {
  var chart = this;
  Shiny.addCustomMessageHandler('drilldown', function(message) {
    var point = chart.get(message.point)
    chart.addSeriesAsDrilldown(point, message.series);
   });
   }")

 highchart() %>%
  # Both events are on the chart layer, not by series. 
  hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
  hc_xAxis(type = "category") %>%
  # Note: We add a drilldown directive (= name) to tell Highcharts that this has a drilldown functionality.
  hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#E4551F") %>%
  hc_plotOptions(column = list(stacking = "normal")) %>%
  hc_drilldown(allowPointDrilldown = TRUE)
   })

  # Drilldown handler to calculate the correct drilldown
 observeEvent(input$ClickedInput, {
 # We will code the drill levels to be i.e. Farm_Car. By that we calculate the next Sub-Chart.
 levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
 # This is just for generalizing this function to work in all the levels and even be expandable to further more levels.
 resemblences <- c("x", "y", "z")

 dataSubSet <- dat

  # We subsequently narrow down the original dataset by walking through the drilled levels
for (i in 1:length(levels)) {
  dataSubSet <- dat[dat[[resemblences[i]]] == levels[i],]
}

# Create a common data.frame for all level names.
normalized <- data.frame(category = dataSubSet[[resemblences[length(levels) + 1]]], amount = dataSubSet$a)

 summarized <- normalized %>%
  group_by(category) %>%
  summarize(Quantity = sum(amount))

summarized <- arrange(summarized, desc(Quantity))

tibbled <- tibble(name = summarized$category, y = summarized$Quantity)

 # Preparing the names and drilldown directives for the next level below.
# If already in "Farm_Car", the name for column "Bob" will be "Farm_Car_Bob"
 nextLevelCodes = lapply(tibbled$name, function(fac) {
  paste(c(levels, as.character(fac)), collapse = "_")
 }) %>% unlist

tibbled$id = nextLevelCodes

 # This is dynamic handling for when there is no further drilldown possible.
 # If no "drilldown" property is set in the data object, Highcharts will not let further drilldowns be triggered.
 if (length(levels) < length(resemblences) - 1) {
  tibbled$drilldown = nextLevelCodes
}

# Sending data to the installed Drilldown Data listener.
session$sendCustomMessage("drilldown", list(
  series = list(
    type = "column",
    name = paste(levels, sep = "_"),
    data = list_parse(tibbled)
  ),
  # Here, point is, as mentioned above, the ID of the point that triggered the drilldown.
  point = input$ClickedInput
  ))
 })

 output$trial <- renderText({input$ClickedInput})
 }
shinyApp(ui, server)

so all I need is to add two new variables "b" & "c" , then create select input to select a, b or c -as you already did, then change the plot accordingly.

thanks again dear

[raytong]

@ABIS. Let try this code.

library (shinyjs)
library (tidyr)
library (data.table)
library (highcharter)
library (dplyr)
library (shinydashboard)
library (shiny)

x <- c("Farm","Farm","Farm","City","City","City","Ocean","Ocean")
y <- c("Sheep","Sheep","Cow","Car","Bus","Bus","Boat","Boat")
z <- c("Bill","Tracy","Sandy","Bob","Carl","Newt","Fig","Tony")
a <- c(1,1,1,1,1,1,1,1)
b <- c(3,2,5,1,3,5,1,5)
c <- c(4,6,7,7,4,2,1,6)

dat <- data.frame(x,y,z,a,b,c)

header <- dashboardHeader()
body <- dashboardBody(
  selectInput("selectid","Select a Measurement",choices=c("a","b","c"),selected = "a"),
  highchartOutput("Working"))
sidebar <- dashboardSidebar()
ui <- dashboardPage(header, sidebar, body)

server <- function(input, output, session) {
  output$Working <- renderHighchart({
    # Make the initial data.
    summarized <- dat %>%
      group_by(x) %>%
      summarize(Quantity = sum(!!sym(input$selectid)))
    
    summarized <- arrange(summarized, desc(Quantity))
    tibbled <- tibble(name = summarized$x, y = summarized$Quantity)
    
    # This time, click handler is needed.
    drilldownHandler <- JS("function(event) {Shiny.onInputChange('ClickedInput', event.point.drilldown);}")
    
    # Also a message receiver for later async drilldown data has to be set.
    # Note in the JS: message.point is going to be the point ID. Highcharts addSeriesAsDrilldown need a point to attach
    #   the drilldown series to. This is retrieved via chart.get which takes the ID of any Highcharts Element.
    #   This means: IDs are kind of important here, so keep track of what you assign.
    installDrilldownReceiver <- JS("function() {
                                   var chart = this;
                                   Shiny.addCustomMessageHandler('drilldown', function(message) {
                                   var point = chart.get(message.point)
                                   chart.addSeriesAsDrilldown(point, message.series);
                                   });
  }")

    highchart() %>%
      # Both events are on the chart layer, not by series. 
      hc_chart(events = list(load = installDrilldownReceiver, drilldown = drilldownHandler)) %>%
      hc_xAxis(type = "category") %>%
      # Note: We add a drilldown directive (= name) to tell Highcharts that this has a drilldown functionality.
      hc_add_series(tibbled, "column", hcaes(x = name, y = y, drilldown = name, id = name), color = "#E4551F") %>%
      hc_plotOptions(column = list(stacking = "normal")) %>%
      hc_drilldown(allowPointDrilldown = TRUE)
})
  
  # Drilldown handler to calculate the correct drilldown
  observeEvent(input$ClickedInput, {
    # We will code the drill levels to be i.e. Farm_Car. By that we calculate the next Sub-Chart.
    levels <- strsplit(input$ClickedInput, "_", fixed = TRUE)[[1]]
    # This is just for generalizing this function to work in all the levels and even be expandable to further more levels.
    resemblences <- c("x", "y", "z")
    
    dataSubSet <- dat
    
    # We subsequently narrow down the original dataset by walking through the drilled levels
    for (i in 1:length(levels)) {
      dataSubSet <- dat[dat[[resemblences[i]]] == levels[i],]
    }
    
    # Create a common data.frame for all level names.
    normalized <- data.frame(category = dataSubSet[[resemblences[length(levels) + 1]]], amount = dataSubSet[, input$selectid])
    
    summarized <- normalized %>%
      group_by(category) %>%
      summarize(Quantity = sum(amount))
    
    summarized <- arrange(summarized, desc(Quantity))
    
    tibbled <- tibble(name = summarized$category, y = summarized$Quantity)
    
    # Preparing the names and drilldown directives for the next level below.
    # If already in "Farm_Car", the name for column "Bob" will be "Farm_Car_Bob"
    nextLevelCodes = lapply(tibbled$name, function(fac) {
      paste(c(levels, as.character(fac)), collapse = "_")
    }) %>% unlist
    
    tibbled$id = nextLevelCodes
    
    # This is dynamic handling for when there is no further drilldown possible.
    # If no "drilldown" property is set in the data object, Highcharts will not let further drilldowns be triggered.
    if (length(levels) < length(resemblences) - 1) {
      tibbled$drilldown = nextLevelCodes
    }
    
    # Sending data to the installed Drilldown Data listener.
    session$sendCustomMessage("drilldown", list(
      series = list(
        type = "column",
        name = paste(levels, sep = "_"),
        data = list_parse(tibbled)
      ),
      # Here, point is, as mentioned above, the ID of the point that triggered the drilldown.
      point = input$ClickedInput
    ))
  })
  
  output$trial <- renderText({input$ClickedInput})
  }
shinyApp(ui, server)

[ABIS]

Thank you for all these efforts @raytong, the solution is working perfect with the data frame, but once uploading the excel file the R studio can't execute the 'amount function' , you can try with this spreadsheet which contains exactly the same data

Regards,

[raytong]

@ABIS. What function you use to import the excel file?

[ABIS]

here is the error message
"Warning: Error in : object 'amount' not found"
just after removing this part

 x <- c("Farm","Farm","Farm","City","City","City","Ocean","Ocean")
 y <- c("Sheep","Sheep","Cow","Car","Bus","Bus","Boat","Boat")
 z <- c("Bill","Tracy","Sandy","Bob","Carl","Newt","Fig","Tony")
 a <- c(1,1,1,1,1,1,1,1)
 b <- c(3,2,5,1,3,5,1,5)
 c <- c(4,6,7,7,4,2,1,6)

 dat <- data.frame(x,y,z,a,b,c)

and replacing with this spreadsheet contains the same data

[ABIS]

[raytong]

I mean how you import the excel file? Using read_xls?

[ABIS]

Imported to my global environment

[raytong]

Show the structure of the data frame by str(dat) see if any problem of the data frame.

[ABIS]

@raytong

str(dat)

I cant figure out the problem.
here is the output

A tibble: 3 x 6

x y z a b c

1 Farm Sheep Bill 1 3 4
2 Farm Sheep Tracy 1 2 6
3 Farm Cow Sandy 1 5 7
Classes ‘tbl_df’, ‘tbl’ and 'data.frame': 3 obs. of 6 variables:
x: chr "Farm" "Farm" "Farm" y: chr "Sheep" "Sheep" "Cow"
z: chr "Bill" "Tracy" "Sandy" a: num 1 1 1
b: num 3 2 5 c: num 4 6 7
category b
1 Sheep 3
2 Sheep 2
3 Cow 5
'data.frame': 3 obs. of 2 variables:
category: Factor w/ 2 levels "Cow","Sheep": 2 2 1 b : num 3 2 5
Warning: Error in amount: could not find function "amount"
83: summarise_impl
82: summarise.tbl_df
80: function_list[[k]]
78: freduce
77: _fseq
76: eval
75: eval
73: %>%
72: observeEventHandler [/cloud/project/TABLEDRILLDOWN/app.R#72]
1: runApp

[ABIS]

solved
thanks @raytong for being that patient with me
have a great day