Time series charts by the Economist in R using Plotly

July 11, 2016
By

(This article was first published on R – Modern Data, and kindly contributed to R-bloggers)

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/[email protected]/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:", trends$Date, "
", "From US:", trends$From.US, "
") hovertext2 <- paste0("Date:", trends$Date, "
", "From Britain:", trends$From.Britain, "
") 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("1", "3"), 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("2", "4"), 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("1", "2", "3", "4"), 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 = "Your home and native land?", 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 = "Google search volume for 'Move to Canada'
100 is peak volume
Note that monthly averages are used
", 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 = "George W. Bush is re-elected", 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 = "Canadian minister visits Britain, ecourages skilled workers to move", 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 = "Super tuesday: Donald Trump wins 7 out of 11 republican primaries", 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 = "Britain votes 52-48% to leave the Europen Union", 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 = "Annual immigration to Canada", 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 = "Source: 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 The economist', 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("Year: ", plot.df$Time.Period, "
", "Est.: ", round(plot.df$All.ages.estimate/1e6,2),"M
", "Lower est.: ", round(plot.df$All.ages.lower.estimate/1e6,2),"M
", "Upper est.: ", 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("Year: ", plot.df$Time.Period, "
", "Est.: ", round(plot.df$All.ages.estimate/1e6,2),"M
", "Lower est.: ", round(plot.df$All.ages.lower.estimate/1e6,2),"M
", "Upper est.: ", 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("Year:", x, "
", "Est.: ", 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 = "Keeping the pressure up
Worldwide, (in millions)
", 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 = "Source: UNAIDS", 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 = "New HIV Infections(per year)", 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 = "AIDS related deaths (per year)", 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 = "People receving Anti-
Retroviral Therapy (total)
", 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 The economist', 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 = "Lower bound", 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 = "Higher bound", 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 = "Estimate", 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 on topics such as: Data science, Big Data, R jobs, visualization (ggplot2, Boxplots, maps, animation), programming (RStudio, Sweave, LaTeX, SQL, Eclipse, git, hadoop, Web Scraping) statistics (regression, PCA, time series, trading) and more...



If you got this far, why not subscribe for updates from the site? Choose your flavor: e-mail, twitter, RSS, or facebook...

Comments are closed.

Sponsors

Never miss an update!
Subscribe to R-bloggers to receive
e-mails with the latest R posts.
(You will not see this message again.)

Click here to close (This popup will not appear again)