drilldown-example.R

suppressPackageStartupMessages(library(highcharter))
suppressPackageStartupMessages(library(tidyverse))

dtrees <- tibble(
  tree = c("A", "B"),
  apples = c(5, 7),
  species = c("Fuji", "Gala"),
  trunk_size = c(30, 40)
  ) |> 
  # rowise is used to avoid vectorization in tags$td, ie, do it row by row
  rowwise() |> 
  mutate(
    tooltip_text = list(
      tags$table(
        tags$tr(tags$th("Tree"), tags$td(tree)),
        tags$tr(tags$th("# Apples"), tags$td(apples))
      )
    )
  ) |> 
  ungroup() |> 
  mutate(
    tooltip_text = map_chr(tooltip_text, as.character),
    # clean text
    tooltip_text = str_trim(str_squish(tooltip_text))
    )

dtrees$tooltip_text[[1]]

## [1] "<table> <tr> <th>Tree</th> <td>A</td> </tr> <tr> <th># Apples</th> <td>5</td> </tr> </table>"

dflowers <- tibble(
  tree = c(rep("A", 3), rep("B", 4)),
  rose = c("R1", "R2", "R3", "R4", "R5", "R6", "R7"),
  petals = c(10, 13, 15, 20, 24, 26, 27),
  color = c(
    "gray",
    "#FFB6C1",
    "#8B0000",
    "purple",
    "#FF10F0",
    "#ffffbf",
    "red"
  ),
  price = c(3, 2, 4, 3.5, 5, 2.5, 4.5)
  ) |>   
  rowwise() |> 
  mutate(
    tooltip_text = list(
      tags$table(
        tags$tr(tags$th("Flower"), tags$td(rose)),
        tags$tr(tags$th("# Petals"), tags$td(petals)),
        tags$tr(tags$th("Price"), tags$td(str_c("$ ", price)))
      )
    )  
  ) |> 
  ungroup() |> 
  mutate(
    tooltip_text = map_chr(tooltip_text, as.character),
    # clean text
    tooltip_text = str_trim(str_squish(tooltip_text))
  )

dflowers$tooltip_text[[1]]

## [1] "<table> <tr> <th>Flower</th> <td>R1</td> </tr> <tr> <th># Petals</th> <td>10</td> </tr> <tr> <th>Price</th> <td>$ 3</td> </tr> </table>"

dflowers_dd <- dflowers |>
  group_nest(id = tree) |>
  mutate(
    type = "column",
    data = map(data, mutate, name = rose, y = petals),
    data = map(data, list_parse),
    name = "Petals"
  )

hchart(
  dtrees,
  "column",
  hcaes(tree, apples, drilldown = tree),
  name = "Apples",
  colorByPoint = TRUE
) |>
  hc_drilldown(
    breadcrumbs = list(
      format = 'back to {level.name} series',
      # enabled = FALSE,
      showFullPath = FALSE
      ),
    allowPointDrilldown = TRUE,
    series = list_parse(dflowers_dd)
    ) |>
  hc_yAxis(title = list(text  = "")) |>
  hc_xAxis(title = list(text  = "")) |>
  hc_tooltip(
    headerFormat = "", # remove header
    pointFormat = "{point.tooltip_text}",
    useHTML = TRUE
    )