Создайте анимацию карты «flyover», используя ggmap и gganimate - PullRequest
Новая
       17

Создайте анимацию карты «flyover», используя ggmap и gganimate

0 голосов
/ 26 сентября 2018

У меня есть набор данных людей, прибывающих в какое-то место, как долго они оставались, и их домашние местоположения.Я хочу создать анимированный график, который «доставит» их к месту назначения и вернет их к исходной точке, как только их путешествие закончится.Но я не уверен, возможно ли это с 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

enter image description here

Но, как я уже сказал, точки, кажется, не «летают» так сильнокак только появляясь и исчезая.Должен ли я использовать другой формат данных?Тип перехода?Количество кадров?(У меня возникают проблемы с поиском документации по любому из вышеперечисленных вопросов, поэтому я застрял ...)

1 Ответ

0 голосов
/ 09 октября 2018

Конечный результат

7

Код 

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()

1

Мы видим, что события прилета и вылета достаточно близки для каждого самолета.Кроме того, между ними всегда есть разрыв в пару дней.Это кажется разумным.

Давайте проверим переменную 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()

2

Кроме того, у нас есть только 11 уникальных мест (== аэропортов).Это, вероятно, приведет к дублированию данных.Давайте построим это по дням: 

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

3

Да, это будет весело ... Много вещей происходит в этом аэропорту посередине.

2.Базовая анимация 

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

4

Мы использовали transition_time(), а не transition_states(), потому что первый используется для линейных переменных времени (например, секунда, день, год) и автоматической интерполяции, в то время как последний дает больше ручного управления пользователю.

3.Давайте добавим цвет 

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

5

Это начинает выглядеть как-то!

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} и посмотрите, что получится!

6

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)

8

Выглядит хорошо, давайте закончим!

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)

7

Не слишком потертый, а?Примечание: animate(ggm, nframes = 384) имел бы такой же эффект на анимацию, что и fps = 24 с duration = 16.

Если у вас есть какие-либо вопросы, пожалуйста, не стесняйтесь, напишите мне комментарий.Я сделаю все возможное, чтобы помочь или прояснить ситуацию.

...