Time series charts by the Economist in R using Plotly
[This article was first published on R – Modern Data, and kindly contributed to R-bloggers]. (You can report issue about the content on this page here)
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.
In this post we’ll recreate two info graphics created by The Economist. The code uses the new Plotly 4.0 syntax.
Note: Plotly 4.0 has not been officially released yet. You can download the dev version using
devtools::install_github("ropensci/plotly@fix/nse")
Volume of google searches related to immigrating to Canada
library(plotly)
library(zoo)
# Trends Data
trends <- read.csv("https://cdn.rawgit.com/plotly/datasets/master/Move%20to%20Canada.csv", check.names = F, stringsAsFactors = F)
trends.zoo <- zoo(trends[,-1], order.by = as.Date(trends[,1], format = "%d/%m/%Y"))
trends.zoo <- aggregate(trends.zoo, as.yearmon, mean)
trends <- data.frame(Date = index(trends.zoo),
coredata(trends.zoo))
# Immigration Data
immi <- read.csv("https://cdn.rawgit.com/plotly/datasets/master/Canada%20Immigration.csv", stringsAsFactors = F)
labels <- format(as.yearmon(trends$Date), "%Y")
labels <- as.character(sapply(labels, function(x){
unlist(strsplit(x, "20"))[2]
}))
test <- labels[1]
for(i in 2:length(labels)){
if(labels[i] == test) {
labels[i] <- ""
}else{
test <- labels[i]
}
}
labels[1] <- "2004"
hovertext1 <- paste0("Date:<b>", trends$Date, "</b><br>",
"From US:<b>", trends$From.US, "</b><br>")
hovertext2 <- paste0("Date:<b>", trends$Date, "</b><br>",
"From Britain:<b>", trends$From.Britain, "</b><br>")
p <- plot_ly(data = trends, x = ~Date) %>%
# Time series chart
add_lines(y = ~From.US, line = list(color = "#00526d", width = 4),
hoverinfo = "text", text = hovertext1, name = "From US") %>%
add_lines(y = ~From.Britain, line = list(color = "#de6e6e", width = 4),
hoverinfo = "text", text = hovertext2, name = "From Britain") %>%
add_markers(x = c(as.yearmon("2004-11-01"), as.yearmon("2016-03-01")),
y = c(24, 44),
marker = list(size = 15, color = "#00526d"),
showlegend = F) %>%
add_markers(x = c(as.yearmon("2008-07-01"), as.yearmon("2016-07-01")),
y = c(27, 45),
marker = list(size = 15, color = "#de6e6e"),
showlegend = F) %>%
# Markers for legend
add_markers(x = c(as.yearmon("2005-01-01"), as.yearmon("2005-01-01")),
y = c(40, 33.33),
marker = list(size = 15, color = "#00526d"),
showlegend = F) %>%
add_markers(x = c(as.yearmon("2005-01-01"), as.yearmon("2005-01-01")),
y = c(36.67, 30),
marker = list(size = 15, color = "#de6e6e"),
showlegend = F) %>%
add_text(x = c(as.yearmon("2004-11-01"), as.yearmon("2016-03-01")),
y = c(24, 44),
text = c("<b>1</b>", "<b>3</b>"),
textfont = list(color = "white", size = 8),
showlegend = F) %>%
add_text(x = c(as.yearmon("2008-07-01"), as.yearmon("2016-07-01")),
y = c(27, 45),
text = c("<b>2</b>", "<b>4</b>"),
textfont = list(color = "white", size = 8),
showlegend = F) %>%
# Text for legend
add_text(x = c(as.yearmon("2005-01-01"), as.yearmon("2005-01-01"), as.yearmon("2005-01-01"), as.yearmon("2005-01-01")),
y = c(40, 36.67, 33.33, 30),
text = c("<b>1</b>", "<b>2</b>", "<b>3</b>", "<b>4</b>"),
textfont = list(color = "white", size = 8),
showlegend = F) %>%
# Bar chart
add_bars(data = immi, x = ~Year, y = ~USA, yaxis = "y2", xaxis = "x2", showlegend = F,
marker = list(color = "#00526d"), name = "USA") %>%
add_bars(data = immi, x = ~Year, y = ~UK, yaxis = "y2", xaxis = "x2", showlegend = F,
marker = list(color = "#de6e6e"), name = "UK") %>%
layout(legend = list(x = 0.8, y = 0.36, orientation = "h", font = list(size = 10),
bgcolor = "transparent"),
yaxis = list(domain = c(0.4, 0.95), side = "right", title = "", ticklen = 0,
gridwidth = 2),
xaxis = list(showgrid = F, ticklen = 4, nticks = 100,
ticks = "outside",
tickmode = "array",
tickvals = trends$Date,
ticktext = labels,
tickangle = 0,
title = ""),
yaxis2 = list(domain = c(0, 0.3), gridwidth = 2, side = "right"),
xaxis2 = list(anchor = "free", position = 0),
# Annotations
annotations = list(
list(xref = "paper", yref = "paper", xanchor = "left", yanchor = "right",
x = 0, y = 1, showarrow = F,
text = "<b>Your home and native land?</b>",
font = list(size = 18, family = "Balto")),
list(xref = "paper", yref = "paper", xanchor = "left", yanchor = "right",
x = 0, y = 0.95, showarrow = F,
align = "left",
text = "<b>Google search volume for <i>'Move to Canada'</i></b><br><sup>100 is peak volume<br><b>Note</b> that monthly averages are used</sup>",
font = list(size = 13, family = "Arial")),
list(xref = "plot", yref = "plot", xanchor = "left", yanchor = "right",
x = as.yearmon("2005-03-01"), y = 40, showarrow = F,
align = "left",
text = "<b>George W. Bush is re-elected</b>",
font = list(size = 12, family = "Arial"),
bgcolor = "white"),
list(xref = "plot", yref = "plot", xanchor = "left", yanchor = "right",
x = as.yearmon("2005-03-01"), y = 36.67, showarrow = F,
align = "left",
text = "<b>Canadian minister visits Britain, ecourages skilled workers to move</b>",
font = list(size = 12, family = "Arial"),
bgcolor = "white"),
list(xref = "plot", yref = "plot", xanchor = "left", yanchor = "right",
x = as.yearmon("2005-03-01"), y = 33.33, showarrow = F,
align = "left",
text = "<b>Super tuesday: Donald Trump wins 7 out of 11 republican primaries</b>",
font = list(size = 12, family = "Arial"),
bgcolor = "white"),
list(xref = "plot", yref = "plot", xanchor = "left", yanchor = "right",
x = as.yearmon("2005-03-01"), y = 30, showarrow = F,
align = "left",
text = "<b>Britain votes 52-48% to leave the Europen Union</b>",
font = list(size = 12, family = "Arial"),
bgcolor = "white"),
list(xref = "paper", yref = "paper", xanchor = "left", yanchor = "right",
x = 0, y = 0.3, showarrow = F,
align = "left",
text = "<b>Annual immigration to Canada</b>",
font = list(size = 12, family = "Arial")),
list(xref = "paper", yref = "paper", xanchor = "left", yanchor = "right",
x = 0, y = -0.07, showarrow = F,
align = "left",
text = "<b>Source:</b> Google trends and national statistics",
font = list(size = 12, family = "Arial")),
list(xref = "paper", yref = "paper", xanchor = "left", yanchor = "right",
x = 0.85, y = 0.98, showarrow = F,
align = "left",
text = 'Inspired by <a href = "http://www.economist.com/blogs/graphicdetail/2016/07/daily-chart">The economist</a>',
font = list(size = 12, family = "Arial"))),
paper_bgcolor = "#f2f2f2",
margin = list(l = 18, r = 30, t = 18),
width = 1024,height = 600)
print(p)
AIDS related Visualization
library(plotly)
library(zoo)
library(tidyr)
library(dplyr)
# Aids Data
df <- read.csv("https://cdn.rawgit.com/plotly/datasets/master/Aids%20Data.csv", stringsAsFactors = F)
# AIDS Related Deaths ####
plot.df <- df %>%
filter(Indicator == "AIDS-related deaths") %>%
filter(Subgroup %in% c("All ages estimate",
"All ages upper estimate",
"All ages lower estimate"))
# Munge
plot.df <- plot.df %>%
select(Subgroup, Time.Period, Data.Value) %>%
spread(Subgroup, Data.Value) %>%
data.frame()
hovertxt <- paste0("<b>Year: </b>", plot.df$Time.Period, "<br>",
"<b>Est.: </b>", round(plot.df$All.ages.estimate/1e6,2),"M<br>",
"<b>Lower est.: </b>", round(plot.df$All.ages.lower.estimate/1e6,2),"M<br>",
"<b>Upper est.: </b>", round(plot.df$All.ages.upper.estimate/1e6,2), "M")
# Plot
p <- plot_ly(plot.df, x = ~Time.Period, showlegend = F) %>%
add_lines(y = ~All.ages.estimate/1e6, line = list(width = 4, color = "#1fabdd"),
hoverinfo = "text", text = hovertxt) %>%
add_lines(y = ~All.ages.lower.estimate/1e6, line = list(color = "#93d2ef"),
hoverinfo = "none") %>%
add_lines(y = ~All.ages.upper.estimate/1e6, line = list(color = "#93d2ef"),
fill = "tonexty",
hoverinfo = "none")
# New HIV Infections ####
plot.df <- df %>%
filter(Indicator == "New HIV Infections") %>%
filter(Subgroup %in% c("All ages estimate",
"All ages upper estimate",
"All ages lower estimate"))
# Munge
plot.df <- plot.df %>%
select(Subgroup, Time.Period, Data.Value) %>%
spread(Subgroup, Data.Value) %>%
data.frame()
hovertxt <- paste0("<b>Year: </b>", plot.df$Time.Period, "<br>",
"<b>Est.: </b>", round(plot.df$All.ages.estimate/1e6,2),"M<br>",
"<b>Lower est.: </b>", round(plot.df$All.ages.lower.estimate/1e6,2),"M<br>",
"<b>Upper est.: </b>", round(plot.df$All.ages.upper.estimate/1e6,2), "M")
# Add to current plot
p <- p %>%
add_lines(data = plot.df, y = ~All.ages.estimate/1e6, line = list(width = 4, color = "#00587b"),
hoverinfo = "text", text = hovertxt) %>%
add_lines(data = plot.df, y = ~All.ages.lower.estimate/1e6, line = list(color = "#3d83a3"),
hoverinfo = "none") %>%
add_lines(data = plot.df, y = ~All.ages.upper.estimate/1e6, line = list(color = "#3d83a3"),
fill = "tonexty",
hoverinfo = "none")
# People receiving ART ####
x <- c(2010:2015)
y <- c(7501470, 9134270, 10935600, 12936500, 14977200, 17023200)
hovertxt <- paste0("<b>Year:</b>", x, "<br>",
"<b>Est.:</b> ", round(y/1e6,2), "M")
p <- p %>%
add_lines(x = x, y = y/1e6, line = list(width = 5, color = "#e61a20"),
yaxis = "y2",
hoverinfo = "text", text = hovertxt)
# Layout
p <- p %>%
layout(xaxis = list(title = "", showgrid = F, ticklen = 4, ticks = "inside",
domain = c(0, 0.9)),
yaxis = list(title = "", gridwidth = 2, domain = c(0, 0.9), range = c(-0.01, 4)),
yaxis2 = list(overlaying = "y", side = "right", showgrid = F, color = "#e61a20",
range = c(5,18)),
annotations = list(
list(xref = "paper", yref = "paper", xanchor = "left", yanchor = "right",
x = 0, y = 1, showarrow = F, align = "left",
text = "<b>Keeping the pressure up<br><sup>Worldwide, (in millions)</sup></b>",
font = list(size = 18, family = "Arial")),
list(xref = "paper", yref = "paper", xanchor = "left", yanchor = "right",
x = 0, y = -0.07, showarrow = F, align = "left",
text = "<b>Source: UNAIDS</b>",
font = list(size = 10, family = "Arial", color = "#bfbfbf")),
list(xref = "plot", yref = "plot", xanchor = "left", yanchor = "right",
x = 1995, y = 3.92, showarrow = F, align = "left",
text = "<b>New HIV Infections(per year)</b>",
font = list(size = 12, family = "Arial", color = "#00587b")),
list(xref = "plot", yref = "plot", xanchor = "left", yanchor = "right",
x = 1999, y = 1, showarrow = F, align = "left",
text = "<b>AIDS related deaths (per year)</b>",
font = list(size = 12, family = "Arial", color = "#1fabdd")),
list(xref = "plot", yref = "plot", xanchor = "left", yanchor = "right",
x = 2010, y = 3, showarrow = F, align = "left",
text = "<b>People receving Anti-<br>Retroviral Therapy (total)</b>",
font = list(size = 12, family = "Arial", color = "#e61a20")),
list(xref = "paper", yref = "paper", xanchor = "left", yanchor = "right",
x = 0.85, y = 0.98, showarrow = F,
align = "left",
text = 'Inspired by <a href = "http://www.economist.com/blogs/graphicdetail/2016/05/daily-chart-23">The economist</a>',
font = list(size = 12, family = "Arial")),
list(xref = "paper", yref = "paper", xanchor = "left", yanchor = "middle",
x = 0.375, y = 0.9, showarrow = F, align = "left",
text = "<b>Lower bound</b>",
font = list(size = 10, family = "Arial", color = "#8c8c8c")),
list(xref = "paper", yref = "paper", xanchor = "left", yanchor = "middle",
x = 0.375, y = 0.95, showarrow = F, align = "left",
text = "<b>Higher bound</b>",
font = list(size = 10, family = "Arial", color = "#8c8c8c")),
list(xref = "paper", yref = "paper", xanchor = "left", yanchor = "middle",
x = 0.485, y = 0.925, showarrow = F, align = "left",
text = "<b>Estimate</b>",
font = list(size = 10, family = "Arial", color = "#8c8c8c"))
),
shapes = list(
list(type = "rectangle",
xref = "paper", yref = "paper",
x0 = 0.45, x1 = 0.48, y0 = 0.9, y1 = 0.95,
fillcolor = "#d9d9d9",
line = list(width = 0)),
list(type = "line",
xref = "paper", yref = "paper",
x0 = 0.45, x1 = 0.48, y0 = 0.9, y1 = 0.9,
line = list(width = 2, color = "#8c8c8c")),
list(type = "line",
xref = "paper", yref = "paper",
x0 = 0.45, x1 = 0.48, y0 = 0.95, y1 = 0.95,
fillcolor = "#bfbfbf",
line = list(width = 2, color = "#8c8c8c")),
list(type = "line",
xref = "paper", yref = "paper",
x0 = 0.45, x1 = 0.48, y0 = 0.925, y1 = 0.925,
fillcolor = "#bfbfbf",
line = list(width = 2, color = "#404040"))),
height = 600,width = 1024)
print(p)
To leave a comment for the author, please follow the link and comment on their blog: R – Modern Data.
R-bloggers.com offers daily e-mail updates about R news and tutorials about learning R and many other topics. Click here if you're looking to post or find an R/data-science job.
Want to share your content on R-bloggers? click here if you have a blog, or here if you don't.