6

问题：

我使用gridExtra包创建了一个表：

require("gridExtra")

# Prepare data frame
col1 = c(rep("A", 3), rep("B", 2), rep("C", 5))
col2 = c(rep("1", 4), rep("2", 3), rep("3", 3))
col3 = c(1:10)
df = data.frame(col1, col2, col3)

# Create table
grid.arrange(tableGrob(df, show.rownames=F))

输出：

默认输出

问题：

我想摆脱重复的行条目并实现看起来像这样的跨越条目（此图像是用 Photoshop 制作的模型）：

期望的输出

任何想法如何在 R 中以编程方式实现这一点？

4

2 回答 2

5

我会使用 gtable，并利用它更灵活的框架，

在此处输入图像描述

require(gtable)
require(plyr)

## build a rectGrob with parameters
cellRect <- function(fill=NA) 
  rectGrob(gp=gpar(fill=fill, col=NA))

cellText <- function(label, colour="black", 
                     hjust=c("left", "center", "right"), ...) {
  hjust <- match.arg(hjust)
  x <- switch(hjust,
              "left" = 0,
              "center"=0.5,
              "right"=1)
  textGrob(label, x=x, hjust=x, gp=gpar(col=colour, ...))
}


rowMax_units <- function(m){
  do.call(unit.c, apply(m, 1, function(l)
    max(do.call(unit.c, lapply(l, grobHeight)))))
}

colMax_units <- function(m){
  do.call(unit.c, apply(m, 2, function(l)
    max(do.call(unit.c, lapply(l, grobWidth)))))
}

findHeights <- function(l)
  do.call(unit.c, lapply(l,grobHeight))
findWidths <- function(l)
  do.call(unit.c, lapply(l,grobWidth))

## NAs are used to indicate grobs that span multiple cells
gtable_colheader <- function(header, n = NULL, 
                             padding=unit(rep(5,5),"mm"), ...){

  type <- 2L
  if(is.null(n)) n <- max(apply(header, type, length))

  start <- alply(header, type, function(s) which(!is.na(s), TRUE))
  end <- llply(start, function(s) c(s[-1], n+1) - 1 )

  fixed <- rep(seq_along(start), sapply(start, length)) # t,b for rows, l,r for cols

  label <- header[!is.na(header)]

  d <- data.frame(label =  label,
                  start=unlist(start), end=unlist(end), fixed, fixed,
                  stringsAsFactors=FALSE)

  names(d) <- c("label","t","b","l","r")

  ## make grobs
  d$grobs <- lapply(d$label, cellText, hjust="center")
  d$widths <- lapply(d$grobs, grobWidth)
  d$heights <- lapply(d$grobs, grobHeight)

  widths <- dlply(d, names(d)[4], # t if type==1, l if type==2
                  function(d) width=do.call(unit.c, d$widths))
  heights <- dlply(d, names(d)[4],
                   function(d) heights=do.call(unit.c, d$heights))

  ## extract widths and heights relevant to the layout
  attr(d, "widths") <- do.call(unit.c, lapply(widths, max))
  attr(d, "heights") <- heights[[which(sapply(heights, length) == n)]]

  ## create gtable
  g <- gtable()
  g <- gtable_add_cols(g, attr(d,"widths") + padding[1])
  g <- gtable_add_rows(g, attr(d,"heights")+ padding[2])

  ## vertical/horizontal separators
  sgh <- segmentsGrob(x0 = unit(0, "npc"), y0 = unit(0, "npc"),
                      x1 = unit(1, "npc"), y1 = unit(0, "npc"),
                      gp=gpar(lwd=2, col="white"))
  sgv <- segmentsGrob(x0 = unit(1, "npc"), y0 = unit(0, "npc"),
                      x1 = unit(1, "npc"), y1 = unit(1, "npc"),
                      gp=gpar(lwd=2, col="white"))
  d2 <- subset(d, b < n)
  g <- with(d2, gtable_add_grob(g, replicate(length(d2$grobs), sgh, simplify=FALSE),
                                t, l, b, r, z=1, name="seph"))
  g <- gtable_add_grob(g, replicate(ncol(g)-1, sgv, simplify=FALSE),
                       t=1, b=nrow(g),l=seq.int(ncol(g)-1), z=1, name="sepv")
  g <- with(d, gtable_add_grob(g, grobs, t, l, b, r, z=0, name="text"))
  g <- gtable_add_grob(g, rectGrob(gp=gpar(fill="grey90", col="white")), t=1, l=1, 
                       b=nrow(g), r=ncol(g), z=-Inf, name="rect")
  g
}

v <- cbind(c("A", NA, NA, "B", NA, "C", NA, NA, NA, NA),
           c(1, NA, NA, NA, 2, NA, NA, 3, NA, NA),
           seq(1,10))
g2 <- gtable_colheader(v)
header <- paste0("col #",1:3)
head <- lapply(header, textGrob, gp=gpar(fontface="bold"))
w <- do.call(unit.c, lapply(header, stringWidth)) + unit(5, "mm")
h <- max(do.call(unit.c, lapply(head, grobHeight))) + unit(5, "mm")
hg <- gtable_matrix("header",  widths=w, heights=h,
                      grobs=matrix(head, nrow=1))

grid.newpage()
grid.draw(gtable:::rbind_gtable(hg, g2, size="first"))
于 2013-09-29T13:45:06.133 回答
4 
 require(grid)
 require(gridExtra)
   Loading required package: gridExtra

 df = data.frame(col1, col2, col3, stringsAsFactors=FALSE)
df2 <- df
df2[] <- lapply(df2, function(col) col <- ifelse( !duplicated(col, fromLast=TRUE), col, ""))
df2
#---------------
   col1 col2 col3
1               1
2               2
3     A         3
4          1    4
5     B         5
6               6
7          2    7
8               8
9               9
10    C    3   10
#-------------
 grid.arrange(tableGrob(df2, show.rownames=F))  # works

df2[]复制和分配以保留数据帧结构的两步过程。复制参数 fromLast 将“命中”更改为系列中的最后一个而不是第一个。

有了明确的要求，这里是计算第一列位置的代码：

> tapply(df[[1]], df[[1]], FUN=function(x) mean(seq_along(x)))
  A   B   C 
2.0 1.5 3.0

这是从您的数据创建 v-matrix 的代码：

v <- as.matrix( as.data.frame( lapply(df,function(col) 
             ifelse(!duplicated(col), as.character(col), NA)))  )
v
      col1 col2 col3
 [1,]    1    1    1
 [2,]   NA   NA    2
 [3,]   NA   NA    3
 [4,]    2   NA    4
 [5,]   NA    2    5
 [6,]    3   NA    6
 [7,]   NA   NA    7
 [8,]   NA    3    8
 [9,]   NA   NA    9
[10,]   NA   NA   10
  g2 <- gtable_colheader(v)
 header <- colnames(v)
 head <- lapply(header, textGrob, gp=gpar(fontface="bold"))
 w <- do.call(unit.c, lapply(header, stringWidth)) + unit(5, "mm")
 h <- max(do.call(unit.c, lapply(head, grobHeight))) + unit(5, "mm")
 hg <- gtable_matrix("header",  widths=w, heights=h,
                       grobs=matrix(head, nrow=1))

 grid.newpage()
 grid.draw(gtable:::rbind_gtable(hg, g2, size="first"))
于 2013-09-28T17:25:10.027 回答