How to add an arrow to lines in R to indicate the passage of time (CC138)
If you want to make it super easy for your audience to see the temporal direction of a trend, add an arrow to the lines in the figure! Using the ggplot2 R package this can be done by adding the arrow argument to geom_line, geom_path, and geom_segment. We’ll make our own geom_arrow function! In this episode of Code Club, Pat continues to morph a figure he made that was originally creaed by Ipsos to a more stylized one published by chartr. The data depict the percentage of people in 15 countries who would be willing to receive the COVID-19 vaccine as of August and October of 2020.
Pat uses functions from the tidyverse including functions from the ggplot2, dplyr, ggtext and glue packages in RStudio.
Code
Final R script
library(tidyverse)
library(glue)
library(ggtext)
data <- read_csv("august_october_2020.csv") %>%
rename(country = X.1,
percent_august = "Total Agree - August 2020",
percent_october = "Total Agree - October 2020") %>%
mutate(bump_august = case_when(percent_august < percent_october ~
percent_august - 2,
percent_august > percent_october ~
percent_august + 2,
TRUE ~ NA_real_),
bump_october = case_when(percent_august < percent_october ~
percent_october + 2,
percent_august > percent_october ~
percent_october - 2,
TRUE ~ percent_october + 2),
y_position = rev(1:nrow(.)))
strip_data <- data %>%
select(country, y_position) %>%
mutate(xmin = 50, xmax=100,
ymin = y_position - 0.5,
ymax = y_position + 0.5,
fill = c("c", rep(c("a", "b"), length.out=nrow(.)-1))) %>%
pivot_longer(cols=c(xmin, xmax), values_to="x", names_to="xmin_xmax") %>%
select(-xmin_xmax)
arrows_data <- data %>%
filter(abs(percent_august - percent_october) > 1) %>%
mutate(midpoint = (percent_august + 2*percent_october)/3) %>%
select(country, y_position, percent_august, midpoint) %>%
pivot_longer(c(percent_august, midpoint), names_to="type", values_to="x")
data %>%
pivot_longer(cols = -c(country, y_position),
names_to=c(".value", "month"),
names_sep = "_") %>%
drop_na() %>%
ggplot(aes(x=percent, y=y_position, color=month, group=y_position)) +
geom_ribbon(data = strip_data,
aes(x = x, ymin=ymin, ymax = ymax, group=y_position, fill=fill),
inherit.aes = FALSE) +
geom_line(color="#e6e6e6", size=1.75, show.legend = FALSE) +
geom_path(data=arrows_data, aes(x=x, y=y_position, group=y_position),
color="red",
arrow = arrow(angle = 30, length=unit(0.1, "in"), type="open"),
show.legend = FALSE,
inherit.aes = FALSE) +
geom_point(size=2, show.legend = FALSE) +
geom_text(aes(label=glue("{percent}%"), x=bump),
size=3,
show.legend = FALSE) +
scale_color_manual(name=NULL,
breaks=c("august", "october"),
values=c("#727272", "#15607a"),
labels=c("August", "October")) +
scale_x_continuous(limits=c(50, 100),
breaks=seq(50, 100, by=5),
labels=glue("{seq(50, 100, 5)}%"),
expand = c(0, 0)) +
scale_y_continuous(breaks = c(data$y_position, 0.5, data$y_position+0.5),
labels = c(data$country, rep("", length(data$y_position)+1)),
expand = c(0, 0),
limits=c(0.5, 16.5)) +
labs(x=NULL, y=NULL,
title="If a vaccine for COVID-19 were available, I would get it",
caption="<i>Base: 18,526 online adults aged 16-74 across 15 countries</i>
<br>Source: Ipsos")+
theme(
plot.title.position = "plot",
plot.title = element_text(face="bold", margin= margin(b=20)),
plot.caption = element_markdown(hjust=0, color="darkgray"),
plot.caption.position = "plot",
panel.background = element_blank(),
axis.ticks.x = element_blank(),
axis.ticks.y = element_line(color = c(rep(NA, nrow(data)),
rep("darkgray", nrow(data)+1)),
size=0.2),
axis.text.x = element_text(color="darkgray"),
axis.line = element_line(color="darkgray", size=0.2)
)
ggsave("august_october_2020_chartr.tiff", width=6, height=4)
Initial R script
library(tidyverse)
library(glue)
library(ggtext)
data <- read_csv("august_october_2020.csv") %>%
rename(country = X.1,
percent_august = "Total Agree - August 2020",
percent_october = "Total Agree - October 2020") %>%
mutate(bump_august = if_else(percent_august < percent_october,
percent_august - 2,
percent_august + 2),
bump_october = if_else(percent_august < percent_october,
percent_october + 2,
percent_october - 2))
strip_data <- data %>%
select(country) %>%
mutate(y_position = 1:nrow(.),
ymin = y_position - 0.5,
ymax = y_position + 0.5,
xmin = 50,
xmax = 100,
fill = c(rep(c("a", "b"), length.out=15), "c")
) %>%
pivot_longer(cols=c(xmin, xmax), names_to="min_max", values_to="x")
data %>%
mutate(index = rev(1:nrow(data))) %>%
pivot_longer(cols = -c(country, index), names_to=c(".value", "month"),
names_sep = "_") %>%
mutate(country = factor(country, levels = rev(data$country))) %>%
ggplot(aes(x=percent, y=index, color=month, group=index)) +
geom_ribbon(data=strip_data, aes(x=x, ymin=ymin, ymax=ymax, fill=fill, group=country),
inherit.aes=FALSE) +
geom_line(color="#e6e6e6", size=1.75, show.legend = FALSE) +
geom_point(size=2, show.legend = FALSE) +
geom_text(aes(label=glue("{percent}%"), x=bump),size=3, show.legend = FALSE) +
scale_color_manual(name=NULL,
breaks=c("august", "october"),
values=c("#727272", "#15607a"),
labels=c("August", "October")) +
scale_x_continuous(limits=c(50, 100),
breaks=seq(50, 100, by=5),
labels=glue("{seq(50, 100, 5)}%"),
expand=c(0,0)) +
scale_y_continuous(limits=c(0.5, 16.5),
breaks=c(seq(1, 16, 1), seq(0.5, 16.5, 1)),
labels=c(rev(data$country), rep("", 17)),
expand=c(0,0)) +
coord_cartesian(clip="off") +
labs(x=NULL, y=NULL,
title="If a vaccine for COVID-19 were available, I would get it",
caption="<i>Base: 18,526 online adults aged 16-74 across 15 countries</i><br>Source: Ipsos")+
theme(
plot.title.position = "plot",
plot.title = element_text(face="bold", margin= margin(b=20)),
plot.caption = element_markdown(hjust=0, color="darkgray"),
plot.caption.position = "plot",
panel.background = element_blank(),
axis.text.x = element_text(color="darkgray"),
axis.ticks.x = element_blank(),
axis.ticks.y = element_line(color=c(rep(NA, 16), rep("darkgray", 17)), size=0.2),
axis.line = element_line(color="darkgray", size=0.2),
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_blank()
)
ggsave("august_october_2020_ipsos.tiff", width=6, height=4)
Data
X.1,Total Agree - August 2020,Total Agree - October 2020
Total,77,73
India,87,87
China,97,85
South Korea,84,83
Brazil,88,81
Australia,88,79
United Kingdom,85,79
Mexico,75,78
Canada,76,76
Germany,67,69
Japan,75,69
South Africa,64,68
Italy,67,65
Spain,72,64
United States,67,64
France,59,54