使用ggmap和gganimate创建"天桥"地图动画

Question

我有一个人到达某个地点的数据集,他们待了多久,以及他们的家乡位置.我想创建一个动画图表,将它们"飞"到目的地,并在旅行结束后将它们返回原点.但我不确定这是否可行gganimate.目前我似乎只能做一个"开始"和"结束"框架,虽然有点难以判断它是否没有足够的框架来执行预期的操作.

这就像我到目前为止的情况:

library(dplyr)
library(ggplot2)
library(ggmap)
library(gganimate)

#Coordinates
europecoords <- c(left = -23, bottom = 36, right = 27.87, top = 70.7)
londonareacoords <- c(left = -.7, bottom = 51, right = 0.2, top = 52)
londonpointcoords <- as.data.frame(list(lon = -.14, lat = 51.49))

#Get the map we'll use as the background
europe <- get_stamenmap(europecoords, zoom = 4, maptype = "toner-lite")

#Sample dataset configuration
numberofpoints <- 10
balance <- 0.1

#Set up an example dataset
ids <- seq(1:numberofpoints)
arrivalday <- sample(x = 30, size = numberofpoints, replace = TRUE)
staylength <- sample(x = 7, size = numberofpoints, replace = TRUE)
startlocationlondonarealon <- sample(x = seq(londonareacoords['left'] * 10, londonareacoords['right'] * 10), size = numberofpoints * balance, replace = TRUE) / 10
startlocationlondonarealat <- sample(x = seq(londonareacoords['bottom'] * 10, londonareacoords['top'] * 10), size = numberofpoints * balance, replace = TRUE) / 10
startlocationeuropelon <- sample(x = seq(europecoords['left'] * 10, europecoords['right'] * 10), size = (numberofpoints * (1 - balance)), replace = TRUE) / 10
startlocationeuropelat <- sample(x = seq(europecoords['bottom'] * 10, europecoords['top'] * 10), size = (numberofpoints * (1 - balance)), replace = TRUE) / 10
startlocationlon <- c(startlocationlondonarealon, startlocationeuropelon)
startlocationlat <- c(startlocationlondonarealat, startlocationeuropelat)

points <- as.data.frame(cbind(ID = ids, arrivalday, staylength, departureday = arrivalday + staylength, startlocationlon, startlocationlat))

#Map the sample dataset to check it looks reasonable
ggmap(europe) +
  geom_point(data = points, aes(x = startlocationlon, y = startlocationlat), col = "blue", size = 2) +
  geom_point(data = londonpointcoords, aes(x = lon, y = lat), col = "red")


#Separate the events out to rearrange, then glue them back together
event1 <- points %>%
  mutate(Event = "Day Before Arrival", Date = arrivalday - 1) %>%
  mutate(Lon = startlocationlon, 
         Lat = startlocationlat) %>%
  select(ID, Event, Date, Lon, Lat)

event2 <- points %>% 
  mutate(Event = "Arrival Date", Date = arrivalday) %>%
  mutate(Lon = londonpointcoords$lon[1],
         Lat = londonpointcoords$lat[1]) %>%
  select(ID, Event, Date, Lon, Lat)

event3 <- points %>% 
  mutate(Event = "Departure Date", Date = departureday) %>%
  mutate(Lon = londonpointcoords$lon[1],
         Lat = londonpointcoords$lat[1]) %>%
  select(ID, Event, Date, Lon, Lat)

event4 <- points %>%
  mutate(Event = "Day After Departure", Date = departureday + 1) %>%
  mutate(Lon = startlocationlon, 
         Lat = startlocationlat) %>%
  select(ID, Event, Date, Lon, Lat)

events <- rbind(event1, event2, event3, event4) %>%
  mutate(Event = factor(Event, ordered = TRUE, levels = c("Day Before Arrival", "Arrival Date", "Departure Date", "Day After Departure"))) %>%
  mutate(ID = factor(ID))

#Make an animation
ggmap(europe) +
  geom_point(data = events, aes(x = Lon, y = Lat, group = ID, col = ID), size = 2) +
  #geom_point(data = londonpointcoords, aes(x = lon, y = lat), col = "red") +
  transition_manual(Date) +
  labs(title = "Date: {frame}") +
  NULL

但正如我所说的,这些点似乎并不像出现和消失一样"飞行".我应该使用不同的数据格式吗？过渡型？帧数？(我很难找到上述任何一个的文档,这也是我被卡住的原因之一...)

Answer 1

最后结果

码

library(ggplot2)    
library(ggmap)
library(gganimate)
ggm <- ggmap(europe) +
    geom_point(data = events,
               aes(x = Lon, y = Lat,
                   colour = ID, group = ID, shape = Event),
               size = 3, alpha = 0.8) +
    transition_time(Date) + 
    labs(title = paste("Day", "{round(frame_time,0)}")) +
    shadow_wake(wake_length = 0.1)
animate(ggm, fps = 24, duration = 16) 

================================================== ======

一步步

那里有很多活动部件.让我们分解一下:

0.加载库

library(ggplot2)    
library(ggmap)
library(gganimate)
library(ggrepel) # will be useful for data exploration in step 1

1.数据探索

ggplot(data = events, aes(x = ID, y = Date, colour = Event)) +
    geom_point()

我们看到,每架飞机的到达和离开事件都非常接近.此外,两者之间总是存在几天的差距.这看似合理.

我们来检查Date变量:

> length(unique(events$Date))
[1] 24
> min(events$Date)
[1] 2
> max(events$Date)
[1] 33

好的,这意味着两件事:

1. 我们的数据点间距不均匀.
2. 我们没有所有数据Date.

两件事都会让动画部分变得非常具有挑战性.

ggplot(data = unique(events[, 4:5]), aes(x = Lon, y = Lat)) + 
    geom_point()

此外,我们只有11个独特的位置(==机场).这可能导致数据重叠.让我们按天绘制它:

ggplot(data = unique(events[, 3:5]), aes(x = Lon, y = Lat, label = Date)) +
    geom_point() + 
    geom_text_repel()

是的,这很有趣......中间那个机场发生了很多事情.

2.基本动画

gga <- ggplot(data = events, aes(x = Lon, y = Lat)) +
    geom_point() +
    transition_time(Date)
animate(gga)

我们使用transition_time()和不使用transition_states(),因为前者用于线性时间变量(例如,秒,日,年)和自动插值,而后者为用户提供更多的手动控制.

3.让我们添加颜色

gga <- ggplot(data = events, aes(x = Lon, y = Lat, colour = ID)) +
    geom_point() +
    transition_time(Date)
animate(gga)

它开始看起来像什么!

4.添加标题,透明度,增加大小

gga <- ggplot(data = events, aes(x = Lon, y = Lat, col = ID)) +
    geom_point(size = 3, alpha = 0.5) +
    transition_time(Date) + 
    labs(title = paste("Day", "{round(frame_time, 0)}"))

请注意圆形{round(frame_time, 0)}.尝试使用{frame_time},看看会发生什么!

5.添加一些比萨饼

gga <- ggplot(data = events, aes(x = Lon, y = Lat, col = ID, group = ID, 
                                 shape = Event)) +
    geom_point(size = 3, alpha = 0.5) +
    transition_time(Date) + 
    labs(title = paste("Day", "{round(frame_time, 0)}")) +
    shadow_wake(wake_length = 0.05)
animate(gga)

看起来不错,让我们完成它!

6.添加地图,使动画更慢,调整一些细节

ggm <- ggmap(europe) +
    geom_point(data = events,
               aes(x = Lon, y = Lat,
                   colour = ID, group = ID, shape = Event),
               size = 3, alpha = 0.8) +
    transition_time(Date) + 
    labs(title = paste("Day", "{round(frame_time,0)}")) +
    shadow_wake(wake_length = 0.1)
animate(ggm, fps = 24, duration = 16) 

不是太破旧了,是吗？作为旁注:animate(ggm, nframes = 384)对动画的效果fps = 24与使用相同duration = 16.

如果您有任何疑问,请随时给我发表评论.我会尽力帮助或澄清事情.