条形相互超越的动画排序条形图
Animated sorted bar chart with bars overtaking each other
编辑：关键字是 'bar chart race'
你会如何在 R 中从 Jaime Albella 复制这张图表？
查看 visualcapitalist.com or on 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))
编辑：
John Murdoch 的另一个很酷的例子：
编辑：添加了样条插值以实现更平滑的过渡，而不会使等级变化发生得太快。代码在底部。
我已经改编了我的答案 。我喜欢将 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)
对于顶部更平滑的版本，我们可以在绘图步骤之前添加一个步骤来进一步插值数据。插值两次可能很有用，一次以粗略的粒度确定排名，另一次用于更精细的细节。如果排名计算得太精细，条形会很快交换位置。
gap_smoother <- gapminder %>%
filter(continent == "Asia") %>%
group_by(country) %>%
# Do somewhat rough interpolation for ranking
# (Otherwise the ranking shifts unpleasantly fast.)
complete(year = full_seq(year, 1)) %>%
mutate(gdpPercap = spline(x = year, y = gdpPercap, xout = year)$y) %>%
group_by(year) %>%
mutate(rank = min_rank(-gdpPercap) * 1) %>%
ungroup() %>%
# Then interpolate further to quarter years for fast number ticking.
# Interpolate the ranks calculated earlier.
group_by(country) %>%
complete(year = full_seq(year, .5)) %>%
mutate(gdpPercap = spline(x = year, y = gdpPercap, xout = year)$y) %>%
# "approx" below for linear interpolation. "spline" has a bouncy effect.
mutate(rank = approx(x = year, y = rank, xout = year)$y) %>%
ungroup() %>%
arrange(country,year)
然后剧情用了一些修改的台词，其他都一样：
p <- ggplot(gap_smoother, ...
# This line for the numbers that tick up
geom_text(aes(y = gdpPercap,
label = scales::comma(gdpPercap)), hjust = 0, nudge_y = 300 ) +
...
labs(title='{closest_state %>% as.numeric %>% floor}',
x = "", y = "GFP per capita") +
...
transition_states(year, transition_length = 1, state_length = 0) +
enter_grow() +
exit_shrink() +
ease_aes('linear')
animate(p, fps = 20, duration = 5, width = 400, height = 600, end_pause = 10)
到目前为止，这是我在很大程度上基于@Jon 的回答得出的结论。
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 线移动和淡出来模拟移动网格，这要归功于 alpha 参数在接近 1000 亿时发生变化。
要让标签在年份之间改变值（这在原始图表中给人一种很好的紧迫感）我认为我们别无选择，只能在插入标签的同时乘以行，我们也需要插入排名。
然后通过一些小的外观更改，我们应该非常接近。
这就是我的想法，我只是使用 Jon 和 Moody 代码作为模板，并进行了一些改动。
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 秒，这很慢。您可以根据需要更改持续时间并使其变快或变慢。
编辑：关键字是 'bar chart race'
你会如何在 R 中从 Jaime Albella 复制这张图表？
查看 visualcapitalist.com or on 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))
编辑：
John Murdoch 的另一个很酷的例子：
编辑：添加了样条插值以实现更平滑的过渡，而不会使等级变化发生得太快。代码在底部。
我已经改编了我的答案 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)
对于顶部更平滑的版本，我们可以在绘图步骤之前添加一个步骤来进一步插值数据。插值两次可能很有用，一次以粗略的粒度确定排名，另一次用于更精细的细节。如果排名计算得太精细，条形会很快交换位置。
gap_smoother <- gapminder %>%
filter(continent == "Asia") %>%
group_by(country) %>%
# Do somewhat rough interpolation for ranking
# (Otherwise the ranking shifts unpleasantly fast.)
complete(year = full_seq(year, 1)) %>%
mutate(gdpPercap = spline(x = year, y = gdpPercap, xout = year)$y) %>%
group_by(year) %>%
mutate(rank = min_rank(-gdpPercap) * 1) %>%
ungroup() %>%
# Then interpolate further to quarter years for fast number ticking.
# Interpolate the ranks calculated earlier.
group_by(country) %>%
complete(year = full_seq(year, .5)) %>%
mutate(gdpPercap = spline(x = year, y = gdpPercap, xout = year)$y) %>%
# "approx" below for linear interpolation. "spline" has a bouncy effect.
mutate(rank = approx(x = year, y = rank, xout = year)$y) %>%
ungroup() %>%
arrange(country,year)
然后剧情用了一些修改的台词，其他都一样：
p <- ggplot(gap_smoother, ...
# This line for the numbers that tick up
geom_text(aes(y = gdpPercap,
label = scales::comma(gdpPercap)), hjust = 0, nudge_y = 300 ) +
...
labs(title='{closest_state %>% as.numeric %>% floor}',
x = "", y = "GFP per capita") +
...
transition_states(year, transition_length = 1, state_length = 0) +
enter_grow() +
exit_shrink() +
ease_aes('linear')
animate(p, fps = 20, duration = 5, width = 400, height = 600, end_pause = 10)
到目前为止，这是我在很大程度上基于@Jon 的回答得出的结论。
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 线移动和淡出来模拟移动网格，这要归功于 alpha 参数在接近 1000 亿时发生变化。
要让标签在年份之间改变值（这在原始图表中给人一种很好的紧迫感）我认为我们别无选择，只能在插入标签的同时乘以行，我们也需要插入排名。
然后通过一些小的外观更改，我们应该非常接近。
这就是我的想法，我只是使用 Jon 和 Moody 代码作为模板，并进行了一些改动。
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"))