Animar gráficos de barras apiladas con gganimate

ggplot2 • dplyr • gganimate
tidytuesday

Herramientas: ggplot2, dplyr, gganimate

Preámbulo

Unos de los mayores problemas con los que me he encontrado a la hora de preparar el #tidytuesday del 2020-04-14 ha sido animar congganimate una gráfica de barras apiladas. Los datos de esta semana son relativos a las puntuaciones emitidas por diversos críticos de música a distintas canciones de de hip-hop. Cada crítico podía puntuar cinco canciones, de 1 (mayor puntuación, 10) a 5 (menor puntuación, 2).

En concreto, usaremos el conjunto de datos rankings, que contiene las siguientes variables:

  • ID: identificador numérico de la canción
  • title: título de la canción
  • artist:
  • year: año de publicación
  • gender: género del artista
  • points: puntos totales obtenidos por la canción
  • n: número total de votos obtenidos recibidos por cada canción
  • n1: número de votos que cómo número 1
  • n2: número de votos que cómo número 2
  • n3: número de votos que cómo número 3
  • n4: número de votos que cómo número 4
  • n5: número de votos que cómo número 5

La idea es crear un gráfico que tenga las siguientes características:

  • Una barra por cada canción
  • Una sección de barra con la suma de puntos por cada tipo de voto (n1 a n5)
  • La animación debe ir mostrando cada una de las secciones hasta completar el total de la barra

NOTA: puedes saltarte las explicaciones e ir directamente al código final.

Carga de librerías y datos

library(tidyverse)
library(gganimate)

rankings <- readr::read_csv('https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2020/2020-04-14/rankings.csv')

Primer intento de animación

A partir de este punto vamos a seguir siempre los siguientes pasos:

ETL -> gráfico estático -> gráfico animado

Para poder hacer el gráfico de barras apiladas por tipo de voto tenemos que realizar las siguientes modificaciones al conjunto de datos:

  • Las cinco variables n1 a n5 tienen que pasar a tener una estructura clave:valor, para lo que usaremos la función de tidyr pivot_longer().
  • Por otra parte, el conjunto de datos original ofrece los puntos ya calculados que ha obtenido cada canción, pero nuestro gráfico necesitamos los puntos de cada canción desagregados a nivel de tipo de voto. Como ya se ha indicado, se asignan 10 puntos por cada voto #1, 8 por los votos tipo #, etc.
  • Finalmente, filtramos todas las canciones que han recibido un único voto.
# ETL

canciones_x_tipovoto <- rankings %>%
  pivot_longer(n1:n5, names_to = "puesto", values_to = "votos") %>%
  group_by(title) %>%
  mutate(
    puntos = case_when(
      puesto == "n1" ~  votos * 10,
      puesto == "n2" ~  votos * 8,
      puesto == "n3" ~  votos * 6,
      puesto == "n4" ~  votos * 4,
      puesto == "n5" ~  votos * 2,
      TRUE ~ 0
    )
  ) %>% 
  filter(n > 1)
# Gráfico estático

ggplot(canciones_x_tipovoto, aes(
  x = puntos,
  y = title,
  fill = puesto
)) +
  geom_col()

Ahora ordenamos las barras de mayor a menor.

# Gráfico estático

ggplot(canciones_x_tipovoto, aes(
  x = puntos,
  y = fct_reorder(title, rev(ID)), # ordenar las barras
  fill = puesto
)) +
  geom_col()

Finalmente, vamos a modificar el orden de las secciones, de tal forma que n1 (las votaciones con más puntos) se alineen a partir de 0 en el eje x, y el resto se vayan apilando consecutivamente. Usamos group ya que si aplicaramos el reordenamiento en fill simplemente cambiaríamos el orden de los colores, no de los bloques.

# Gráfico estático

(grafico <- ggplot(canciones_x_tipovoto, aes(
  x = puntos,
  y = fct_reorder(title, rev(ID)),
  group = fct_relevel(rev(puesto)), # ordenar las secciones
  fill = puesto
)) +
  geom_col()
)

Una vez que tenemos el gráfico base, podemos empezar con la animación. De las distintas transiciones que ofrece gganimate, la que nos interesa para este caso es [transition_states()](https://gganimate.com/reference/transition_states.html, que crea la animación a partir de los niveles de una variable.

 animacion <- grafico +
   transition_states(puesto,
     state_length = 2,
     transition_length = 1
   ) 
anim_save("animacion_inicial.gif", animation = animacion, width = 900, height = 750)

Como se puede apreciar, la animación no es exactamente el resultado que queríamos obtener. En cada paso se muestran únicamente las secciones de un nivel, y están todas alineadas a 0 en el eje X.

Segundo intento

La idea es que las distintas secciones de las barras se vayan acumulando según vayan apareciendo; para esto, podemos usar la función shadow_mark(): “This shadow lets you show the raw data behind the current frame. Both past and/or future raw data can be shown and styled as you want.”

animacion <- grafico +
  transition_states(puesto,
                    state_length = 2,
                    transition_length = 1) +
  shadow_mark(past = TRUE)

anim_save(
  "animacion_secunda.gif",
  animation = animacion,
  width = 900,
  height = 750
)

Aunque ahora tenemos todas las marcas en la animación, siguen alineándose en el punto 0, por lo que seguimos sin tener un gráfico de barras apilados.

Busquemos en internet

Reflexionemos

¿Por qué se apilan las marcas en el punto 0?

La variable que tenemos mapeada al eje X es puntos, y el geom es col. Es decir, cada columna adquiere la longitud a partir de puntos. Sin embargo, esta variable por si misma no indica dónde tiene que posicionarse en el eje X, y por eso todas las marcas empiezan desde el punto 0. Ggplot se encarga de ir desplazando cada sección, pero al entrar ej juego las transiciones de gganimate esa información se olvida, por así decirlo.

Hay varios geoms de forma rectangular y que sí permiten indicar la forma y posición exacta del rectángulo: geom_tile() y geom_rect().

geom_rect and geom_tile do the same thing, but are parameterised differently: geom_rect uses the locations of the four corners (xmin, xmax, ymin and ymax), while geom_tile uses the center of the tile and its size (x, y, width, height).

Cualquiera de los dos geoms requiere que calculemos nuevas variables para poder posicionar todos los rectángulos correctamente. En este caso, los cálculos necesarios para geom_rect parecen más directos. Básicamente, necesitamos saber dónde comienza y termina cada rectángulo.

  • El punto final se calcula como la suma acumulada de la variable puntos.
  • El punto de inicio se puede calcular restando al punto final la longitud de la barra (dada por la variable puntos).
canciones_x_tipovoto <- rankings %>%
  pivot_longer(n1:n5, names_to = "puesto", values_to = "votos") %>%
  group_by(title) %>%
  mutate(
    puntos = case_when(
      puesto == "n1" ~  votos * 10,
      puesto == "n2" ~  votos * 8,
      puesto == "n3" ~  votos * 6,
      puesto == "n4" ~  votos * 4,
      puesto == "n5" ~  votos * 2,
      TRUE ~ 0
    ),
    acumulados = cumsum(puntos) # punto final
  ) %>% 
  filter(n > 1)

Tercer intento

(grafico <- ggplot(
  canciones_x_tipovoto,
  aes(
    x = puntos,
    y = fct_reorder(title, rev(ID)),
    group = fct_relevel(rev(puesto)),
    fill = puesto,
    xmin = acumulados - puntos,
    # punto de inicio del rectángulo
    xmax = acumulados # punto de final del rectángulo
  )
) +
  geom_rect())
## Error: geom_rect requires the following missing aesthetics: ymin and ymax

El problema que tenemos ahora es que geom_rect requiere que le indiquemos los cuatro vértices del rectángulo, y únicamente le hemos indicado dos. Nos falta indicar ymin e ymax; estod dos parámetros, además, tienen que ser de tipo numérico, y hasta ahora hemos usado una variable cualitativa para el eje Y.

Podríamos usar la variable ID para posicionar las barras en el eje Y, ya que se ha codificado de forma numérica.

(grafico <- ggplot(
   canciones_x_tipovoto,
   aes(
     x = puntos,
     y = ID,
     group = fct_relevel(rev(puesto)),
     fill = puesto,
     xmin = acumulados - puntos,
     xmax = acumulados,
     ymin = ID - 0.45,
     ymax = ID + 0.45
   )
 ) +
   geom_rect() +
   scale_y_continuous(trans = "reverse")
)

Ahora cada rectángulo se posiciona correctamente… ¡demasiado correctamente, de hecho!

No hemos de olvidar que hemos filtrado las canciones con un solo voto; algunas de esas canciones tenían más puntos en total que canciones con más votos, por lo que aparecen en la posición que les corresponde dentro de la lista de TODAS las canciones.

Para arreglar este problema, podemos volver a crear un ranking DESPUÉS de filtrar las canciones que no nos interesen. Para ello, aplicamos el filtro en primer lugar, y calculamos la nueva posición en el ranking.

canciones_x_tipovoto <- rankings %>%
 filter(n > 1) %>% # primero filtramos las canciones
 mutate(new_ID = dense_rank(ID)) %>% # y calculamos el nuevo ranking
 pivot_longer(n1:n5, names_to = "puesto", values_to = "votos") %>%
 group_by(title) %>%
 mutate(
   puntos = case_when(
     puesto == "n1" ~  votos * 10,
     puesto == "n2" ~  votos * 8,
     puesto == "n3" ~  votos * 6,
     puesto == "n4" ~  votos * 4,
     puesto == "n5" ~  votos * 2,
     TRUE ~ 0
   ),
   acumulados = cumsum(puntos)
 )

(grafico <- ggplot(
   canciones_x_tipovoto,
   aes(
     x = puntos,
     y = new_ID,
     group = fct_relevel(rev(puesto)),
     fill = puesto,
     xmin = acumulados - puntos,
     xmax = acumulados,
     ymin = new_ID - 0.45,
     ymax = new_ID + 0.45
   )
 ) +
   geom_rect() +
   scale_y_continuous(trans = "reverse")
)

Arreglar etiquetas

Finalmente, tenemos que arreglar las etiquetas del eje Y para que aparezca el título de las canciones en lugar del puesto en el ranking. Para ello, necesitamos la lista de las canciones en el orden correcto.

También tenemos que hacer que el número de breaks del eje Y coincida con el número de canciones.

titulos <- as.character(fct_unique(fct_reorder(canciones_x_tipovoto$title, canciones_x_tipovoto$ID)))

(
  grafico <- ggplot(
    canciones_x_tipovoto,
    aes(
      x = puntos,
      y = new_ID,
      group = fct_relevel(rev(puesto)),
      fill = puesto,
      xmin = acumulados - puntos,
      xmax = acumulados,
      ymin = new_ID - 0.45,
      ymax = new_ID + 0.45
    )
  ) +
    geom_rect() +
    scale_y_continuous(
      trans = "reverse",
      breaks = c(1:length(titulos)),
      labels = titulos
    ) +
    scale_x_continuous(expand = c(0, 1)) +
    theme_minimal() +
    theme(
      panel.grid.major.y = element_blank(),
      panel.grid.minor.y = element_blank(),
      axis.ticks.y = element_blank()
    )
)

Animación final

Ya tenemos casi todo preparado para crear la animación final. Sin embargo, después de varias pruebas, hemos detectado un pequeño problemilla: la animación no comienza en blanco, sino que se muestran directamente las marcas del primer estado (n1). Podemos hacer dos cosas:

  • Dejarlo así.
  • Añadir un registro con una canción de puesto n0; esto forzará a gganimate a crear un estado más antes de n1. Para que el truco funcione gráficamente, este nuevo registro no tiene que “dibujarse” en pantalla, por lo que la mayoría de sus variables tendrán un valor de 0 o campo vacio. Esta solución conlleva a su vez otro pequeño problema, y es que el nivel n0 aparecerá en la leyenda de color, a pesar de no haber ninguna marca (visible) de ese nivel.

Resumimos todo el código:

canciones_x_tipovoto <- rankings %>%
 filter(n > 1) %>% # primero filtramos las canciones
 mutate(new_ID = dense_rank(ID)) %>% # y calculamos el nuevo ranking
 pivot_longer(n1:n5, names_to = "puesto", values_to = "votos") %>%
 group_by(title) %>%
 mutate(
   puntos = case_when(
     puesto == "n1" ~  votos * 10,
     puesto == "n2" ~  votos * 8,
     puesto == "n3" ~  votos * 6,
     puesto == "n4" ~  votos * 4,
     puesto == "n5" ~  votos * 2,
     TRUE ~ 0
   ),
   acumulados = cumsum(puntos)
 )

canciones_x_tipovoto <- canciones_x_tipovoto %>%
  ungroup() %>%
  add_row(
    ID = 1,
    title = "",
    artist = "slideholder",
    year = "2020",
    gender = "mixed",
    points = 0,
    n = 2,
    new_ID = 1,
    puesto = "n0",
    votos = 0,
    puntos = 0,
    acumulados = 0
  )

titulos <- as.character(fct_unique(fct_reorder(canciones_x_tipovoto$title, canciones_x_tipovoto$ID)))

grafico <- ggplot(
  canciones_x_tipovoto,
  aes(
    x = puntos,
    y = new_ID,
    group = fct_relevel(rev(puesto)),
    fill = puesto,
    xmin = acumulados - puntos,
    xmax = acumulados,
    ymin = new_ID - 0.45,
    ymax = new_ID + 0.45
  )
) +
  geom_rect() +
  scale_y_continuous(trans = "reverse",
                     breaks = c(1:length(titulos)),
                     labels = titulos) +
  scale_x_continuous(expand = c(0, 1)) +
  theme_minimal() +
  theme(
    panel.grid.major.y = element_blank(),
    panel.grid.minor.y = element_blank(),
    axis.ticks.y = element_blank()
  )

anim_grafico <- grafico +
  transition_states(
    puesto,
    transition_length = 1,
    state_length = 1,
    wrap = FALSE
  ) +
  enter_drift(x_mod = -15) +
  ease_aes("cubic-out") +
  shadow_mark(past = TRUE)

animate(anim_grafico, width = 900, height = 750)

anim_save("animacion_final.gif", animation = anim_grafico, width = 900, height = 750)

Más posts