Reproduce a 'The Economist' Chart with Dual Axis

Reproduce a 'The Economist' chart with dual axis

Of course, it can be done with gplot2 with some help from grid and gtable. I don't try to position the axis labels in the ggplots; rather the axis labels are drawn in their own grob, and then positioned into the gtable.

This draws on code from here, which in turn draws on code from here and from the cowplot package). (It requires a little more work to get nicely positioned tick marks and tick labels in the overlay plot drawn with ggplot2 version 2.1.0. Notice, for instance, they are left justified as in the original The Economist rendering.)

# Data
dat = read.csv(text = ",Russia,World
1996,0,423
1997,4,220
1998,1,221
1999,0,298
2000,0,322
2001,8,530
2002,6,466
2003,17,459
2004,25,562
2005,27,664
2006,33,760
2007,53,893
2008,87,1038
2009,32,761
2010,62,949
2011,101,1109
2012,96,1130
2013,110,1317
2014,111,1535
2015,88,1738", header  = TRUE)

rus <- dat[,1:2]
world <- dat[,-2]

# Packages
library(ggplot2)
library(gtable)
library(grid)

# The ggplots
p1 <- ggplot(rus, aes(X, Russia)) + 
  geom_line(colour = "#68382C", size = 1.5) + 
  scale_x_continuous("", breaks = c(1996, seq(2000, 2015, 5))) +
  scale_y_continuous("", lim = c(0, 200), expand = c(0, 0)) +
  theme_bw() +
  theme(panel.grid.minor = element_blank(), 
    panel.grid.major = element_line(color = "gray50", size = 0.5),
    panel.grid.major.x = element_blank(),
    axis.text.y = element_text(colour = "#68382C", size = 14),
    axis.text.x = element_text(size = 14),
    axis.ticks = element_line(colour = 'gray50'),
    panel.border = element_blank(),
    plot.margin = unit(c(40, 20, 80, 20), "pt"))

p2 <- ggplot(world, aes(X, World)) + 
  geom_line(colour = "#00a4e6", size = 1.5) +  
  scale_x_continuous("", breaks= c(1996, seq(2000, 2015, 5))) +
  scale_y_continuous("", lim = c(0, 2000), expand = c(0, 0)) +
  theme_bw() +
  theme(panel.grid.minor = element_blank(), 
    panel.grid.major = element_blank(),
    axis.text.y = element_text(colour = "#00a4e6", size = 14),
    axis.text.x = element_text(size = 14),
    axis.ticks = element_line(colour = 'gray50'),
    panel.border = element_blank(),
    panel.background = element_rect(fill = "transparent"))

# Get the plot grobs
g1 <- ggplotGrob(p1)
g2 <- ggplotGrob(p2)

# Get the location of the plot panel in g1
pp <- c(subset(g1$layout, name == "panel", se = t:r))

# Overlap panel for second plot on that of the first plot
g1 <- gtable_add_grob(g1, g2$grobs[[which(g2$layout$name == "panel")]], pp$t, pp$l, pp$b, pp$l)

# ggplot contains many labels that are themselves complex grob; 
# usually a text grob surrounded by margins.
# When moving the grobs from, say, the left to the right of a plot,
# make sure the margins and the justifications are swapped around.
# The function below does the swapping.
# Taken from the cowplot package:
# https://github.com/wilkelab/cowplot/blob/master/R/switch_axis.R 
hinvert_title_grob <- function(grob){

  # Swap the widths
  widths <- grob$widths
  grob$widths[1] <- widths[3]
  grob$widths[3] <- widths[1]
  grob$vp[[1]]$layout$widths[1] <- widths[3]
  grob$vp[[1]]$layout$widths[3] <- widths[1]

  # Fix the justification
  grob$children[[1]]$hjust <- 1 - grob$children[[1]]$hjust 
  grob$children[[1]]$vjust <- 1 - grob$children[[1]]$vjust 
  grob$children[[1]]$x <- unit(1, "npc") - grob$children[[1]]$x
  grob
}

# Get the y axis from g2 (axis line, tick marks, and tick mark labels)
index <- which(g2$layout$name == "axis-l")  # Which grob
yaxis <- g2$grobs[[index]]                  # Extract the grob

# yaxis is a complex of grobs containing the axis line, the tick marks, and the tick mark labels.
# The relevant grobs are contained in axis$children:
#   axis$children[[1]] contains the axis line;
#   axis$children[[2]] contains the tick marks and tick mark labels.

# Second, swap tick marks and tick mark labels
ticks <- yaxis$children[[2]]
ticks$widths <- rev(ticks$widths)
ticks$grobs <- rev(ticks$grobs)

# Third, move the tick marks
# Tick mark lengths can change. 
# A function to get the original tick mark length
# Taken from the cowplot package:
# https://github.com/wilkelab/cowplot/blob/master/R/switch_axis.R 
plot_theme <- function(p) {
  plyr::defaults(p$theme, theme_get())
}

tml <- plot_theme(p1)$axis.ticks.length   # Tick mark length
ticks$grobs[[1]]$x <- ticks$grobs[[1]]$x - unit(1, "npc") + tml

# Fourth, swap margins and fix justifications for the tick mark labels
ticks$grobs[[2]] <- hinvert_title_grob(ticks$grobs[[2]])

# Fifth, put ticks back into yaxis
yaxis$children[[2]] <- ticks

# Put the transformed yaxis on the right side of g1
g1 <- gtable_add_cols(g1, g2$widths[g2$layout[index, ]$l], pp$r)
g1 <- gtable_add_grob(g1, yaxis, pp$t, pp$r + 1, pp$b, pp$r + 1, clip = "off", name = "axis-r")

# Labels grob
left = textGrob("Number in Russia", x = 0, y = 1, just = c("left", "top"), gp = gpar(fontsize = 14, col =  "#68382C"))
right =  textGrob("Rest of World", x = 1, y = 1, just = c("right", "top"), gp = gpar(fontsize = 14, col =  "#00a4e6"))
labs = gTree("Labs", children = gList(left, right))

# New row in the gtable for labels - immediately above the panel
pos = g1$layout[grepl("panel", g1$layout$name), c('t', 'l')]
height = unit(3, "grobheight", left)
g1 <- gtable_add_rows(g1, height, pos$t-1)  

# Put the label in the new row
g1 = gtable_add_grob(g1, labs, t = pos$t-1, l = pos$l-1, r = pos$l+1)

# Remove a column y label
g1 = g1[, -2]

# Grey rectangle
rect = rectGrob(gp = gpar(col = NA, fill = "grey90"))

# Put the grey rectangles into the margin columns and rows
g1 = gtable_add_grob(g1, list(rect, rect), t = 1, b = length(g1$heights), l = c(1, length(g1$widths)))
g1 = gtable_add_grob(g1, list(rect, rect), t = c(1, length(g1$heights)), l = 1, r = length(g1$widths))

# Draw it
grid.newpage()
grid.draw(g1)

Wondering how to output a chart I saw in the economist magazine

I played around a little using only base plot functionality. This is the result:

Here is the code that produced it:

bigmacprice <- data.frame(
    country = c("Switzerland", "Brazil", "Euro area",
        "Canada", "Japan", "United States",
        "Britain", "Singapore", "South Korea",
        "South Africa", "Mexico", "Thailand",
        "Russia", "Malaysia", "China"),
    price = c(6.78, 5.26, 4.79, 4.18, 3.91, 3.71,
              3.63, 3.46, 3.03, 2.79, 2.58, 2.44,
              2.39, 2.25, 2.18)
)

plotbigmac <- function(mac, base = "United States", xlim = c(-40, 100)) {
    mac <- mac[order(mac$price),]
    base = which(mac$country == base)
    height <- (mac$price / mac[base, "price"] - 1) * 100
    par(bg = "#d0e0e7", col.main = "#262324", col.axis = "#393E46",
        mar = c(8, 8, 6, 6), las = 1)
    barplot(height, width = .1, space = .4,
        names.arg = mac$country, #cex.names = .8,
        col = "#01516c", border = "#7199a8", # border = "#577784",
        horiz = TRUE, xlim = c(-40, 100), axes = FALSE)
    axis(3, lty = 0)
    title(main = "Bunfight\nBig Mac index", col = "#393E46")

    abline(v = seq(-100, 100, 10), col = "white", lwd = 2)
    abline(v = 0, col = "#c8454e", lwd = 2)
    par(xpd = TRUE)
    for (i in 1:nrow(mac)) {
        rect(105, (i - 1) / 7, 118, i / 7 - 0.05,
        col = "white", border = "#7199a8")
        text(112, (i - 1) / 7 + 0.05, mac$price[i], cex = 0.8, col = "#393E46")
    }
    rect(-120, 2.5, -90, 3, col = "#c8454e", border = "#c8454e")
    text(-68, -.2, "Sources:", col = "#393E46")
    text(-64, -.3, "McDonald's;", col = "#393E46")
    text(-60, -.4, "The Economist", col = "#393E46")
}

plotbigmac(bigmacprice)

It might not be the exact match (ex. i don't know how to right align without calling text directly), and if you try to resize it the text will jump around, so you would have to tweak the parameters further to fit your needs. But it goes to show that you can get far with using only basic plot functionality in R.

EDIT: As was commented, the white stripes cross the bars. This is inevitable and cant be adjusted with another call to barplot since that would redraw the plot area. Thus we have to take a peek into the source-code of barplot and customize it for this purpose (love how easy this is in R). But now we have moved outside of the comfy basics in R (i.e. using built in barplot). Here is another go at it:

plotBigMac <- function(mac, base = "United States") {
    old.par <- par(no.readonly = TRUE)
    on.exit(par(old.par))
    # Create data:
    mac <- mac[order(mac$price),]
    base = which(mac$country == base)
    height <- (mac$price / mac[base, "price"] - 1) * 100
    # Costume 'barplot'
    NN <- length(height)
    width <- rep(1, length.out = NN)
    delta <- width / 2
    w.r <- cumsum(width + 0.5)
    w.m <- w.r - delta
    w.l <- w.m - delta
    xlim <- c(range(-.01 * height, height)[1], 100)
    ylim <- c(min(w.l), max(w.r))
    par(bg = "#d0e0e7", col.main = "#262324", col.axis = "#393E46",
        mar = c(8, 8, 6, 6), las = 1, cex = 0.9)
    plot.new()
    plot.window(xlim, ylim)
    abline(v = seq(-100, 100, 20), col = "white", lwd = 2)
    rect(0, w.l, height, w.r, col = "#01516c", border = "#7199a8", lwd = 1)

    # Lines and axis
    abline(v = 0, col = "#c8454e", lwd = 2)
    axis(3, axTicks(3), abs(axTicks(3)), lty = 0)
    axis(2, labels = mac$country, at = w.m, lty = 0)

    # Move outside of plot area
    par(xpd = TRUE)

    # Text misc.
    text(5, (w.l[base] + w.r[base]) / 2, "nil", font = 3)
    text(8, w.r[NN] + 2.3, "+")
    text(-8, w.r[NN] + 2.3, "-")

    # Create price boxes:
    rect(105, w.l, 125, w.r,
        col = "white", border = "#7199a8", lwd = 1)
    text(115, (w.r + w.l)/2, mac$price, cex = 0.8, col = "#393E46")

}

Which creates this:

how to create a bar chart with a dual axis?

I simplified your data a bit.

Using as.layer (also from latticeExtra) rather than doubleYScale:

library(lattice)
library(latticeExtra)      

  mydf <- data.frame(t=1:5,x=c(2,2,2,2,1),
             y=c(2,1,1,4,5),z=c(200,200,400,500,230))

    p1 <- barchart(x+y~t,mydf,stack=TRUE,horiz=FALSE,
       par.settings = simpleTheme(col = c('red', 'blue'),
                                           fill = c('red', 'blue'),
                                           alpha = c(0.2)),
                auto.key = TRUE)

    p2 <- xyplot(z~t,mydf,type="l")

    p1+as.layer(p2,x.same=TRUE,y.same=FALSE,outside=TRUE)

I trust it also works with lubridated objects and tibbles.

EDIT: to clarify as.layer is also in latticeExtra package and add the plot.

Re-labeling one axis on a dual-axis chart

You can label the primary axis using a labeller function that finds which driver was at each position on lap 0, and add a sec_axis instead of a dup_axis.

You can also use scale_y_reverse rather than using -pos to order the axis correctly:

dat %>% 
  ggplot(aes(x = lap, y = pos, color = name)) +
  geom_line() +
  scale_y_reverse(breaks = 1:3,
                  labels = function(x) {
                    dat$name[dat$lap == 0][order(dat$pos[dat$lap == 0])][x]
                    },
                  sec.axis = sec_axis(function(x) x, 
                                      breaks = 1:3, labels = label_ordinal())) +
  scale_x_continuous(breaks = pretty_breaks(3))

How does The Economist make these lines near the title using using ggplot?

This question is a mix of "how to annotate outside the plot area" and "how to annotate in npc coordinates". Therefore, I offer two options.

Both unfortunately require a bit of trial and error in order to correctly place the segment. For option 1, it is the y coordinate which we have to "guess", and for option 2 it's x!

In order to make y slightly less guess work, I tried an approach to position is relative to the default axis breaks. using the fabulous information from this answer. This is of course not necessary, one can also simply trial and error.

For option 2, I modified a function from user Allan Cameron's answer here. He mentions a way to figure out x and y, I guess one could use the title, and then place the annotation based on that.

library(ggplot2)

p <-
  ggplot(mtcars, aes(mpg, wt)) +
  geom_point() +
  ggtitle("lorem ipsum") +
  theme(plot.margin = margin(t = 1.5, unit = "lines")) # this is always necessary

# OPTION 1
# semi-programmatic approach to figure out y coordinates
y_defaultticks <- with(mtcars, labeling::extended(range(wt)[1], range(wt)[2], m = 5))
y_default <- y_defaultticks[2] - y_defaultticks[1] 
y_seg <- max(mtcars$wt) + 0.75 * y_default

p +
annotate(geom = "segment", x = - Inf, xend = 12, y = y_seg, yend = y_seg, 
         color = "red", size = 5) +
  coord_cartesian(clip = "off", ylim = c(NA, max(mtcars$wt)),
                  xlim = c(min(mtcars$mpg), NA)) 

# OPTION 2
annotate_npc <- function(x, y, height, width, ...) {
  grid::grid.draw(grid::rectGrob(
    x = unit(x, "npc"), y = unit(y, "npc"), height = unit(height, "npc"), width = unit(width, "npc"),
    gp = grid::gpar(...)
  ))
}

p
annotate_npc(x = 0.07, y = 1, height = 0.05, width = 0.05, fill = "red", col = NA)

^{Created on 2021-01-02 by the reprex package (v0.3.0)}

Create The Economist Style Plots in R?

Yes you have it in ggthemes (extension of ggplot2) with theme_economist and theme_economist_white.

For the bar plot, you will need to play with geom_bar and coord_flip (here)

Examples from ggthemes doc (here)

library("ggplot2")
library("ggthemes")

p <- ggplot(mtcars) +
     geom_point(aes(x = wt, y = mpg, colour = factor(gear))) +
     facet_wrap(~am) +
     # Economist puts x-axis labels on the right-hand side
     scale_y_continuous(position = "right")

## Standard
p + theme_economist() +
  scale_colour_economist()

## White
p + theme_economist_white() +
  scale_colour_economist()

How to reproduce the plot given in example

Since I cannot install SciencesPo package in my computer, I propose you a ggplot + ggthemes approach.

A good starting point might be the following approach. I use as an example the diamond dataset.

library(dplyr)
library(ggplot2)
library(ggthemes)

df <- diamonds %>%
  group_by(cut) %>%
  summarise(mean = mean(price), sigma = sd(price),
            n = n())
df <- df %>%
  mutate(int_minus = mean - 1.96*sigma/sqrt(n),
         int_plus = mean + 1.96*sigma/sqrt(n))

And then the plot

ggplot(df) +
  geom_segment(aes(x = int_minus, xend = int_plus, y = factor(cut), yend = factor(cut)), size = 2L, alpha = 0.4) +
  geom_point(aes(x = mean, y = factor(cut)), shape = 15, color = "blue", size = 4L) +
  theme_economist_white()

---

Related Topics