Data Driven Christmas Card Animation with Voronoi Tiles

December 20, 2016
By

(This article was first published on Data Imaginist - R posts, and kindly contributed to R-bloggers)

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:

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))

center

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))

center

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')

center

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))

center

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))
}

unnamed-chunk-10

Merry Christmas!

To leave a comment for the author, please follow the link and comment on their blog: Data Imaginist - R posts.

R-bloggers.com offers daily e-mail updates about R news and tutorials on topics such as: Data science, Big Data, R jobs, visualization (ggplot2, Boxplots, maps, animation), programming (RStudio, Sweave, LaTeX, SQL, Eclipse, git, hadoop, Web Scraping) statistics (regression, PCA, time series, trading) and more...



If you got this far, why not subscribe for updates from the site? Choose your flavor: e-mail, twitter, RSS, or facebook...

Comments are closed.

Sponsors

Never miss an update!
Subscribe to R-bloggers to receive
e-mails with the latest R posts.
(You will not see this message again.)

Click here to close (This popup will not appear again)