Анимированная гистограмма с пересекающимися столбцами

Question

Как вы будете воспроизводить этот график из Хайме Альбеллы в R?

См. Анимацию на visualcapitalist.com или на twitter (с несколькими ссылками в случае поломки одного).

Я отмечаю это как ggplot2 и gganimate, но все, что может быть получено из R., имеет значение.

данные (спасибо https://github.com/datasets/gdp)

gdp <- read.csv("https://raw.github.com/datasets/gdp/master/data/gdp.csv")
# remove irrelevant aggregated values
words <- scan(
  text="world income only total dividend asia euro america africa oecd",
  what= character())
pattern <- paste0("(",words,")",collapse="|")
gdp  <- subset(gdp, !grepl(pattern, Country.Name , ignore.case = TRUE))

Edit:

Еще один классный пример от Джона Мердока:

Самые густонаселенные города с 1500 по 2018

Answer 1

Это то, что я до сих пор придумал, основываясь на хорошей части ответа @ Джона.

p <- gdp  %>%
  # build rank, labels and relative values
  group_by(Year) %>%
  mutate(Rank = rank(-Value),
         Value_rel = Value/Value[Rank==1],
         Value_lbl = paste0(" ",round(Value/1e9)))  %>%
  group_by(Country.Name) %>%
  # keep top 10
  filter(Rank <= 10) %>%
  # plot
  ggplot(aes(-Rank,Value_rel, fill = Country.Name)) +
  geom_col(width = 0.8, position="identity") +
  coord_flip() + 
  geom_text(aes(-Rank,y=0,label = Country.Name,hjust=0)) +       #country label
  geom_text(aes(-Rank,y=Value_rel,label = Value_lbl, hjust=0)) + # value label
  theme_minimal() +
  theme(legend.position = "none",axis.title = element_blank()) +
  # animate along Year
  transition_states(Year,4,1)

animate(p, 100, fps = 25, duration = 20, width = 800, height = 600)

Я мог бы вернуться, чтобы улучшить его.

Движущуюся сетку можно смоделировать, удалив фактическую сетку и заставив geom_segment линии двигаться и исчезать благодаря изменению альфа-параметра при приближении к 100 млрд.

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

Тогда с небольшими косметическими изменениями мы должны быть довольно близки.

Answer 2

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

library(tidyverse)
library(gganimate)
library(gapminder)
theme_set(theme_classic())

gdp <- read.csv("https://raw.github.com/datasets/gdp/master/data/gdp.csv")
words <- scan(
  text="world income only total dividend asia euro america africa oecd",
  what= character())
pattern <- paste0("(",words,")",collapse="|")
gdp  <- subset(gdp, !grepl(pattern, Country.Name , ignore.case = TRUE))
colnames(gdp) <- gsub("Country.Name", "country", colnames(gdp))
colnames(gdp) <- gsub("Country.Code", "code", colnames(gdp))
colnames(gdp) <- gsub("Value", "value", colnames(gdp))
colnames(gdp) <- gsub("Year", "year", colnames(gdp))

gdp$value <- round(gdp$value/1e9)

gap <- gdp %>%
  group_by(year) %>%
  # The * 1 makes it possible to have non-integer ranks while sliding
  mutate(rank = min_rank(-value) * 1,
         Value_rel = value/value[rank==1],
         Value_lbl = paste0(" ",value)) %>%
  filter(rank <=10) %>%
  ungroup()

p <- ggplot(gap, aes(rank, group = country, 
                     fill = as.factor(country), color = as.factor(country))) +
  geom_tile(aes(y = value/2,
                height = value,
                width = 0.9), alpha = 0.8, color = NA) +
  geom_text(aes(y = 0, label = paste(country, " ")), vjust = 0.2, hjust = 1) +
  geom_text(aes(y=value,label = Value_lbl, hjust=0)) +
  coord_flip(clip = "off", expand = FALSE) +
  scale_y_continuous(labels = scales::comma) +
  scale_x_reverse() +
  guides(color = FALSE, fill = FALSE) +

  labs(title='{closest_state}', x = "", y = "GDP in billion USD",
       caption = "Sources: World Bank | Plot generated by Nitish K. Mishra @nitishimtech") +
  theme(plot.title = element_text(hjust = 0, size = 22),
        axis.ticks.y = element_blank(),  # These relate to the axes post-flip
        axis.text.y  = element_blank(),  # These relate to the axes post-flip
        plot.margin = margin(1,1,1,4, "cm")) +

  transition_states(year, transition_length = 4, state_length = 1) +
  ease_aes('cubic-in-out')

animate(p, 200, fps = 10, duration = 40, width = 800, height = 600, renderer = gifski_renderer("gganim.gif"))

Здесь я использую длительность 40 секунд, что медленно. Вы можете изменить продолжительность и сделать ее быстрее или медленнее, чем вам нужно.

Answer 3

Я адаптировал ответ на связанный вопрос . Мне нравится использовать geom_tile для анимированных баров, так как это позволяет вам перемещать позиции.

Я работал над этим до того, как вы добавили данные, но, как оказалось, использованные мной данные gapminder тесно связаны.

library(tidyverse)
library(gganimate)
library(gapminder)
theme_set(theme_classic())

gap <- gapminder %>%
  filter(continent == "Asia") %>%
  group_by(year) %>%
  # The * 1 makes it possible to have non-integer ranks while sliding
  mutate(rank = min_rank(-gdpPercap) * 1) %>%
  ungroup()

p <- ggplot(gap, aes(rank, group = country, 
                     fill = as.factor(country), color = as.factor(country))) +
  geom_tile(aes(y = gdpPercap/2,
                height = gdpPercap,
                width = 0.9), alpha = 0.8, color = NA) +

  # text in x-axis (requires clip = "off" in coord_*)
  # paste(country, " ")  is a hack to make pretty spacing, since hjust > 1 
  #   leads to weird artifacts in text spacing.
  geom_text(aes(y = 0, label = paste(country, " ")), vjust = 0.2, hjust = 1) +

  coord_flip(clip = "off", expand = FALSE) +
  scale_y_continuous(labels = scales::comma) +
  scale_x_reverse() +
  guides(color = FALSE, fill = FALSE) +

  labs(title='{closest_state}', x = "", y = "GFP per capita") +
  theme(plot.title = element_text(hjust = 0, size = 22),
        axis.ticks.y = element_blank(),  # These relate to the axes post-flip
        axis.text.y  = element_blank(),  # These relate to the axes post-flip
        plot.margin = margin(1,1,1,4, "cm")) +

  transition_states(year, transition_length = 4, state_length = 1) +
  ease_aes('cubic-in-out')

animate(p, fps = 25, duration = 20, width = 800, height = 600)