5

我想将几个不同的 ggplot 图放到一个图像中。经过大量探索，我发现如果数据格式正确，ggplot 在生成单个图或一系列图方面非常出色。但是，当您想要组合多个绘图时，有很多不同的选项可以将它们组合起来，这会让人感到困惑并且很快就会令人费解。我对我的最终情节有以下愿望：

  1. 所有单个图的左轴对齐，以便所有图都可以共享最底部图存在的公共 x 轴
  2. 情节右侧有一个常见的图例（最好位于情节顶部附近）
  3. 前两个指标图没有任何 y 轴抽动或数字
  4. 地块之间有最小的空间
  5. 指标图（isTraining 和 isTesting）占用较少的垂直空间，以便其余三个图可以根据需要填充空间

我已经搜索了满足上述要求的解决方案，但它只是无法正常工作。下面的代码做了很多这样的事情（尽管可能以一种令人费解的方式），但未能满足我上面列出的要求。以下是我的具体问题：

  1. 我发现对齐图左侧的代码由于某种原因无法正常工作
  2. 我目前用来在同一页面上获取多个图的方法似乎很难使用，而且很可能有更好的技术（我愿意接受建议）
  3. x 轴标题未显示在结果中
  4. 图例没有对齐情节的顶部（我根本不知道这样做的简单方法，所以我没有尝试过。欢迎提出建议）

任何解决这些问题的帮助将不胜感激。

自包含代码示例

（有点长，但对于这个问题，我认为可能会有奇怪的互动）

# Load needed libraries ---------------------------------------------------

library(ggplot2)
library(caret)
library(grid)

rm(list = ls())

# Genereate Sample Data ---------------------------------------------------

N = 1000
classes = c('A', 'B', 'C', 'D', 'E')
set.seed(37)
ind   = 1:N
data1 = sin(100*runif(N))
data2 = cos(100*runif(N))
data3 = cos(100*runif(N)) * sin(100*runif(N))
data4 = factor(unlist(lapply(classes, FUN = function(x) {rep(x, N/length(classes))})))
data = data.frame(ind, data1, data2, data3, Class = data4)
rm(ind, data1, data2, data3, data4, N, classes)

# Sperate into smaller datasets for training and testing ------------------

set.seed(1976)
inTrain <- createDataPartition(y = data$data1, p = 0.75, list = FALSE)
data_Train = data[inTrain,]
data_Test  = data[-inTrain,]
rm(inTrain)

# Generate Individual Plots -----------------------------------------------

data1_plot = ggplot(data) + theme_bw() + geom_point(aes(x = ind, y = data1, color = Class))
data2_plot = ggplot(data) + theme_bw() + geom_point(aes(x = ind, y = data2, color = Class))
data3_plot = ggplot(data) + theme_bw() + geom_point(aes(x = ind, y = data3, color = Class))
isTraining = ggplot(data_Train) + theme_bw() + geom_point(aes(x = ind, y = 1, color = Class))
isTesting = ggplot(data_Test) + theme_bw() + geom_point(aes(x = ind, y = 1, color = Class))


# Set the desired legend properties before extraction to grob -------------

data1_plot = data1_plot + theme(legend.key = element_blank())

# Extract the legend from one of the plots --------------------------------

getLegend<-function(a.gplot){
  tmp <- ggplot_gtable(ggplot_build(a.gplot))
  leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box")
  legend <- tmp$grobs[[leg]]
  return(legend)}

leg = getLegend(data1_plot)


# Remove legend from other plots ------------------------------------------

data1_plot = data1_plot + theme(legend.position = 'none')
data2_plot = data2_plot + theme(legend.position = 'none')
data3_plot = data3_plot + theme(legend.position = 'none')
isTraining = isTraining + theme(legend.position = 'none')
isTesting = isTesting + theme(legend.position = 'none')



# Remove the grid from the isTraining and isTesting plots -----------------

isTraining = isTraining + theme(panel.grid.minor=element_blank(), panel.grid.major=element_blank())
isTesting = isTesting + theme(panel.grid.minor=element_blank(), panel.grid.major=element_blank())


# Remove the y-axis from the isTraining and the isTesting Plots -----------

isTraining = isTraining + theme(axis.ticks = element_blank(), axis.text = element_blank())
isTesting = isTesting + theme(axis.ticks = element_blank(), axis.text = element_blank())


# Remove the margin from the plots and set the XLab to null ---------------

tmp = theme(panel.margin = unit(c(0, 0, 0, 0), units = 'cm'), plot.margin = unit(c(0, 0, 0, 0), units = 'cm'))
data1_plot = data1_plot + tmp + labs(x = NULL, y = 'Data 1')
data2_plot = data2_plot + tmp + labs(x = NULL, y = 'Data 2')
data3_plot = data3_plot + tmp + labs(x = NULL, y = 'Data 3')
isTraining = isTraining + tmp + labs(x = NULL, y = 'Training')
isTesting = isTesting + tmp + labs(x = NULL, y = 'Testing')


# Add the XLabel back to the bottom plot ----------------------------------

data3_plot = data3_plot + labs(x = 'Index')

# Remove the X-Axis from all the plots but the bottom one -----------------
# data3 is to the be last plot...

data1_plot = data1_plot + theme(axis.ticks.x = element_blank(), axis.text.x = element_blank())
data2_plot = data2_plot + theme(axis.ticks.x = element_blank(), axis.text.x = element_blank())
isTraining = isTraining + theme(axis.ticks.x = element_blank(), axis.text.x = element_blank())
isTesting = isTesting + theme(axis.ticks.x = element_blank(), axis.text.x = element_blank())


# Store plots in a list for ease of processing ----------------------------

plots = list()
plots[[1]] = isTraining
plots[[2]] = isTesting
plots[[3]] = data1_plot
plots[[4]] = data2_plot
plots[[5]] = data3_plot

# Fix the widths of the plots so that the left side of the axes align ----
# Note: This does not seem to function correctly....
# I tried to adapt from: 
#   http://stackoverflow.com/questions/13294952/left-align-two-graph-edges-ggplot

plotGrobs = lapply(plots, ggplotGrob)
plotGrobs[[1]]$widths[2:5]
maxWidth = plotGrobs[[1]]$widths[2:5]
for(i in length(plots)) {
  maxWidth = grid::unit.pmax(maxWidth, plotGrobs[[i]]$widths[2:5])
}
for(i in length(plots)) {
  plotGrobs[[i]]$widths[2:5] = as.list(maxWidth)
}

plotAtPos = function(x = 0.5, y = 0.5, width = 1, height = 1, obj) {
  pushViewport(viewport(x = x + 0.5*width, y = y + 0.5*height, width = width, height = height))
  grid.draw(obj)
  upViewport()
}

grid.newpage()
plotAtPos(x = 0, y = 0.85, width = 0.9, height = 0.1, plotGrobs[[1]])
plotAtPos(x = 0, y = 0.75, width = 0.9, height = 0.1, plotGrobs[[2]])
plotAtPos(x = 0, y = 0.5, width = 0.9, height = 0.2, plotGrobs[[3]])
plotAtPos(x = 0, y = 0.3, width = 0.9, height = 0.2, plotGrobs[[4]])
plotAtPos(x = 0, y = 0.1, width = 0.9, height = 0.2, plotGrobs[[5]])
plotAtPos(x = 0.9, y = 0, width = 0.1, height = 1, leg)

上面的视觉结果如下图所示：

上述代码的输出

4

1 回答 1

6

对齐 ggplots 应该使用rbind.gtable; 在这里它相当简单，因为 gtable 都具有相同数量的列。在我看来，使用 gtable 设置面板高度并在侧面添加图例也比使用网格视口更直接。

唯一轻微的烦恼是rbind.gtable 目前无法unit.pmax按要求设置宽度。不过很容易修复，请参阅rbind_max下面的功能。 在此处输入图像描述

require(gtable)
rbind_max <- function(...){

  gtl <- lapply(list(...), ggplotGrob)

  bind2 <- function (x, y) 
  {
    stopifnot(ncol(x) == ncol(y))
    if (nrow(x) == 0) 
      return(y)
    if (nrow(y) == 0) 
      return(x)
    y$layout$t <- y$layout$t + nrow(x)
    y$layout$b <- y$layout$b + nrow(x)
    x$layout <- rbind(x$layout, y$layout)
    x$heights <- gtable:::insert.unit(x$heights, y$heights)
    x$rownames <- c(x$rownames, y$rownames)
    x$widths <- grid::unit.pmax(x$widths, y$widths)
    x$grobs <- append(x$grobs, y$grobs)
    x
  }

  Reduce(bind2, gtl)
}



gp <- do.call(rbind_max, plots)
gp <- gtable_add_cols(gp, widths = sum(leg$widths))
panels <- gp$layout$t[grep("panel", gp$layout$name)]
# set the relative panel heights 1/3 for the top two
gp$heights[panels] <- lapply(c(1,1,3,3,3), unit, "null")
# set the legend justification to top (it's a gtable embedded in a gtable)
leg[["grobs"]][[1]][["vp"]] <- viewport(just = c(0.5,1))
gp <- gtable_add_grob(gp, leg, t = 1, l = ncol(gp))

grid.newpage()
grid.draw(gp)
于 2014-06-15T23:27:35.460 回答