Session 3: Creating interactive graphics, with linking between plots

H. Sherry Zhang and Prof. Di Cook

2022-12-06

Goal of session 3

Interaction 1: Click on a point on the map

It will show the station name in the tooltip.

Interaction 2: Select a point on the time series

It will link to the station on the map and you can then hover to see the station.

Interaction 3: Click the button on the map to activate area selection

Use the four corners and to adjust the size and position of the selection.

Roadmap

Data to start with

Code 
# | output-location: column
(clean <- cubble::climate_subset |>
  face_temporal() |>
  mutate(month = lubridate::month(date, label = TRUE, abbr = TRUE)) |>
  group_by(month) |>
  summarise(
    tmax = mean(tmax, na.rm = TRUE),
    tmin = mean(tmin, na.rm = TRUE),
    diff = mean(tmax - tmin, na.rm = TRUE)
    ) |>
  face_spatial() |>
  mutate(temp_diff_var = var(ts$diff, na.rm = TRUE)))
# cubble:   id [30]: nested form
# bbox:     [114.09, -41.88, 152.87, -11.65]
# temporal: month [ord], tmax [dbl], tmin [dbl], diff [dbl]
   id            lat  long  elev name              wmo_id ts               
   <chr>       <dbl> <dbl> <dbl> <chr>              <dbl> <list>           
 1 ASN00003057 -16.5  123.   7   cygnet bay         94201 <tibble [12 × 4]>
 2 ASN00005007 -22.2  114.   5   learmonth airport  94302 <tibble [12 × 4]>
 3 ASN00005084 -21.5  115.   5   thevenard island   94303 <tibble [12 × 4]>
 4 ASN00010515 -32.1  117. 199   beverley           95615 <tibble [12 × 4]>
 5 ASN00012314 -27.8  121. 497   leinster aero      95448 <tibble [12 × 4]>
 6 ASN00014401 -11.7  133.  19.2 warruwi            94139 <tibble [12 × 4]>
 7 ASN00014703 -15.7  137.  12.2 centre island      94248 <tibble [12 × 4]>
 8 ASN00017123 -28.1  140.  37.8 moomba airport     95481 <tibble [12 × 4]>
 9 ASN00018201 -32.5  138.  14   port augusta aero  95666 <tibble [12 × 4]>
10 ASN00022841 -35.7  138.   5   kingscote aero     95807 <tibble [12 × 4]>
   temp_diff_var
           <dbl>
 1         8.27 
 2         1.80 
 3         0.389
 4         5.08 
 5         0.868
 6         0.662
 7         0.314
 8         1.36 
 9         2.56 
10         3.72 
# … with 20 more rows

Linking with crosstalk

nested <- clean %>% 
  SharedData$new(~id, group = "cubble")

(long <- clean |>
  face_temporal() |>
  unfold(temp_diff_var) |>
  SharedData$new(~id, group = "cubble"))
<SharedData>
  Public:
    clearSelection: function (ownerId = "") 
    clone: function (deep = FALSE) 
    data: function (withSelection = FALSE, withFilter = TRUE, withKey = FALSE) 
    groupName: function () 
    initialize: function (data, key = NULL, group = createUniqueId(4, prefix = "SharedData")) 
    key: function () 
    origData: function () 
    selection: function (value, ownerId = "") 
  Private:
    .data: cubble_df, grouped_df, tbl_df, tbl, data.frame
    .filterCV: ClientValue, R6
    .group: cubble
    .key: formula
    .rv: reactivevalues
    .selectionCV: ClientValue, R6
    .updateSelection: function (value)

Map with leaflet

leaflet(nested, 
        width = 500, height = 500) |>
  addTiles() |>
  addCircleMarkers()

Adding color and more aesthetics

domain <- clean$temp_diff_var
pal <- colorNumeric(
  colorspace::sequential_hcl(
    "Rocket",  n = 7, cmax = 90, 
    rev = TRUE, c2 = 40, l2= 85,
    c1 = 20, l1 = 30
    ),
  domain = domain)

(map <- leaflet(nested, 
        width = 500, height = 500) |> 
  addTiles() |> 
  addCircleMarkers(
    color = ~pal(domain), 
    radius = 0.8,
    popup = ~name, 
    fillOpacity = 1, opacity = 1))

Make temp. ribbons with ggplot

Code 
(ts_static <- long %>% 
  ggplot(aes(x = month, group = id,
         fill = temp_diff_var, color = temp_diff_var
         )) +
  geom_ribbon(aes(ymin = tmin, ymax = tmax), size = 0.1, alpha = 0.3) +
  geom_point(aes(y = tmax), size = 0.1) +
  geom_point(aes(y = tmin), size = 0.1) +
  colorspace::scale_fill_continuous_sequential(
    "Rocket",  n_interp = 7, cmax = 90, rev = TRUE,
    c2 = 40, l2= 85, c1 = 20, l1 = 30, name = "Var. temp. diff.") +
  colorspace::scale_colour_continuous_sequential(
    "Rocket",  n_interp = 7, cmax = 90, rev = TRUE,
    c2 = 40, l2= 85, c1 = 20, l1 = 30, name = "Var. temp. diff.") +
  labs(x = "Month", y = "Temperature") +
  theme_bw() +
  theme(
    panel.grid.major = element_blank(),
    legend.position = "bottom"
    ))

Make it interactive

(ts_interactive <- ggplotly(ts_static) %>% 
    highlight(on = "plotly_selected", opacityDim = 0.012))

Assemble map and temp. bands into a linked plot

bscols(map, ts_interactive, widths = c(4, 6))
Code 
clean <- climate_aus |>
  filter(name == "melbourne airport") |>
  bind_rows(climate_subset)  |>
  face_temporal() |>
  mutate(month = lubridate::month(date, label = TRUE, abbr = TRUE)) |>
  group_by(month) |>
  summarise(
    tmax = mean(tmax, na.rm = TRUE),
    tmin = mean(tmin, na.rm = TRUE),
    diff = mean(tmax - tmin, na.rm = TRUE)
    ) |>
  face_spatial() |>
  mutate(temp_diff_var = var(ts$diff, na.rm = TRUE))

nested <- clean %>% SharedData$new(~id, group = "cubble")
long <- clean |>
  face_temporal() |>
  unfold(temp_diff_var) |>
  arrange(temp_diff_var) |>
  SharedData$new(~id, group = "cubble")

domain <- clean$temp_diff_var
pal <- colorNumeric(
  colorspace::sequential_hcl(
    "Rocket",  n = 7, cmax = 90, rev = TRUE, c2 = 40, l2= 85, c1 = 20, l1 = 30),
  domain = domain)

map <- leaflet(nested, width = 300, height = 300) |>
  addTiles() |>
  addCircleMarkers(color = ~pal(domain), group = "a", radius = 0.1,
                   popup = ~name, fillOpacity = 1, opacity = 1)

ts_static <- long |> 
  ggplot(aes(x = month, group = id,
         fill = temp_diff_var, color = temp_diff_var
         )) +
  geom_ribbon(aes(ymin = tmin, ymax = tmax), size = 0.1, alpha = 0.3) +
  geom_point(aes(y = tmax), size = 0.1) +
  geom_point(aes(y = tmin), size = 0.1) +
  colorspace::scale_fill_continuous_sequential(
    "Rocket",  n_interp = 7, cmax = 90, rev = TRUE,
    c2 = 40, l2= 85, c1 = 20, l1 = 30, name = "Var. temp. diff.") +
  colorspace::scale_colour_continuous_sequential(
    "Rocket",  n_interp = 7, cmax = 90, rev = TRUE,
    c2 = 40, l2= 85, c1 = 20, l1 = 30, name = "Var. temp. diff.") +
  labs(x = "Month", y = "Temperature") +
  theme_bw() +
  theme(
    panel.grid.major = element_blank(),
    legend.position = "bottom"
    )
ts_interactive <- ggplotly(ts_static, width = 600, height =300) |>
    highlight(on = "plotly_selected", opacityDim = 0.012)
bscols(map, ts_interactive, widths = c(4, 6))

Save your interactive graphic

  • save the full interactivity (html):

    • htmltools::save_html(file = ...)

  • save as a static image (png):

    • Viewer > Export > Save as Image
    • webshot::webshot(url = ..., file = ...). You will need first to install phantomjs with webshot::install_phantomjs()

Your time 🔧

  • Create two linked new SharedData instances with SharedData$new(..., group = "...")

  • Create a leaflet map with color on circles

  • Create a ggplot of the temperature bands and turn it into interactive with ggplotly()

  • Link the leaflet map with the ggplotly time series together via crosstalk bscols()

Meet me tomorrow in the WOMBAT!

Further reading

Acknowledgements

  • The slides are made with Quarto