R: удалить повторяющиеся записи строки в gridExtra таблице

Question

Проблема:

создать таблицу с помощью 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)) 

Выход:

Вопрос:

Я хотел бы избавиться от повторяющейся строки e ntries и достижения, охватывающие записи, которые выглядят следующим образом (это изображение макет сделано с Photoshop):

Любые идеи, как добиться этого программно в R?

Answer 1

I Would использовать 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")) 

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 

Два шага процесса копирования и присвоения df2[] сохраняет структуру dataframe. Дублированный параметр fromLast изменяет «образы» последним в последовательности, а не первой.

С осветленной просьбой, вот код для расчета позиции для первого столбца:

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

Вот код, чтобы создать V-матрицу из ваших данных:

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