How to add multi-sub-columns in gridExtra::tableGr

Question

I'm attempting to engineer an R function that will accept a list and plot a table with specialized formatting.

Here is my data:

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 )

Here is the function I am feeding the data into:

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 )

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

    g <- tableGrob( dataDF, theme = ttheme_minimal(
            colhead = list( fg_params = prefferedFont ),
            core = list( fg_params = prefferedFont ) ),
        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 ) )
}

Currently, this code will create the following table:

The table I am going for however is this:

I've found a lot of good documentation and discussion but nothing that's been very helpful for what I'm trying to accomplish.

On another note, if someone knows where I can get more information on the tableGrob and ttheme_default/ttheme_minimal functions, that would come in handy too. I'm unfamiliar with the parameters these functions are able to take and only just discovered I could give the tthmeme_ functions the colhead and core parameter to invoke changes on subsets of grobs. Perhaps I am missing something related to the grob object construction as a whole?

Thanks.

--EDIT--

I created this script here that creates matrix versions of what I'm after. Perhaps I could start with this to work directly with the grobs and create something productive.

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

--UPDATE--

The answer proposed by @baptiste seems very close. (I would like the formatting corrected but) I was also thinking of using the following script, but instead of needing to know which columns needed to move over, perhaps we could search for repeating column headers and combine them on their numbers:

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

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

    g <- tableGrob( dataDF, theme = ttheme_minimal(
            colhead = list( fg_params = prefferedFont ),
            core = list( fg_params = prefferedFont ) ),
        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

The solution I came up with was the following:

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

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

    g <- tableGrob( dataDF, theme = ttheme_minimal(
            colhead = list( fg_params = prefferedFont ),
            core = list( fg_params = prefferedFont ) ),
        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 ) )
}

This function is much more robust for the multi-sub-column approach I wanted to take even though I've sadly left out the formatting that I would have liked to see. That being, bringing the numbers from a multi-sub-column group closer together. Aside from that, here are some figures generated with the script:

Shoutout to @baptiste who helped with this development.

Answer 2

here's a way to format the data, then make the column header span two columns (you would probably want to fine-tune the column widths, here all equal):

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)