Animated supply and demand graph

animated_SD_wide

library(tidyverse)
library(Hmisc)
library(gganimate)
library(tweenr)

curve_intersect <- function(c1x, c1y, c2x, c2y, empirical=TRUE, domain=NULL) {
  curve1 <- data.frame(x = c1x, y = c1y)
  curve2 <- data.frame(x = c2x, y = c2y)
  
  if (!empirical & missing(domain)) {
    stop("'domain' must be provided with non-empirical curves")
  }
  
  if (!empirical & (length(domain) != 2 | !is.numeric(domain))) {
    stop("'domain' must be a two-value numeric vector, like c(0, 10)")
  }
  
  if (empirical) {
    # Approximate the functional form of both curves
    curve1_f <- approxfun(curve1$x, curve1$y, rule = 2)
    curve2_f <- approxfun(curve2$x, curve2$y, rule = 2)
    
    # Calculate the intersection of curve 1 and curve 2 along the x-axis
    point_x <- uniroot(function(x) curve1_f(x) - curve2_f(x),
                       c(min(curve1$x), max(curve1$x)))$root
    
    # Find where point_x is in curve 2
    point_y <- curve2_f(point_x)
  } else {
    # Calculate the intersection of curve 1 and curve 2 along the x-axis
    # within the given domain
    point_x <- uniroot(function(x) curve1(x) - curve2(x), domain)$root
    
    # Find where point_x is in curve 2
    point_y <- curve2(point_x)
  }
  
  return(list(x = point_x, y = point_y))
}

s <- bind_rows(data.frame(bezier(c(1, 1.8, 2), c(3, 3.5, 4)), 
                          t = 1,
                          point = 1:100),
               data.frame(bezier(c(1.5, 2.3, 2.5), c(3, 3.5, 4)), 
                          t = 2,
                          point = 1:100)) %>%
  rename(xs = x, ys = y)
d <- data.frame(bezier(c(1,1.3,2), c(4, 3.5, 3)), point = 1:100, t = 1) %>%
  rename(xd = x, yd = y)

s_frames <-  s %>%
  tween_along(ease = 'sine-in-out', 100, along = t, id = point) %>% 
  filter(.phase == "transition") %>% 
  select(xs, ys, point, .frame) %>% 
  arrange(.frame, point)  # arrange by point needed to keep in order

d_frames <-  d %>%
  bind_rows(d %>% mutate(t = 2)) %>% 
  tween_along(ease = 'sine-in-out', 100, along = t, id = point) %>% 
  filter(.phase == "transition") %>% 
  select(xd, yd, point, .frame) %>%
  arrange(.frame, point)


data <- s_frames %>%
  left_join(d_frames, by = c(".frame", "point")) %>% 
  group_by(.frame) %>% 
  mutate(xe = curve_intersect(xs,ys,xd,yd)$x,
         ye = curve_intersect(xs,ys,xd,yd)$y)

p <- ggplot(data, aes(x = xs, y = ys)) + geom_path(size = 1.25, color = 'red') +
  geom_path(aes(x=xd,y=yd), size = 1.25, color = 'blue')+
  geom_point(aes(x = xe,y = ye), 
             size = 5,
             color = 'black') +
  labs(x = "Q",
       y = "P",
       title = "A Rightward Shift in Supply")+
  expand_limits(y = c(2.9, 4.1))+
  transition_states(.frame)+
  ease_aes('sine-in-out') + 
  theme_light()+
  theme(axis.title.y = element_text(hjust=1,angle = 90, size = 20),
        axis.title.x = element_text(hjust = 1, size = 20))
animate(p, fps = 24)