Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.
I recently published a bit of self-promotion in the form of an animation based
on the new geom_voronoi_tile() and geom_voronoi_segment() functions in
ggforce:
Selfpromoting fun with geom_voronoi_* in #ggforce #ggplot2 #tweenr pic.twitter.com/CcFCJ8UDyy
— Thomas Lin Pedersen (@thomasp85) December 16, 2016
This prompted someone to ask for the source code and I off-handedly said I would
make a blog post about. So here we are, but I’m not going to show you how I made
that animation (sorry). Instead I’m going to show you how to make your very own
animated Christmas card using ggplot2, ggforce, and tweenr (as well as
mgcv and deldir for some computations).
Let’s set the scene: we are going to do a cyclic animation switching between a heart, the word “merry”, and the word “x-mas”. Each shape will be made up of voronoi tiles with the colour of the tile defining the shape. The shapes has been created in Illustrator and exported to a json representation using a script.
Let’s start by importing the shapes and do a sanity check:
library(jsonlite)
library(ggplot2)
greet <- fromJSON(readLines('http://www.data-imaginist.com/assets/data/x-mas.json'))
layer_names <- greet$layers$name
heart <- greet$layers$paths[[which(layer_names == 'Heart')]]$points
merry <- greet$layers$paths[[which(layer_names == 'Merry')]]$points
x_mas <- greet$layers$paths[[which(layer_names == 'X-MAS')]]$points
range <- greet$layers$paths[[which(layer_names == 'back')]]$points[[1]]
ggplot(as.data.frame(heart[[1]])) +
geom_polygon(aes(V1, V2))
That seems sort-of right. The shape is on its head since Illustrator measures
its coordinates from the top-left corner and down and not from the bottom-left
corner and up. Well simply use scale_y_reverse() later to circumvent this.
Now that we have our shapes it is time to draw them with points. To do this
we’ll sample 25.000 points within the plot area and check which ones falls into
the different shapes. There are many ways to test whether a point lies inside a
shape – I’ll use the in.out() function from the mgcv package.
library(mgcv)
heart_points <- data.frame(
x = runif(25000, min = min(range[,1]), max = max(range[, 1])),
y = runif(25000, min = min(range[,2]), max = max(range[, 2])),
colour = 'green',
stringsAsFactors = FALSE
)
heart_points$colour[
in.out(
do.call(rbind, lapply(heart, rbind, c(NA, NA))),
cbind(heart_points$x, heart_points$y)
)
] <- 'red'
merry_points <- data.frame(
x = runif(25000, min = min(range[,1]), max = max(range[, 1])),
y = runif(25000, min = min(range[,2]), max = max(range[, 2])),
colour = 'red',
stringsAsFactors = FALSE
)
merry_points$colour[
in.out(
do.call(rbind, lapply(merry, rbind, c(NA, NA))),
cbind(merry_points$x, merry_points$y)
)
] <- 'green'
xmas_points <- data.frame(
x = runif(25000, min = min(range[,1]), max = max(range[, 1])),
y = runif(25000, min = min(range[,2]), max = max(range[, 2])),
colour = 'red',
stringsAsFactors = FALSE
)
xmas_points$colour[
in.out(
do.call(rbind, lapply(x_mas, rbind, c(NA, NA))),
cbind(xmas_points$x, xmas_points$y)
)
] <- 'green'
ggplot(merry_points) +
geom_point(aes(x, y, colour = colour))
We could call this a day and continue with all those points, but we wont. First,
because voronoi tessellation (as implemented in deldir) does not scale well to
these number of points, and second, because the tiles would be so small that
they are almost indistinguishable from each other.
To fix this we are going to remove a lot of the points that do not help in defining the shapes. In order to determine which points are safe to remove we are going to calculate the delaunay triangulation (the “inverse” of a voronoi tesselation) and find out which points only have neighbors of the same colour. We are going to remove as many random point so well end up with 1.000 points of each colour:
library(deldir)
library(ggforce)
heart_vor <- deldir(heart_points$x, heart_points$y)
heart_con <- split(c(heart_points$colour[heart_vor$delsgs$ind2],
heart_points$colour[heart_vor$delsgs$ind1]),
c(heart_vor$delsgs$ind1, heart_vor$delsgs$ind2))
heart_boring <- lengths(lapply(heart_con, unique)) == 1
heart_remove <- c(
sample(which(heart_boring & heart_points$colour == 'red'),
sum(heart_boring & heart_points$colour == 'red') -
(1000 - sum(!heart_boring & heart_points$colour == 'red'))),
sample(which(heart_boring & heart_points$colour == 'green'),
sum(heart_boring & heart_points$colour == 'green') -
(1000 - sum(!heart_boring & heart_points$colour == 'green')))
)
heart_points <- heart_points[-heart_remove, ]
merry_vor <- deldir(merry_points$x, merry_points$y)
merry_con <- split(c(merry_points$colour[merry_vor$delsgs$ind2],
merry_points$colour[merry_vor$delsgs$ind1]),
c(merry_vor$delsgs$ind1, merry_vor$delsgs$ind2))
merry_boring <- lengths(lapply(merry_con, unique)) == 1
merry_remove <- c(
sample(which(merry_boring & merry_points$colour == 'red'),
sum(merry_boring & merry_points$colour == 'red') -
(1000 - sum(!merry_boring & merry_points$colour == 'red'))),
sample(which(merry_boring & merry_points$colour == 'green'),
sum(merry_boring & merry_points$colour == 'green') -
(1000 - sum(!merry_boring & merry_points$colour == 'green')))
)
merry_points <- merry_points[-merry_remove, ]
xmas_vor <- deldir(xmas_points$x, xmas_points$y)
xmas_con <- split(c(xmas_points$colour[xmas_vor$delsgs$ind2],
xmas_points$colour[xmas_vor$delsgs$ind1]),
c(xmas_vor$delsgs$ind1, xmas_vor$delsgs$ind2))
xmas_boring <- lengths(lapply(xmas_con, unique)) == 1
xmas_remove <- c(
sample(which(xmas_boring & xmas_points$colour == 'red'),
sum(xmas_boring & xmas_points$colour == 'red') -
(1000 - sum(!xmas_boring & xmas_points$colour == 'red'))),
sample(which(xmas_boring & xmas_points$colour == 'green'),
sum(xmas_boring & xmas_points$colour == 'green') -
(1000 - sum(!xmas_boring & xmas_points$colour == 'green')))
)
xmas_points <- xmas_points[-xmas_remove, ]
ggplot(xmas_points) +
geom_voronoi_tile(aes(x, y, fill = colour), colour = 'black')
Now we’re getting somewhere!
The next step is to match the points from each stage together so we know which
one moves where. For the transition between the heart and the text I’m fine with
it being random, but for the transition between “merry” and “x-mas” I want it to
seem as smooth as possible. This requires that each point in merry_points get
matched to its nearest neighbor of equal colour in the xmas_points data.frame.
As some points might compete for the nearest neighbor some will have to settle
for neighbors a bit farther away. While it might be possible to optimise the
choice of neighbor we are just going to go through each in turn so the points
occuring first in the data.frame will get first pick:
heart_points <- heart_points[order(heart_points$colour), ]
heart_points$id <- seq_len(nrow(heart_points))
merry_points <- merry_points[order(merry_points$colour), ]
merry_points$id <- seq_len(nrow(merry_points))
xmas_points <- xmas_points[order(xmas_points$colour), ]
eu_dist <- function(x, y) {
ifelse(
merry_points$colour[x] != xmas_points$colour[y],
1e5,
sqrt((merry_points$x[x] - xmas_points$x[y])^2 +
(merry_points$y[x] - xmas_points$y[y])^2)
)
}
distance <- outer(seq_len(nrow(merry_points)),
seq_len(nrow(merry_points)),
eu_dist
)
pair <- Reduce(function(l, r) {
pair_order <- order(distance[r, ])
c(l, pair_order[which(!pair_order %in% l)[1]])
}, seq_len(nrow(merry_points)), init = integer())
xmas_points$id[pair] <- seq_len(nrow(xmas_points))
xmas_points <- xmas_points[order(xmas_points$id), ]Now each data.frame is lined up so the point encoded in row 1 is the same across
all. The last bit of work we need to do is to interpolate the transition between
each stage. This could be done in one line of code with tweenr using
tween_states() but I dont want all points to start and end their movements at
the same time. Thus we need to do something a bit more custom:
library(tweenr)
tween_points <- function(from, to, length, stagger) {
leave <- sample(seq_len(stagger), nrow(from), replace = TRUE)
arive <- sample(seq_len(stagger), nrow(from), replace = TRUE)
x <- tween_t(Map(function(.f, .t) c(.f, .t), .f = from$x, .t = to$x),
length - leave - arive)
y <- tween_t(Map(function(.f, .t) c(.f, .t), .f = from$y, .t = to$y),
length - leave - arive)
points <- Map(function(x, y, l, a) {
data.frame(x = x, y = y)[c(rep(1, l), seq_along(x), rep(length(x), a)), ]
}, x = x, y = y, l = leave, a = arive)
points <- do.call(rbind, points)
points$frame <- rep(seq_len(length), nrow(from))
cbind(
points,
from[rep(seq_len(nrow(from)), each = length), !names(from) %in% c('x', 'y')])
}This function takes two data.frames along with the total transition length and
a stagger value that encodes the maximum offset in time each transition can
have in terms of starting and ending. It then interpolates the x and y
columns between the two data.frames, adding a frame column to the end result.
Let’s put it to good use. Our animation will take 12 seconds at a frame rate of 24 fps making a total of 288 frames and 96 frames for each stage along with the transition to it. We’ll split it up so that each stage is hold for 36 frames, ending up with 60 frames for each transition. We’ll allow the start and end time to vary with 20 frames each:
n_frames_still <- 36
n_frames_trans <- 60
n_frames_stagger <- 20
n_frames_stage <- 96
heart_to_merry <- tween_points(heart_points,
merry_points,
n_frames_trans,
n_frames_stagger)
merry_to_xmas <- tween_points(merry_points,
xmas_points,
n_frames_trans,
n_frames_stagger)
xmas_to_heart <- tween_points(xmas_points,
heart_points,
n_frames_trans,
n_frames_stagger)In addition to this we need to repeat each stage 36 times and offset the frame count. In the end we’ll combine everything into one data.frame:
heart_still <- heart_points[rep(seq_len(nrow(heart_points)), n_frames_still), ]
heart_still$frame <- rep(seq_len(n_frames_still), each = nrow(heart_points))
heart_to_merry$frame <- heart_to_merry$frame + n_frames_still
merry_still <- merry_points[rep(seq_len(nrow(merry_points)), n_frames_still), ]
merry_still$frame <- rep(seq_len(n_frames_still), each = nrow(merry_points)) + n_frames_stage
merry_to_xmas$frame <- merry_to_xmas$frame + n_frames_stage + n_frames_still
xmas_still <- xmas_points[rep(seq_len(nrow(xmas_points)), n_frames_still), ]
xmas_still$frame <- rep(seq_len(n_frames_still), each = nrow(xmas_points)) + 2*n_frames_stage
xmas_to_heart$frame <- xmas_to_heart$frame + 2*n_frames_stage + n_frames_still
frames <- rbind(
heart_still,
heart_to_merry,
merry_still,
merry_to_xmas,
xmas_still,
xmas_to_heart
)We now have everything in place to create our animation – we just need to define the plotting function (take note that we specify the bounding rectangle as the range of our data might change between frames):
christmas_card <- function(data) {
bound <- c(range(range[,1]), range(-range[,2]))
ggplot(data, aes(x = x, y = y)) +
geom_voronoi_tile(aes(fill = colour), bound = bound) +
geom_voronoi_segment(alpha = 0.3, bound = bound) +
scale_y_reverse() +
scale_fill_manual(values = c('forestgreen', 'firebrick')) +
labs(caption = 'www.data-imaginist.com') +
coord_fixed(expand = FALSE) +
theme_void() +
theme(legend.position = 'none')
}
plot(christmas_card(heart_points))
Now it is just a matter of looping over each frame and plotting that data.
Normally gganimate would be useful for this but it does not always play nice
when data is heavily transformed by the stat function (as is the case with
geom_voronoi_tile() and geom_voronoi_segment()). We’ll just do it the
oldschool way (if you’re running this yourself wrap the following expression
in animation::saveGIF()):
for (i in seq_len(max(frames$frame))) {
data <- frames[frames$frame == i, ]
plot(christmas_card(data))
}
Merry Christmas!
R-bloggers.com offers daily e-mail updates about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.