r - 使用ggmap和gganimate创建 'flyover' map 动画

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. 我们没有所有日期的数据。

这两件事都会使动画部分变得非常具有挑战性。

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。添加 map ，使动画变慢，调整一些细节

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 相同>.

If you have any question please do not hesitate to shoot me a comment. I will try my best to help or clarify things.