如何在 gridExtra::tableGrob 中添加多子列

Question

我正在尝试设计一个 R 函数，该函数将接受一个列表并绘制一个具有特殊格式的表格。

这是我的数据：

pottery <- list(
    `Llanederyn` = c( 14.4, 13.8, 14.6, 11.5, 13.8, 10.9, 10.1, 11.6, 11.1, 13.4, 12.4, 13.1, 12.7, 12.5 ),
    `Caldicot` = c( 11.8, 11.6 ),
    `Island Thorns` = c( 18.3, 15.8, 18.0, 18.0, 20.8 ),
    `Ashley Rails` = c( 17.7, 18.3, 16.7, 14.8, 19.1 )
)

myTableGrob( pottery )

这是我将数据输入的函数：

myTableGrob <- function( data, padding = unit( 4, 'mm' ), ... )
{
    mostRows <- max( sapply( data, length ) )
    dataDF <- data.frame( lapply( data, function( p ) {
            for ( aoc in (length( p ):mostRows)[-1] )
                p[aoc] <- ''
            return( p )
        } ), stringsAsFactors = FALSE, check.names = FALSE )

    preferredFont <- list( fontface = 'plain', fontfamily = 'Times', cex = φ )

    g <- tableGrob( dataDF, theme = ttheme_minimal(
            colhead = list( fg_params = preferredFont ),
            core = list( fg_params = preferredFont ) ),
        rows = NULL )

    g$colnames <- colnames( dataDF )

    g <- gtable_add_grob( g,
            grobs = segmentsGrob( name = 'segment',
                    y1 = unit( 0, 'npc' ),
                    gp = gpar( lty = 1, lwd = 1 ) ),
            t = 1, l = 1, r = ncol( g ) )

    g$widths <- unit( rep( (1/φ) / ncol( g ), ncol( g ) ), 'npc' )

    grid.newpage()
    grid.draw( g )
    return( invisible( g ) )
}

目前，此代码将创建下表：

我要找的桌子是这样的：

我找到了很多 good documentation 和 discussion，但没有什么对我想要完成的工作很有帮助。

另一方面，如果有人知道我可以从哪里获得有关 tableGrob 和 ttheme_default/ttheme_minimal 函数的更多信息，那也会派上用场。我不熟悉这些函数能够采用的参数，只是刚刚发现我可以给tthmeme_ 函数提供colhead 和core 参数来调用对grobs 子集的更改。也许我遗漏了与整个 grob 对象构造相关的内容？

谢谢。

--编辑--

我在这里创建了这个脚本，它创建了我所追求的矩阵版本。也许我可以从这个开始，直接使用 grobs 并创造一些富有成效的东西。

listToTableMatricies <- function( data, MAX_ROWS = 7, ... )
{
    mostRows <- max( sapply( data, function(d) {
        ifelse( length( d ) %/% MAX_ROWS > 0,
            MAX_ROWS, length( d ) %% MAX_ROWS )
        } ) )

    dataMod <- sapply( data, function( d ) {
        nc <- ( length( d ) %/% (MAX_ROWS + 1) ) + 1
        for ( aoc in (length( d ):(mostRows*nc))[-1] )
            d[aoc] <- NA
        return( matrix( d, nrow = mostRows, ncol = nc ) )
    } )

    return( dataMod )
}

--更新--

answer proposed by @baptiste 似乎非常接近。 （我希望格式更正，但是）我也在考虑使用下面的脚本，但我们不需要知道需要移动哪些列，也许我们可以搜索重复的列标题并将它们组合起来关于他们的号码：

tablePlot <- function( data, MAX_ROWS = 7, ... )
{
    mostRows <- max( sapply( data, function(d) {
        ifelse( length( d ) %/% MAX_ROWS > 0,
            MAX_ROWS, length( d ) %% MAX_ROWS )
        } ) )

    dataMod <- sapply( data, function( d ) {
        nc <- ( length( d ) %/% (MAX_ROWS + 1) ) + 1
        for ( aoc in (length( d ):(mostRows*nc))[-1] )
            d[aoc] <- NA
        newD <- c()
        for ( aoc in 1:length(d) )
            newD[aoc] <- ifelse( is.na( d[aoc] ), '', format( d[aoc], nsmall = 1 ) )
        return( matrix( newD, nrow = mostRows, ncol = nc ) )
    } )

    # dataMod <- unlist( lapply( data, function( col ) {
    #         split( col, seq_len( length(col) ) %/% (MAX_ROWS + 1) )
    #     } ), FALSE )

    dataDF <- data.frame( dataMod, stringsAsFactors = FALSE, check.names = FALSE )

    # dataDF <- as.data.frame( do.call( cbind.fill, dataMod ), stringsAsFactors = FALSE, check.names = FALSE )
    # colnames( dataDF ) <- c( '', names( data ) )

    preferredFont <- list( fontface = 'plain', fontfamily = 'Times', cex = φ/1.25 )

    g <- tableGrob( dataDF, theme = ttheme_minimal(
            colhead = list( fg_params = preferredFont ),
            core = list( fg_params = preferredFont ) ),
        rows = NULL )

    g$colnames <- colnames( dataDF )

    g <- gtable_add_grob( g,
            grobs = segmentsGrob( name = 'segment',
                    y1 = unit( 0, 'npc' ),
                    gp = gpar( lty = 1, lwd = 1 ) ),
            t = 1, l = 1, r = ncol( g ) )

    g$widths <- unit( rep( (1/φ) / ncol( g ), ncol( g ) ), 'npc' )

    id_cell <- function( table, row, col, name = 'colhead-fg' )
    {
        l <- table$layout
        which( l$t %in% row & l$l %in% col & l$name == name )
    }

    # id <- id_cell( g, 1, 2 )
    # g$layout[id, 'l'] <- g$layout[id, 'l'] - 1

    ### CODE TO SEARCH FOR REPEAT COLUMN HEADERS
    ###  Combine repeated column headers to some center
    ###  Delete other unneccessary column header text/rect grobs

    grid.newpage()
    grid.draw( g )
    return( dataMod )
    return( invisible( g ) )
}

Answer 1

这是一种格式化数据的方法，然后使列标题跨越两列（您可能想要微调列宽，这里全部相等）：

pottery <- list(
  `Llanederyn` = c( 14.4, 13.8, 14.6, 11.5, 13.8, 10.9, 10.1, 11.6, 11.1, 13.4, 12.4, 13.1, 12.7, 12.5 ),
  `Caldicot` = c( 11.8, 11.6 ),
  `Island Thorns` = c( 18.3, 15.8, 18.0, 18.0, 20.8 ),
  `Ashley Rails` = c( 17.7, 18.3, 16.7, 14.8, 19.1 )
)

# http://stackoverflow.com/questions/7962267/cbind-a-df-with-an-empty-df-cbind-fill

cbind.fill <- function(...){
  nm <- list(...) 
  nm <- lapply(nm, as.matrix)
  n <- max(sapply(nm, nrow)) 
  do.call(cbind, lapply(nm, function (x) 
    rbind(x, matrix("", n-nrow(x), ncol(x))))) 
}

pottery7 <- unlist(lapply(pottery, function(col) split(col, seq_len(length(col)) %/% 8)), FALSE)
tt <- as.data.frame(do.call(cbind.fill, pottery7))
colnames(tt) <- c("", names(pottery))

library(gridExtra)
tg <- tableGrob(tt, theme = ttheme_minimal(), rows = NULL)
tg$widths <- unit(rep(1/ncol(tg), ncol(tg)), "null")

id_cell <- function(table, row, col, name="colhead-fg"){
  l <- table$layout
  which(l$t %in% row & l$l %in% col & l$name==name)
}

id <- id_cell(tg, 1, 2)
tg$layout[id,"l"] <- tg$layout[id,"l"] - 1
grid.newpage()
grid.draw(tg)

Answer 2

我想出的解决方案如下：

tablePlot <- function( data, MAX_ROWS = 7, nsmall = 1, ... )
{
    # Find out the number of rows needed
    mostRows <- max( sapply( data, function(d) {
            min( length( d ), MAX_ROWS )
        } ) )

    # Convert data to strings
    data <- lapply( data, format, nsmall )

    # Create a list of matricies for each group
    dataMod <- lapply( data, function( d ) {
        nc <- (length( d ) %/% (MAX_ROWS) ) -
                (as.logical(length( d ) %% MAX_ROWS == 0)) + 1
        for ( aoc in (length( d ):(mostRows*nc))[-1] )
            d[aoc] <- ''
        return( matrix( d, nrow = mostRows, ncol = nc ) )
    } )

    # Track the number of subcolumns needed per group
    # groupSubColumns
    gsc <- lapply( dataMod, function(d) dim(d)[2] )

    dataDF <- data.frame( dataMod, stringsAsFactors = FALSE, check.names = FALSE )
    colnames( dataDF ) <- unlist( lapply( names( gsc ), function( g ) c( rep( '', gsc[[g]]-1), g ) ) )

    preferredFont <- list( fontface = 'plain', fontfamily = 'Times', cex = φ/1.25 )

    g <- tableGrob( dataDF, theme = ttheme_minimal(
            colhead = list( fg_params = preferredFont ),
            core = list( fg_params = preferredFont ) ),
        rows = NULL )

    # g$colnames <- colnames( dataDF )

    g <- gtable_add_grob( g,
            grobs = segmentsGrob( name = 'segment',
                    y1 = unit( 0, 'npc' ),
                    gp = gpar( lty = 1, lwd = 1 ) ),
            t = 1, l = 1, r = ncol( g ) )

    g$widths <- unit( rep( (1/φ) / ncol( g ), ncol( g ) ), 'npc' )

    id_cell <- function( table, row, col, name = 'colhead-fg' )
    {
        l <- table$layout
        which( l$t %in% row & l$l %in% col & l$name == name )
    }

    for( c in 1:length( colnames( dataDF ) ) )
    {
        colname <- colnames( dataDF )[c]
        if ( colname != '' )
        {
            id <- id_cell( g, 1, c )
            g$layout[id, 'l'] <- g$layout[id, 'l'] - ( gsc[[colname]] - 1 )
        }
    }

    grid.newpage()
    grid.draw( g )
    return( dataMod )
    return( invisible( g ) )
}

这个函数对于我想要采用的多子列方法来说更加健壮，尽管我遗憾地遗漏了我希望看到的格式。也就是说，使来自多子列组的数字更接近。除此之外，以下是脚本生成的一些数字：

感谢@baptiste，他帮助了这一发展。