R Markdown

Sébastien Rochette presented at the SatRday Paris how to build interactive waffle plots. Here, I simply follow his instructions and replicate his tutorial.

library(raster)
library(rasterVis)
library(waffler)
library(cowplot)

Raster and multipolygon structure

# build a raster
mat <- matrix(c(1,0,0,1), ncol = 2)
r <- raster(mat)
plot(r)

# get centers
r_df <- data.frame(coordinates(r), values=values(r))

# transform as polygons
r_waffle <- wafflerize(r_df)

g1 <- gplot(r) +
  geom_raster(aes(fill = value)) +
  guides(fill = FALSE) +
  ggtitle("Original raster")

g2 <- ggplot(r_waffle) +
  geom_sf(aes(colour = LETTERS[1:nrow(r_waffle)]), size = 2) +
  guides(colour = FALSE) +
  ggtitle("Raster as polygon")

plot_grid(plotlist = list(g1, g2))

Heart-shaped waffle

library(sf)
# construct heart (code from @dmarcelinobr)
xhrt <- function(t) 16 * sin(t)^3
yhrt <- function(t) 13 * cos(t) - 5 * cos(2 * t) - 2 * cos(3 * t) - cos(4 * t)

#create heart as polygon
heart_sf <- tibble::tibble(t = seq(0, 2* pi, by = .1)) %>%
  dplyr::mutate(y = yhrt(t), x = xhrt(t)) %>% 
  dplyr::bind_rows(., head(., 1)) %>%
  dplyr::select(x, y) %>%
  as.matrix() %>%
  list() %>% 
  st_polygon() %>%
  st_sfc(crs = 2154)

g1 <- ggplot(heart_sf) +
  geom_sf(fill = "#cb181d") +
  coord_sf(crs = 2154, datum = 2154) +
  ggtitle("Heart sf polygon")

heart_grid <- st_sample(heart_sf, size = 500, type = "regular") %>%
  cbind(as.data.frame(st_coordinates(.))) %>%
  rename(x = X, y = Y) %>%
  st_sf() %>%
  mutate(z = cos(2*x) - cos(x) + sin(y), z_text = paste("Info: ", round(z)))

g2 <- ggplot(heart_grid) +
  geom_sf(colour="#cb181d") +
  coord_sf(crs=2154, datum=2154) +
  ggtitle("Heart as regular point grid")

g3 <- ggplot(heart_grid) + 
  geom_sf(aes(colour = z, size=2)) + 
  scale_colour_distiller(palette= "YlOrBr", type="seq", direction=1) +
  theme(panel.background = element_rect(fill = "#000000")) +
  coord_sf(crs=2154, datum = 2154) +
  guides(colour= FALSE) +
  ggtitle("Chocolate quantity for each point")

cowplot::plot_grid(g1, g2, g3, ncol=3)

Heart-shape waffle with waffler

library(waffler)
# generate a grid polygon from points
heart_polygon <- wafflerize(heart_grid, fact = 1000000)

g1 <- ggplot(heart_polygon) +
  geom_sf(aes(fill = z), colour="blue", size=0.5) +
  scale_fill_distiller(palette = "YlOrBR", type="seq", direction = 1) +
  theme(panel.background=element_rect(fill="#000000")) +
  coord_sf(crs=4326, datum=4326) +
  guides(fill=FALSE) +
  ggtitle("Chocolate quantity (geographical coordinates = data)")

g2 <- ggplot(heart_polygon) +
  geom_sf(aes(fill=z), colour = "blue", size=0.5) +
  scale_fill_distiller(palette="YlOrBr", type="seq", direction = 1) +
  theme(panel.background = element_rect(fill = "#000000")) +
  coord_sf(crs=3857, datum=3857) +
  guides(fill=FALSE) +
  ggtitle("Chocolate quantity (Mercator projection = leaflet)")

plot_grid(plotlist = list(g1,g2), ncol=2)

Interactive waffle plot

library(leaflet)
library(leafgl)
# bigger heart

heart_grid <- st_sample(heart_sf, size=50000, type = "regular") %>%
  cbind(as.data.frame(st_coordinates(.))) %>%
  rename(x=X, y=Y) %>%
  st_sf() %>%
  dplyr::mutate(z=cos(2*x) - cos(x) + sin(y), z_text=as.character(round(z, digits=1)))

# generate a grid polygon from points
heart_polygon2 <- wafflerize(heart_grid, fact=100)

# Define colors for `addGlPolygons`
cols <- scales::brewer_pal(palette = "YlOrBr", type = "seq")(7)
colours <- scales::gradient_n_pal(cols)(scales::rescale(heart_polygon$z))
colours_rgb <- (t(col2rgb(colours, alpha = FALSE))/255) %>% as.data.frame()

# Render as leaflet
m <- leaflet() %>%
  addGlPolygons(data = heart_polygon,
                color = colours_rgb,
                popup = "z_text",
                opacity = 1) %>%
  setView(lng = mean(st_bbox(heart_polygon)[c(1,3)]),
          lat = mean(st_bbox(heart_polygon)[c(2,4)]), zoom = 10)

# m # did not take too much time to figure out why I cannot display m. It halts the rendering when executed