Search code examples
rr-highcharterdrilldown

How to toggle drilldown data (with a button)?


I'm trying to make an interactive data visualization in R. The user is presented with data on an aggregate level, and can then choose to disaggregate on two available variables (one at a time). In the example below, the population data is aggregated on continent. Then I drilldown by country.

library(highcharter)
library(dplyr)
library(purrr)

data <- data.frame(
  continent = rep(c("Asia", "Europe", "Africa"), each = 6),
  country = rep(c("AA", "AB", "AC", "BA", "BB", "BC", "CA", "CB", "CC"), each = 2),
  gender = rep(c('Men', 'Women'), each = 9),
  pop = c(2, 2, 2, 3, 4, 2, 1, 2, 3, 2, 1, 1, 0, 1, 4, 2, 5, 2)
)

column <- data %>% 
  group_by(continent) %>% summarise(pop = sum(pop)) 

drilldown_country <- data %>% 
  group_nest(continent) %>% 
  mutate(
    id = continent,
    type = "column",
    data = map(data, mutate, name = country, y  = pop),
    data = map(data, list_parse)
  )

hchart(
  column,
  "column",
  hcaes(x = continent, y = pop, name = continent, drilldown = continent),
  name = "Population",
  colorByPoint = TRUE
) |>
  hc_drilldown(
    allowPointDrilldown = TRUE,
    series = list_parse(drilldown_country)
  )

I hope it is possible to give the user the choice of whether to drill this data down by country or by gender. I imagine this could be something like a button where the user can choose 'Country' or 'Gender' and then afterwards clicking a continent bar and then the population for that continent is shown by country/gender. I am very open to solutions as long as there is one chart in which the user can choose how to do the drilldown. I have seen that hierarchical drilldowns are possible, what I am looking for might be called a parallel drilldown. I think the prerequisite for this lies in something like the code below, but I'm not sure how to use it.

drilldown_gender <- data %>% 
  group_nest(continent) %>% 
  mutate(
    id = continent,
    type = "column",
    data = map(data, mutate, name = gender, y  = pop),
    data = map(data, list_parse)
  )

I asked a similar question here where I tried to use plotly, but I think my chances are better with highcharter and that I represented my data better this time.


Solution

  • A possibility is that you pass the drilldown data for both variables binded, also containing an info column which is later used for filtering the data depending on the button choice:

    hc_drilldown(allowPointDrilldown = TRUE,
                 series = list_parse(rbind(drilldown_country, drilldown_gender)))
    
    > rbind(drilldown_country, drilldown_gender)
    # A tibble: 6 × 5
      continent data       id     type   info   
      <chr>     <list>     <chr>  <chr>  <chr>  
    1 Africa    <list [6]> Africa column country
    2 Asia      <list [6]> Asia   column country
    3 Europe    <list [6]> Europe column country
    4 Africa    <list [6]> Africa column gender 
    5 Asia      <list [6]> Asia   column gender 
    6 Europe    <list [6]> Europe column gender 
    

    Then we attach a load event to the chart which at first defines a variable which contains this data:

    hc_chart(events = list(
        load = JS(
          "function() {
              var chart = this;
              var drillDownData = chart.options.drilldown.series;
              
              ...
          "
    

    And then (details below) a button is defined which has an onclick event for toggling the drilldown variable and filtering the drilldown data.

    enter image description here

    library(highcharter)
    library(dplyr)
    library(purrr)
    
    data <- data.frame(
      continent = rep(c("Asia", "Europe", "Africa"), each = 6),
      country = rep(c(
        "AA", "AB", "AC", "BA", "BB", "BC", "CA", "CB", "CC"
      ), each = 2),
      gender = rep(c('Men', 'Women'), each = 9),
      pop = c(2, 2, 2, 3, 4, 2, 1, 2, 3, 2, 1, 1, 0, 1, 4, 2, 5, 2)
    )
    
    column <- data %>%
      group_by(continent) %>% summarise(pop = sum(pop))
    
    drilldown_country <- data %>%
      group_nest(continent) %>%
      mutate(
        id = continent,
        type = "column",
        data = map(data, mutate, name = country, y  = pop),
        data = map(data, list_parse),
        info = "country"
      )
    
    drilldown_gender <- data %>%
      group_nest(continent) %>%
      mutate(
        id = continent,
        type = "column",
        data = map(data, mutate, name = gender, y  = pop),
        data = map(data, list_parse),
        info = "gender"
      )
    
    hchart(
      column,
      "column",
      hcaes(
        x = continent,
        y = pop,
        name = continent,
        drilldown = continent
      ),
      name = "Population",
      colorByPoint = TRUE
    ) |>
      hc_drilldown(allowPointDrilldown = TRUE,
                   series = list_parse(rbind(drilldown_country, drilldown_gender))) |>
      hc_chart(events = list(
        load = JS(
          "function() {
              var chart = this;
              var drillDownData = chart.options.drilldown.series;
              
              chart.options.drilldown.series = drillDownData.filter(v => v.info === 'country');
              
              chart.drilldownTextInfo = chart.renderer.text(' ', 300, 25)
                                             .css({
                                                  'color': 'red'
                                              })
                                              .add();
    
              chart.renderer.button('Change drilldown variable', 75, 25)
                   .attr({
                        zIndex: 3
                   })
                   .on('click', function() {
                        var info = chart.options.drilldown.series[0].info
    
                        info = ((info == 'country') ? 'gender' : 'country');
    
                        chart.options.drilldown.series = drillDownData.filter(v => v.info === info);
                                  
                        chart.drilldownTextInfo.attr({
                            text: 'Current drilldown variable: ' + info
                        })
                   })
                   .add();
          }"
        )
      ))