gganimate horizontal column chart won't transition bars smoothly

Question

I am creating a bar chart race animation using geom_colh from the ggstance package. Right now, the animation is very choppy and doesn't appear to be one continuous animation, instead just one image after another. Below is what the current animation looks like:

Instead, I want the bars to "glide" from one position to another when they pass each other. Below is the reprex of the code I currently have:

library(tidyverse)
library(dplyr)
library(ggplot2)
library(gganimate)
library(ggstance)
library(zoo)
library(gifski)
library(shadowtext)

stats <- read_csv(url("https://raw.githubusercontent.com/samhoppen/Fantasy-Evaluator/main/Data/Animation%20Test%20Data.csv")) %>% 
  mutate(unique_id = paste0(player_name, recent_team))
all_weeks <- read_csv(url("https://raw.githubusercontent.com/samhoppen/Fantasy-Evaluator/main/Data/Animation%20Weeks%20Data.csv"))

NFL_pri <- stats$team_color
names(NFL_pri) <- stats$unique_id
NFL_sec <- stats$team_color2
names(NFL_sec) <- stats$unique_id

rb_ani <- ggplot(data = stats, aes(group = player_name)) +
  geom_colh(aes(x = tot_fpts, y = rank, color = unique_id, fill = unique_id), position = 'identity', 
            size = 2, width = 0.8) + 
  scale_x_continuous(expand = expansion(mult = c(0, 0.05))) +
  scale_y_reverse(expand = expansion(mult = c(0.01, 0.01)))+
  geom_shadowtext(aes(x = name_loc, y = rank, label = player_name, color = unique_id), 
                  bg.color = 'white', size = 5.5, na.rm = T, bg.r = 0.075, show.legend = FALSE) +
  scale_color_manual(values = NFL_sec)+
  scale_fill_manual(values = NFL_pri)+ 
  labs(title = "Highest-scoring Fantasy Running Backs of the Past Decade",
       subtitle = paste0("{all_weeks$week_name[as.numeric(previous_state)]}"),
       caption = "Figure: @SamHoppen | Data: @nflfastR",
       y = "",
       x = "Total Fantasy Points")+
  theme(legend.position = "none",
        plot.title = element_text(size = 24, face = "bold", margin = margin(0,0,10,0)),
        plot.subtitle = element_text(size = 12, margin = margin(0,0,10,0)),
        plot.caption = element_text(size = 12)) +
  transition_states(states = week_order, transition_length = 2, state_length = 1, wrap = F) +
  view_follow(fixed_y = TRUE) +
  enter_fly(y_loc = -21) +
  exit_fly(y_loc = -21) +
  ease_aes('linear')

anim <- animate(rb_ani, nframes = 100, fps = 5,renderer = gifski_renderer(), height = 900, width = 1600)

I've tried changing the transition length/state length, removing the theme items, removing the colors, removing the stat = 'identity' argument, changing the group variable, and the number of frames/fps. I'm at a loss of what to try next. Any suggestions would be great!

Answer 1

Part of the challenge here is very choppy rankings week to week. To make the animation smooth, you'll need to either make the animation pretty long, or select a subset of weeks to calculate rankings on. Here I've limited to just week 30-39, and added more frames.

I also did some more data cleaning to give all the players a rank in each week even if they aren't included in stats that week.

animate(
  stats %>%
    # Some week_name missing from stats, will use week_order to get from all_weeks
    select(-week_name) %>%
    left_join(all_weeks %>% select(week_order, week_name), by = "week_order") %>%
    

    # add every week for each player, and fill in any missing tot_fpts or team_colors
    select(week_order, week_name, player_name, tot_fpts, 
           unique_id, team_color, team_color2) %>%
    complete(week_order, player_name) %>%
    fill(tot_fpts, .direction = "down") %>%
    fill(unique_id, team_color, team_color2, .direction = "downup") %>%

    # only keep players who had >0 max_tot_fpts and weeks 30-39
    group_by(player_name) %>%
    mutate(max_tot_fpts = max(tot_fpts)) %>%
    filter(max_tot_fpts > 0, week_order >= 30, week_order < 40) %>% 
  

    # smooth out tot_fpts
    mutate(tot_fpts_smooth = spline(x = week_order, y = tot_fpts, xout = week_order)$y) %>%

    # Calc rank for every week, only keep top 20
    group_by(week_order) %>%
    arrange(-tot_fpts_smooth, player_name) %>%
    mutate(rank = row_number()) %>%
    ungroup() %>% 
    filter(rank <= 20) %>% 
    
    ggplot(aes(group = player_name, y = rank)) +
    geom_tile(aes(x = tot_fpts/2, height = 0.9, width = tot_fpts,
                  color = unique_id, fill = unique_id)) +
    geom_shadowtext(aes(x = tot_fpts, y = rank, label = player_name, color = unique_id), 
                    bg.color = 'white', size = 3.5, na.rm = T, bg.r = 0.075, 
                    show.legend = FALSE, hjust = 1.1) +
    
    # geom_text(aes(x = tot_fpts, label = paste(player_name, " ")), vjust = 0.2, hjust = 1) +
    scale_y_reverse(breaks = 1:20, minor_breaks = NULL) +
    scale_color_manual(values = NFL_sec)+
    scale_fill_manual(values = NFL_pri)+ 
    labs(title = "Highest-scoring Fantasy Running Backs of the Past Decade",
         subtitle = paste0("{all_weeks$week_name[as.numeric(previous_state)]}"),
         caption = "Figure: @SamHoppen | Data: @nflfastR",
         y = "",
         x = "Total Fantasy Points")+
    theme_minimal() +
    theme(legend.position = "none",
          plot.title = element_text(size = 14, face = "bold", margin = margin(0,0,10,0)),
          plot.subtitle = element_text(size = 12, margin = margin(0,0,10,0)),
          plot.caption = element_text(size = 12)) +
    
    transition_states(week_order, state_length = 0) +
    view_follow(fixed_y = TRUE) +
    enter_fly(y_loc = -21) +
    exit_fly(y_loc = -21) +
    
    ease_aes('linear'),
  fps = 20, duration = 4, width = 400, height = 300)