用双轴重现"经济学人"图表

Question

用双轴重现"经济学人"图表

我试图从经济学家(左边的那个)复制这个图表.该图表绘制了左边y轴上俄罗斯亿万富翁的数量以及右边世界其他地区的亿万富翁数量.

为俄罗斯亿万富翁创建图表(p1).
为其他人创建图表(p2).
使用Kohske的代码组合p1并p2进入双y轴图表.

数据:(内容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

Run Code Online (Sandbox Code Playgroud)

码:

library(ggplot2)
library(gtable)
library(grid)
library(extrafont) # for Officiana font
dat <- read.csv("billionaire.csv")
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)

Run Code Online (Sandbox Code Playgroud)

用我选择的字体和颜色来格式化"俄罗斯数字"和"世界其他地方"的文本,我把它们放入ggtitle.但是在第3步将图表组合在一起后,标题p2就丢失了,所以这就是我得到的

我想要实现的是
1.在我选择的颜色和字体系列中添加文本"世界其他地方"(不是默认的Helvetica.)
2.在x轴上添加标签1996.

任何帮助表示赞赏.谢谢!

编辑:添加数据集和完整代码.
EDIT2:仅供参考,我得到了所有的Officiana字体从这里:http://people.oregonstate.edu/~hanshumw/Specie%20I.D./Signage%20Backup/FONT%20Officina%20full/
EDIT3:好吧,我终于如何通过摆弄网格级别的情节来使其工作

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

Run Code Online (Sandbox Code Playgroud)

把这个块放在前面ggsave(...),这是结果:

Answer 1

San*_*att 2

当然，这可以在和gplot2的帮助下完成。我不尝试在 ggplots 中定位轴标签；相反，轴标签在它们自己的 grob 中绘制，然后定位到 gtable 中。gridgtable

这借鉴了这里的代码，而后者又借鉴了这里和cowplot包中的代码）。（需要做更多的工作才能在使用ggplot22.1.0 版本绘制的叠加图中获得正确定位的刻度线和刻度标签。请注意，例如，它们与原始《经济学人》渲染中一样左对齐。）

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

Run Code Online (Sandbox Code Playgroud)

归档时间：	9 年，6 月前
查看次数：	1175 次
最近记录：	8 年，11 月前