Переходя от рассказа историй о рейтинге одобрения президента к созданию фильма об этом с помощью R!
В моем последнем посте я продемонстрировал, как можно создавать графики и текст, которые хорошо рассказывают о том, насколько американская общественность одобряла каждого из последних 14 президентов! Итак, как насчет того, чтобы сделать информацию интереснее для просмотра?
К счастью, R может это сделать. С пакетами gganimate и magick
создание GIF становится простым и эффективным. Давайте сначала посмотрим на конечный
результат, и я смогу убедить вас сделать его самостоятельно.
Эта гифка показывает рейтинг одобрения Трампа по сравнению с рейтингом одобрения каждого президента за последние 75 лет в индивидуальном сравнении один на один. Используя число День при исполнении служебных обязанностей на оси абсцисс, мы можем показать, как рейтинги одобрения каждого президента отличаются от рейтингов Трампа по мере их перехода от дня 1 к день 1461 г. (первые четыре года или первый президентский срок). Пока я сравниваю Трампа в этом посте / руководстве, вы можете заменить данные любым другим прошлым президентом.
Стоит отметить, что в этом руководстве я построил еще один график, но это все, чтобы вы поняли процесс принятия решения, когда анимировать, а когда нет.
Шаг 1. Загрузка пакета и данных
Как всегда, загрузите пакеты и данные. Основные пакеты, которые мы будем использовать в этом руководстве, - это tidyverse (как всегда), gganimate и magick. Пакет gganimate отлично подходит для анимации ваших классических ggplot графиков и графиков. Между тем, magick - один из моих самых любимых пакетов для улучшения ваших графиков, сюжетов и изображений. В этом уроке он позволяет нам изменять размер изображений, редактировать функции и объединять их в длинный GIF.
Что касается данных, я специально опираюсь на предыдущий набор данных, который использовал в моем последнем руководстве, но включил дни пребывания в должности президента и скользящее утверждение (рассчитанное на основе 5 последовательных точек данных). Данные очищены и доступны в моем репозитории Github, поэтому я предлагаю скачать файл csv именно там!
if(!require(“tidyverse”)) install.packages(“tidyverse”) # Our rock in data analysis (includes ggplot2) if(!require(“ggsci”)) install.packages(“ggsci”) # Provides awesome color palettes if(!require(“gganimate”)) install.packages(“gganimate”) # Makes animating ggplot graphs easy!!!! if(!require(“magick”)) install.packages(“magick”) # One of my favourite packages ever. All about editing pictures, plots and making GIFs like magic # Load the data df <- readRDS(“data/CombinedPresidentialApproval.rds”) # The csv file is also there if you want # df <- read.csv(“data/CombinedPresidentialApproval.csv”)
Шаг 2. Очистите данные
Теперь самое важное в любом анализе - очистка данных. Когда мы смотрим на набор данных, мы замечаем огромное количество точек данных, которые у нас есть для Дональда Трампа. Поскольку мы будем сравнивать первые 4 года у власти каждого прошлого президента с ним, мы, возможно, захотим сократить ненужный шум, тем самым ускорив графическое отображение и анимацию нашего фреймворка данных.
Поэтому, чтобы очистить данные, мы удаляем половину точек данных одобрения Трампа через день. Затем мы выбираем соответствующие столбцы для анализа, отфильтровываем все точки данных за первые четыре года и избавляемся от строк, в которых нет информации.
# We will cut every other day from Trump's approval ratings (which is fair given the lack of variation in the approval rating) df.trump <- which(df$president == "Trump") # Figure out what rows contain Trump's data # Pick every other number and add back the number of rows before the Trump data (1716) toDelete <- seq(1, nrow(df[c(df.trump[1]:df.trump[1459]),]), 2) + 1716 df <- df[-toDelete, ] # Delete the rows identified rm(df.trump, toDelete) # Cut df.days by only days in office, president and rolling approval & limit it to first 4 (less than 1461 days) df <- df %>% mutate(days_in_office=as.numeric(days_in_office)) %>% # Turn the days in office to numeric select(president, term.start, days_in_office, rolling_approval) %>% # Select the columns you need for the animated charts filter(days_in_office<1461) %>% # Filger the days in office to bet the first 4 years (1461 days!) na.omit(df)
Шаг 3. Как визуализировать?
Первый шаг визуализации - найти лучший способ сделать это. Это сложно и требует практики, размышлений и МНОГО экспериментов.
Итак, если мы выясняем, как визуализировать первые четыре года пребывания каждого президента у власти, первое, что нужно сделать, это попробовать построить линейный график. Я собираюсь нанести всех четырнадцати президентов на один ggplot график.
# Let's try to plot the data to see how it shows up. For this I am just doing a simple ggplot
static.plot <- df %>%
ggplot(aes(x = days_in_office, y = rolling_approval, color = as.factor(president),
text = paste(
"President: ", president, " - ", round(rolling_approval, digits = 1), "%",
sep = "")
)) +
ggsci::scale_color_simpsons() + # Love this color palette because it has a ton of colors
geom_line(aes(group = president)) +
scale_x_continuous(breaks = c(0, 400, 800, 1200, 1600)) +
labs(x = "Day In Office",
y = "Approval Rating",
title = "How have approval ratings changed by time in office within the first term?",
color = "President") +
theme(plot.title = element_text(face="bold", size =14),
axis.title.x = element_text(face="bold", size = 12),
axis.title.y = element_text(face="bold", size = 12),
legend.title = element_text(face="bold", size = 12),
legend.position = "bottom")
static.plot
Моя реакция? Ой! Этот график слишком загроможден, его трудно читать, и
он заставляет меня переосмыслить, как рассказать историю первых 4
лет жизни каждого президента ...
Шаг 4: Анимация этих данных
Как показал предыдущий график, 14 президентов - это слишком много, чтобы показать на одном графике, потому что становится очень трудно сравнивать, когда он загроможден. Поэтому, поскольку я хотел сосредоточиться на сравнении прошлого президентского одобрения с Трампом, я сосредоточился на создании сюжетов с двумя линиями (рассматриваемый президент и Дональд Трамп). Я также буду анимировать его, чтобы вы могли увидеть разницу в прогрессе между президентом, которого я сравниваю с Трампом, с течением времени. Для этого я создаю функцию, ключевую часть кодирования на R!
Функция выполняет несколько задач:
- Во-первых, он создает вектор всех имен президента, кроме Трампа. Это позволяет нам создать цикл и цикл по всем именам каждого президента.
- Затем создается цикл, который фильтрует данные о Дональде Трампе и рассматриваемом президенте и отображает данные в виде графика. Рейтинги одобрения Трампа показаны темно-красным цветом, а все остальные президентом показаны темно-синим цветом.
- Затем мы используем функцию
transition_reveal, чтобы анимировать каждый из этих созданных графиков. - Затем используйте функцию
animate, чтобы изменить размер и настройки анимации для каждого графика. - Затем создайте новую папку и сохраните в ней каждый анимированный сюжет.
- Цикл
forсделает это и создаст анимированный сюжет для каждого президента в исходном векторе.
Тада, у вас есть 12 анимационных сюжетов первых четырех лет каждого президентства за последние 75 лет! Также стоит отметить, что эта функция запускается через несколько минут, поэтому проявите терпение.
# Note that this function takes about two minutes to run on my machine. You can play with the frame rates, number of frames and the sizes as well to make it faster/ slower
president_linecharts <- function(x) {
# Vector of president names except Trump
compare_presidents <- unique(x[order(x$term.start),]$president)[-c(1,14)]
# A loop to produce ggplot2 graphs
for (i in seq_along(compare_presidents)) {
# make plots; note data = args in each geom
plot <- x %>%
filter(president=='Trump' | president==compare_presidents[i]) %>%
ggplot(aes(x=days_in_office, y=rolling_approval, group=president, colour=president)) +
geom_point(aes(group = seq_along(days_in_office)),
size = 1, alpha = 1, show.legend = FALSE) +
geom_line(size = 2, show.legend = FALSE) +
scale_color_manual(values = c("darkblue", "darkred")) +
scale_x_continuous(breaks=c(200, 400, 600, 800, 1000, 1200, 1400)) +
ylim(0,100) +
labs(x = "Day in Office",
y = "Presidential Approval Rating",
title = paste0("Trump's Approval Rating Compared to the First Term of \nEach President Dating Back to 1945"),
subtitle = "Donald Trump's approval rating remains lower on average than any president in recent history \nduring their first term. Check out all the comparisons for the past 75 years!") +
annotate(geom="text", x=c(1300, 1300), y=c(10,90),
label=c("Trump", compare_presidents[i]),
color=c("darkred", "darkblue"),
size = 10, fontface = 'bold', parse = TRUE) +
theme_bw() +
theme(plot.title = element_text(face="bold", size = 20),
plot.subtitle = element_text(face="bold", size = 12),
axis.title.x = element_text(face="bold", size = 15),
axis.title.y = element_text(face="bold", size = 15),
legend.position = "none")
# Animate the plot
animated.plot <- plot +
transition_reveal(along = days_in_office)
# Adjust the animation settings
animate(animated.plot,
width = 600, # 900px wide
height = 400, # 600px high
nframes = 30, # 30 frames
fps = 10) # 10 frames per second
# create folder to save the plots to
if (dir.exists("animations")) { }
else {dir.create("animations")}
# save plots to the 'output' folder
anim_save(filename = paste0("animations/",
compare_presidents[i],
"_comparison.gif"))
# print each plot to screen
print(plot)
}
}
president_linecharts(df)
Шаг 5: объединение GIF-файлов
На эту последнюю часть у меня ушло несколько часов! Как объединить несколько GIF-файлов в один?
Итак, после создания списка всех моих новых файлов анимированных сюжетов я прочитал в каждом анимированном сюжете GIF, используя функцию image_read, в порядке времени службы президента (от Трумэна до Обамы). Прочитав их, мы объединяем GIF-файлы с помощью функции image_join и сохраняем общий результат.
Это ключевая часть и то, что я узнал после нескольких часов исследований. Поскольку GIF, считанный в R, в значительной степени представляет собой фрейм данных, вы можете просто присоединиться к нему, как обычно, и он будет работать непрерывно. Стоит отметить, что заголовки останутся такими же, как и на первом графике, поэтому они не меняются, и поэтому я включаю имена президентов в график, а не в легенду.
# Create a list of all the animation files in the "animations" folder gif_list <- list.files(path="animations", pattern = '*.gif', full.names = TRUE) gif_list # Read in each gif from the folder by order of year (Truman to Obama) # I did this manually, although I'm sure there is a way to automate it... gif1 <- image_read(gif_list[12]) gif2 <- image_read(gif_list[5]) gif3 <- image_read(gif_list[8]) gif4 <- image_read(gif_list[7]) gif5 <- image_read(gif_list[9]) gif6 <- image_read(gif_list[6]) gif7 <- image_read(gif_list[3]) gif8 <- image_read(gif_list[11]) gif9 <- image_read(gif_list[2]) gif10 <- image_read(gif_list[4]) gif11 <- image_read(gif_list[1]) gif12 <- image_read(gif_list[10]) # Combine all the animated plot GIFs into one, in order of service date presidential_approval <- image_join(gif1, gif2, gif3, gif4, gif5, gif6, gif7, gif8, gif9, gif10, gif11, gif12) # Call your new GIF presidential_approval # Save your new GIF! image_write(presidential_approval, path = "presidential_approval.gif")
И вот оно! Таким образом вы создаете несколько анимированных графиков данных и объединяете их в один более длинный GIF. Не стесняйтесь изменять данные и настройки анимации и получайте удовольствие от того, как получается GIF.
В следующих двух постах я буду: 1) изучать сантимент-анализ Robinhood, очищая Twitter во время скандала с GameStop; и 2) оценка / визуализация одобрения руководства Джо Байдена в первый месяц его работы. Если вас это заинтересует, подпишитесь на меня, и я снова увижу вас в следующих нескольких постах!
Ссылки:
[1] FiveThirtyEight, Рейтинги одобрения Дональда Трампа, (2021 г.)
[2] Проект президентства США Утверждение должности президента (2021 г.)
Я консультант по моделированию и стратегии в Monitor Deloitte. Я использую статистику и аналитику для создания моделей цифровых двойников, которые заново изобретают подход компаний к стратегическим решениям. В свободное время я одержим политикой и политикой, постоянно веду блог на тему Политика в цифрах. Вы можете найти меня там или в моих учетных записях LinkedIn и Twitter (не стесняйтесь подключиться или подписаться на меня).
