Choosing R Highcharter colours for each drilldown level graph in Rshiny

Question

I am creating a drill down in Rshiny similar to the solution in this question but I have 6 drill-down levels whereas the original question has 3 levels. Is there a way to specify the colours for each drill-down level? E.g. using the referenced question, I would be able to specify the colours for level 1 city, farm and ocean, level 2 bus and car, level 3 carl and newt etc (as seen in screenshots below). Is this possible?

Drilldown level 1

Select level 1 "City" resulting in level 2 bus and car

Select level 2 "Bus" resulting in Carl and Newt etc.

What I've tried:

......
highchart() %>%
      hc_xAxis(type = "category") %>%
      hc_add_series(tibbled, "column", hcaes(x = name, y = y), color = "#E4551F", "#4572A7", 
"#AA4643", "#89A54E", "#80699B", "#3D96AE") %>%
      hc_plotOptions(column = list(stacking = "normal", events = list(click = pointClickFunction)))

This didn't work, it just used the first hex code . Surely there has to be a way to say "for category city use colour "#4572A7" etc" ?? Please help

Answer 1

There are a few different ways you could do this. You didn't provide a reproducible question, so I've used the data gapminder.

The highest level is the average life expectancy by continent. The second level is the average by country. The third level is the life expectancy by country by year.

I used the highcharter function colorize to create color vectors. This is how I put it together:

The data

library(tidyverse)
library(highcharter)
data(gapminder, package = "gapminder")

avLE = gapminder %>% 
  group_by(continent) %>% 
  mutate(aLE = mean(lifeExp)) %>% # average by continent
  ungroup() %>% group_by(country) %>% 
  mutate(caLE = mean(lifeExp)) %>% # average by year
  ungroup() %>% arrange(desc(aLE)) %>% # order by life expectancy for continents
  mutate_if(is.numeric, round, 2)  # round to 2 decimals
summary(avLE) # check it; makes sense

gapCol = avLE %>%  # set the continets in the validated avLE as ordered
  group_by(continent) %>% 
  mutate(color = colorize(continent),
         continent = ordered(continent, 
                             levels = unique(avLE$continent)))
summary(gapCol) # check it; makes sense

The drill downs

# make the deepest level dropdown
gapDD2 = avLE %>% 
  arrange(year) %>%  
  group_nest(continent, country, caLE) %>% # keep these variables!
  mutate(id = country,
         type = "column", 
         data = map(data, mutate, name = year, y = lifeExp,
                    color = colorize(year)), # set the color (easier with #)
         data = map(data, list_parse))

gapDD1 = avLE %>% 
  arrange(country) %>%  # arrange by country, set as ordered, then find colors
  mutate(country = ordered(country, levels = unique(country))) %>%
  mutate(color = ordered(colorize(country),     # colors/countries align
                         levels = unique(colorize(country)))) %>% 
  group_nest(continent) %>% 
  mutate(id = continent,
         type = "column", 
         data = map(data, mutate, name = country, y = caLE, 
                    color = color,  # set the color (a few more steps than with #s)
                    drilldown = country),
         data = map(data, list_parse)) 

The chart

# take a look:
hchart(gapCol, "column", name = "Continental Averages",
       hcaes(x = continent, color = continent, y = aLE, 
             name = "continent", drilldown = "continent")) %>% 
  hc_drilldown(allowPointsDrillDown = T,
               series = c(list_parse(gapDD1), list_parse(gapDD2))) 

---

---

With Shiny

I've provided a really simple example of how to render this plot within a Shiny application. In this example, all of the code, except the call hchart, is called before the ui is set.

ui <- fluidPage(
  fluidRow(highchartOutput("myHC"))
)
server <- function(input, output, session){
  output$myHC <- renderHighchart({
    hchart(gapCol, "column", name = "Continental Averages",
           hcaes(x = continent, color = continent, y = aLE, 
                 name = "continent", drilldown = "continent")) %>% 
      hc_drilldown(allowPointsDrillDown = T,
                   series = c(list_parse(gapDD1), list_parse(gapDD2))) 
  })
}
shinyApp(ui = ui, server = server)

Let me know if you have any questions.