R: remove duplicate row entries in gridExtra table

Question

Problem:

I create a table using the gridExtra package:

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

Output:

Question:

I would like to get rid of duplicate row entries and achieve coverage of entries that look like this (this image is a layout made using Photoshop):

Any ideas on how to achieve this programmatically in R?

Answer 1

I would use gtable and take advantage of a more flexible structure,

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

Answer 2

  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 

The two-step copy and assign process in df2[] preserves the dataframe structure. The duplicated fromLast parameter changes the "images" last in the sequence, not the first.

With a refined query, here is the code to calculate the positions for the first column:

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

Here is the code to create a v-matrix from your data:

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