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

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 )

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

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

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

there's no real documentation beyond [the wiki](https://github.com/baptiste/gridextra/wiki/tableGrob), unfortunately. If you want to dig deeper you'll have to look at the source code directly. — baptiste, Apr 25 '17 at 19:46
@baptiste that's what I think too. As far as making editing the gtable goes, do you know what the code for that would look like? And what I come up with might work, but it would certainly not be a catch all function if the number of values changed. — aaiezza, Apr 25 '17 at 20:32
see proposed idea below, and a possibly more robust formatting scheme — baptiste, Apr 25 '17 at 20:33
@baptiste It is much more robust now, thank you. Do you have thoughts on my question's update? — aaiezza, Apr 25 '17 at 21:15
it wouldn't be too hard but i don't have more time to spend on this today. Maybe ask a separate question and keep this one just to create the character matrix. — baptiste, Apr 25 '17 at 21:45

baptiste · Accepted Answer · 2017-04-25T20:30:44.617

1

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)

edited Apr 25 '17 at 20:30

answered Apr 25 '17 at 20:20

baptiste

75,767
19
198
294

I just ran it. This answer looks great! I'm a little disappointed that the spacing between the values would need manual adjustment. Honestly, this feels like it should be a _stock_ function somewhere… – aaiezza Apr 25 '17 at 20:40
1

the thing is, I've never had any use for tableGrob personally, so my incentive to implement not-so-well-defined features is rather low in general. Feel free to contribute however, but note that adjusting widths automatically becomes ill-defined as soon as you get cells spanning multiple columns. – baptiste Apr 25 '17 at 21:44
Thanks for your time @baptiste. I like the elegance of using `split` and `cbind.fill` in your solution, but it does not allow for me to reference the number of splits made on each group when later go to generalize the function. Using most of what you have here and my matrix splitting function, I'm able to make something general. – aaiezza Apr 26 '17 at 14:29
I don't really know what to mean by "reference the number of splits"; `split()` is definitely able to do the job programmatically, if you pass it a factor dividing into the right number of groups (7 here), and with `mapply` instead of `lapply` you could even change this number from one item to the next. – baptiste Apr 26 '17 at 19:32

score 0 · Answer 2 · edited Oct 25 '21 at 19:51

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

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

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.

you can alter the widths easily, `g$widths` is a grid unit vector, and you can assign values that are based e.g on the actual space needed for the digits using `g$widths <- tableGrob(dataDF, rows=NULL, cols=NULL)[["widths"]]`, i.e. without the column names. The problem becomes choosing between those widths, and the ones needed for the longer column headers that might extend further: there's no general solution to this problem and a strategy must be decided upon, e.g. stretch each subcolumn by the same amount. — baptiste, Apr 26 '17 at 19:53

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

2 Answers2

Linked