drawar -4 years ago 243
R Question

# Reproduce a 'The Economist' chart with dual axis

I was trying to replicate this
chart from The Economist (the one on the left). The chart plots the number of billionaires in Russia on the left y-axis and the number of billionaires in rest of the world on the right.

1. Create the chart for Russian billionaires (
`p1`
).

2. Create the chart for the others (
`p2`
).

3. Combine
`p1`
and
`p2`
into a dual y-axis chart using the code by Kohske.

Data: (content of
`billionaire.csv`
)

``````,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
``````

Code:

``````library(ggplot2)
library(gtable)
library(grid)
library(extrafont) # for Officiana font
rus <- dat[,1:2]
world <- dat[,-2]

grid.newpage()
p1 <- ggplot(rus, aes(X, Russia)) + geom_line(colour = "#68382C", size = 1.5) + ggtitle("Number in Russia") +
ylim(0, 200) + labs(x="",y="") +
theme(#plot.margin = unit(c(2,1,0,0), "cm"),
panel.grid.minor = element_blank(),
panel.grid.major = element_line(color = "gray50", size = 0.5),
panel.grid.major.x = element_blank(),
text=element_text(family="ITCOfficinaSans LT Book"),
axis.text.y = element_text(colour="#68382C", size = 14),
axis.text.x = element_text(size = 14),
axis.ticks = element_line(colour = 'gray50'),
plot.title = element_text(hjust = -0.17, vjust=2.12, colour="#68382C", size = 14, family = "ITCOfficinaSans LT Bold"))

p2 <- ggplot(world, aes(X, World)) + geom_line(colour = "#00a4e6", size = 1.5) +  #ggtitle("Rest of world") +
ylim(0, 2000) + labs(x="",y="") +
theme(#plot.margin = unit(c(2,1,0,0), "cm"),
panel.grid.minor = element_blank(),
panel.grid.major = element_blank(),
text = element_text(family="ITCOfficinaSans LT Book"),
axis.text.y = element_text(colour="#00a4e6", size=14),
axis.text.x = element_text(size=14),
axis.ticks = element_blank(),
plot.title = element_text(hjust = 0.2, vjust=2.12, colour="#00a4e6", size = 14, family = "ITCOfficinaSans LT Bold"))

# Combining p1 and p2
g1 <- ggplot_gtable(ggplot_build(p1))
g2 <- ggplot_gtable(ggplot_build(p2))

pp <- c(subset(g1\$layout, name == "panel", se = t:r))
g <- gtable_add_grob(g1, g2\$grobs[[which(g2\$layout\$name == "panel")]], pp\$t,
pp\$l, pp\$b, pp\$l)

ia <- which(g2\$layout\$name == "axis-l")
ga <- g2\$grobs[[ia]]
ax <- ga\$children[[2]]
ax\$widths <- rev(ax\$widths)
ax\$grobs <- rev(ax\$grobs)

g <- gtable_add_cols(g, g2\$widths[g2\$layout[ia, ]\$l], length(g\$widths) - 1)
g <- gtable_add_grob(g, ax, pp\$t, length(g\$widths) - 1, pp\$b)
ggsave("plot.pdf",g, width=5, height=5)
``````

To format the texts "Number in Russia" and "Rest of the world" with my chosen font and color, I put them in
`ggtitle`
. But after combining the charts together in step 3 the title of
`p2`
is missing, so this is all I got

What I'm trying to achieve is

1. Add the text "Rest of world" in a color and font family of my choice (not the default Helvetica.)

2. Add the label 1996 on the x-axis.

Any help is appreciated. Thanks!

EDIT: Data set and full code added.

EDIT2: Just FYI, I got all the Officiana fonts from here: http://people.oregonstate.edu/~hanshumw/Specie%20I.D./Signage%20Backup/FONT%20Officina%20full/

EDIT3: Ok I finally how to make it work by fiddling with the plot at the grid level

``````g\$grobs[[8]]\$children\$GRID.text.526\$label <- c("Number in Russia", "Rest of World")
g\$grobs[[8]]\$children\$GRID.text.526\$gp\$col <- c("#68382C","#00a4e6")
g\$grobs[[8]]\$children\$GRID.text.526\$x <- unit(c(-0.175, 0.774), "npc")
``````

Put this chunk before
`ggsave(...)`
, and here's the result:

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
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

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 locations of the plot panels 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
height = unit(3, "grobheight", left)

# Put the label in the new row
g1 = gtable_add_grob(g1, labs, t=3, l=3, r=5)

# Turn off clipping in the plot panel
g1\$layout[which(g1\$layout\$name == "panel"), ]\$clip = "off"

# 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
for(i in c(1,5)) g1 = gtable_add_grob(g1, rect, t = 1, b = 7, l=i)
for(i in c(1,7)) g1 = gtable_add_grob(g1, rect, t = i, l = 1, r=5)

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

Recommended from our users: Dynamic Network Monitoring from WhatsUp Gold from IPSwitch. Free Download