Skip to content

Instantly share code, notes, and snippets.

@lcolladotor

lcolladotor/animated_tree.R

Last active December 25, 2024 00:04
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save lcolladotor/3ba0c905a9a537f5b997713cf73eb79e to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save lcolladotor/3ba0c905a9a537f5b997713cf73eb79e to your computer and use it in GitHub Desktop.
Download ZIP
Making an animated Christmas tree
Raw
animated_tree.R
## Original code: https://drmowinckels.io/blog/christmas-tree-in-ggplot/
## Original tweet: https://twitter.com/drmowinckels/status/1073261218276798465?s=12
## Other links:
# https://rladies-baltimore.github.io/post/making-holiday-cards-in-r-2018/
# https://twitter.com/fellgernon/status/1062769524917833728
# https://blogs.sas.com/content/iml/2012/12/14/a-fractal-christmas-tree.html
# https://twitter.com/thomasp85/status/811537760783912960
## Link to tweet about this code:
# https://twitter.com/fellgernon/status/1073626385283981312
library('tidyverse')
cone = data.frame(x = 1:9,
y = c(1:5,4:1)) %>%
na.omit() %>%
arrange(x)
fancy = cone %>%
mutate(xoff = ifelse(x<5, x+.4, ifelse(x>5, x-.4, NA))) %>%
gather(del, x, contains("x")) %>%
mutate(y = ifelse(del=="xoff", y-.1,y)) %>%
filter(y>=1) %>%
na.omit() %>%
select(-del) %>%
arrange(y)
## Change the direction of the 'fancy' code
new_x <- fancy$x
new_x[fancy$x > 5] <- 10 - fancy$x[fancy$x > 5]
new_x[fancy$x < 5] <- 10 - fancy$x[fancy$x < 5]
fancy$x <- new_x
# fancy2 <- fancy
# fancy2$x <- new_x
library(gganimate, quietly = T)
# Define bauble colours
bauble_colours = c('deepskyblue', 'darkorange',
'darkorchid', 'aquamarine', 'limegreen',
'lightslateblue', 'chartreuse4')
set.seed(20181214)
baubles = cone %>%
# Group by y, nest and make up some random values for x.
group_by(y) %>%
nest() %>%
mutate(data = map(data, ~data.frame(x=seq(min(.$x), max(.$x), by=.1)))) %>%
unnest() %>%
# Group by x, nest and make up some random values for y.
group_by(x) %>%
nest() %>%
mutate(data = map(data, ~data.frame(y=seq(min(.$y), max(.$y), by=.1)))) %>%
unnest() %>%
# Give baubles random shapes, sizes and two different colours.
mutate(col1 = sample(bauble_colours, nrow(.), replace = T),
col2 = sample(bauble_colours, nrow(.), replace = T),
shp = sample(1:7, nrow(.), replace = T),
sz = sample(seq(.5,2,by=.1), nrow(.), replace = T),
time = sample(seq(.5,1,by=.01), nrow(.), replace = T)
) %>%
rownames_to_column() %>%
# Grab only 60 baubles
sample_n(60) %>%
# Gather the colours into a single column
gather(dd, cols, contains("col")) %>%
mutate(alph = ifelse(dd == "col1", .8, 1))
snow = data.frame(x = sample(seq(1, max(cone$x)+1, by=.01), 100, replace = F),
y = sample(seq(1, max(cone$y)+1, by=.01), 100, replace = F)) %>%
group_by(x) %>%
nest() %>%
mutate(data = map(data,
~data.frame(y=seq(.$y, .$y-sample(seq(.5,1,by=.01),1), length.out = 100)) %>%
mutate(time = sample(seq(0.5,.9, .01), 1)) %>%
mutate(time = seq(unique(time), unique(time)+.02, length.out = nrow(.)))
)) %>%
unnest()
treebase <- data.frame(x = c(4.5, 4.5, 5.5, 5.5), y = c(0, 1, 1, 0))
cone %>%
ggplot(aes(x=x, y=y)) +
# Snow
geom_jitter(data=snow, aes(group=x), colour="deeppink", shape=8, size=1) +
# Cone
geom_polygon(fill="white") +
# Fancy
geom_polygon(data=fancy, fill = "deeppink") + # geom_polygon(data=fancy2, fill = "red")
# Add tree base
geom_polygon(data = treebase, fill = 'deeppink') +
# Add Feliz navidad
# Used info from http://www.cookbook-r.com/Graphs/Fonts/
annotate('text', x = 5.5, y = 6, label = 'Feliz Navidad!', col = 'gold', size = 18, family = 'Courier', fontface = 'italic') +
# Baubles
geom_point(data = baubles %>% select(-time), show.legend = F, alpha = .7,
aes(colour=I(cols), fill=I(cols),
shape = factor(shp),size=sz, group=rowname)) +
# animated baubles!
geom_point(data = baubles, show.legend = F,
aes(colour=I(cols), fill=I(cols), alpha=I(alph),
shape = factor(shp),size=sz, group=rowname)) +
# Topper
geom_point(data=data.frame(x=5, y=5), colour="#e5d08f", size=15, shape=8) +
scale_shape_manual(values = c(20:25,8)) +
# remove axes etc., and make background black
theme_void() +
theme(plot.background = element_rect(fill="black"), title = element_text(colour="white")) +
# Animate
transition_time(time) +
ease_aes('sine-in-out')
## Reproducibility information
library('sessioninfo')
print('Reproducibility information:')
Sys.time()
proc.time()
options(width = 120)
session_info()
# ─ Session info ───────────────────────────────────────────────────────────────────────────────────────────────────────
# setting value
# version R version 3.5.1 (2018-07-02)
# os macOS Mojave 10.14.1
# system x86_64, darwin15.6.0
# ui AQUA
# language (EN)
# collate en_US.UTF-8
# ctype en_US.UTF-8
# tz America/New_York
# date 2018-12-14
#
# ─ Packages ───────────────────────────────────────────────────────────────────────────────────────────────────────────
# package * version date lib source
# assertthat 0.2.0 2017-04-11 [1] CRAN (R 3.5.0)
# backports 1.1.2 2017-12-13 [1] CRAN (R 3.5.0)
# bindr 0.1.1 2018-03-13 [1] CRAN (R 3.5.0)
# bindrcpp * 0.2.2 2018-03-29 [1] CRAN (R 3.5.0)
# broom 0.5.1 2018-12-05 [1] CRAN (R 3.5.1)
# cellranger 1.1.0 2016-07-27 [1] CRAN (R 3.5.0)
# cli 1.0.1 2018-09-25 [1] CRAN (R 3.5.0)
# colorspace 1.3-2 2016-12-14 [1] CRAN (R 3.5.0)
# crayon 1.3.4 2017-09-16 [1] CRAN (R 3.5.0)
# digest 0.6.18 2018-10-10 [1] CRAN (R 3.5.0)
# dplyr * 0.7.8 2018-11-10 [1] CRAN (R 3.5.0)
# farver 1.1.0 2018-11-20 [1] CRAN (R 3.5.1)
# forcats * 0.3.0 2018-02-19 [1] CRAN (R 3.5.0)
# generics 0.0.2 2018-11-29 [1] CRAN (R 3.5.0)
# gganimate * 0.9.9.9999 2018-12-14 [1] Github (thomasp85/gganimate@17cdeef)
# ggplot2 * 3.1.0 2018-10-25 [1] CRAN (R 3.5.0)
# gifski 0.8.6 2018-09-28 [1] CRAN (R 3.5.0)
# glue 1.3.0 2018-07-17 [1] CRAN (R 3.5.0)
# gtable 0.2.0 2016-02-26 [1] CRAN (R 3.5.0)
# haven 2.0.0 2018-11-22 [1] CRAN (R 3.5.0)
# hms 0.4.2 2018-03-10 [1] CRAN (R 3.5.0)
# httr 1.3.1 2017-08-20 [1] CRAN (R 3.5.0)
# jsonlite 1.5 2017-06-01 [1] CRAN (R 3.5.0)
# labeling 0.3 2014-08-23 [1] CRAN (R 3.5.0)
# lattice 0.20-38 2018-11-04 [1] CRAN (R 3.5.1)
# lazyeval 0.2.1 2017-10-29 [1] CRAN (R 3.5.0)
# lubridate 1.7.4 2018-04-11 [1] CRAN (R 3.5.0)
# magrittr 1.5 2014-11-22 [1] CRAN (R 3.5.0)
# modelr 0.1.2 2018-05-11 [1] CRAN (R 3.5.0)
# munsell 0.5.0 2018-06-12 [1] CRAN (R 3.5.0)
# nlme 3.1-137 2018-04-07 [1] CRAN (R 3.5.1)
# pillar 1.3.0 2018-07-14 [1] CRAN (R 3.5.0)
# pkgconfig 2.0.2 2018-08-16 [1] CRAN (R 3.5.0)
# plyr 1.8.4 2016-06-08 [1] CRAN (R 3.5.0)
# png 0.1-7 2013-12-03 [1] CRAN (R 3.5.0)
# prettyunits 1.0.2 2015-07-13 [1] CRAN (R 3.5.0)
# progress 1.2.0 2018-06-14 [1] CRAN (R 3.5.0)
# purrr * 0.2.5 2018-05-29 [1] CRAN (R 3.5.0)
# R6 2.3.0 2018-10-04 [1] CRAN (R 3.5.0)
# Rcpp 1.0.0 2018-11-07 [1] CRAN (R 3.5.0)
# readr * 1.2.1 2018-11-22 [1] CRAN (R 3.5.0)
# readxl 1.1.0 2018-04-20 [1] CRAN (R 3.5.0)
# rlang 0.3.0.1 2018-10-25 [1] CRAN (R 3.5.0)
# rstudioapi 0.8 2018-10-02 [1] CRAN (R 3.5.0)
# rvest 0.3.2 2016-06-17 [1] CRAN (R 3.5.0)
# scales 1.0.0 2018-08-09 [1] CRAN (R 3.5.0)
# sessioninfo * 1.1.1 2018-11-05 [1] CRAN (R 3.5.0)
# stringi 1.2.4 2018-07-20 [1] CRAN (R 3.5.0)
# stringr * 1.3.1 2018-05-10 [1] CRAN (R 3.5.0)
# tibble * 1.4.2 2018-01-22 [1] CRAN (R 3.5.0)
# tidyr * 0.8.2 2018-10-28 [1] CRAN (R 3.5.0)
# tidyselect 0.2.5 2018-10-11 [1] CRAN (R 3.5.0)
# tidyverse * 1.2.1 2017-11-14 [1] CRAN (R 3.5.0)
# tweenr 1.0.0 2018-09-27 [1] CRAN (R 3.5.0)
# withr 2.1.2 2018-03-15 [1] CRAN (R 3.5.0)
# xml2 1.2.0 2018-01-24 [1] CRAN (R 3.5.0)
#
# [1] /Library/Frameworks/R.framework/Versions/3.5devel/Resources/library
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment