SpreadsheetDrawingCode.R

drawTable =
  ## Function for drawing a matrix or dataframe
  ## to look a bit like how it would be drawn in
  ## a spreadsheet software like Excel.
  ## Args:
  ## --datamat--
  ##
  ## --rows/cols (numeric)--
  ## numeric vector specifying which rows and cols to draw
  ## Default: NULL (draw all)
  ##
  ## --highmat (matrix)--
  ## a matrices of the same dimensions as datamat,
  ## each cell containing a list of length 1,
  ## containing a character vector of any length,
  ## that specifies the background colour of a portion
  ## of the matching cell, depending on the length of the vector
  ## length = 1 will be full background
  ## length = 2 means [1] gives left half, [2] gives right half, etc.
  ## Default: NULL (use white background for all)
  ##
  ## --labwidth (numeric)--
  ## numeric vector specifying width of the row number labels
  ## as a proportion of data-cell widths
  ## Default: 0.5
  ##
  ## --colNotNum (numeric)--
  ## numeric vector specifying columns that should never
  ## be formatted as numbers
  ## Default: NULL (any cell that can be coerced to a number
  ##                will be formatted as a number)
  ##
  ## --digits--
  ## passed to 'formatC' function for number formatting
  ## numbers are formatted as "f" (floats)
  ## Default: 0 (no decimal places)
  function(datamat, rows = NULL, cols = NULL, highmat = NULL,
           labwidth = 0.5, colNotNum = NULL, digits = 0){
    datamat = as.matrix(datamat)
    if(is.null(rows))
      rows = 1:nrow(datamat)
    else{
      if(max(rows) > nrow(datamat)){
        extramat = matrix(NA, nrow = max(rows) - nrow(datamat),
          ncol = ncol(datamat))
        datamat = rbind(datamat, extramat)
      }
      if(!is.null(highmat))
        if(max(rows) > nrow(highmat)){
          extramat = matrix(NA, nrow = max(rows) - nrow(highmat),
            ncol = ncol(highmat))
          highmat = rbind(highmat, extramat)
        }
    }
    if(is.null(cols))
      cols = 1:ncol(datamat)
    else{
      if(max(cols) > ncol(datamat)){
        extramat = matrix(NA, nrow = nrow(datamat),
          ncol = max(cols) - ncol(datamat))
        datamat = cbind(datamat, extramat)
      }
      if(!is.null(highmat))
        if(max(cols) > ncol(highmat)){
          extramat = matrix(NA, nrow = nrow(highmat),
            ncol = max(cols) - ncol(highmat))
          highmat = cbind(highmat, extramat)
        }
    }
    
    ## Define Colours
    labelbg = "#EEEEEE"
    bordercol = "#777777"
    
    ## Start plot
    opar = par(mar = rep(0, 4), bg = "white")
    on.exit(par(opar))
    xlim = c(0.5 - labwidth, length(cols) + 0.5)
    ylim = c(length(rows) + 0.5, -0.5)
    plot.new()
    plot.window(xlim = xlim, xaxs = "i",
                ylim = ylim, yaxs = "i")
    
    ## Draw rows/cols numbers
    ## Background
    rect(0.5 - labwidth, -0.5, labwidth, ylim[1], border = NA,
         col = labelbg)
    rect(0.5, -0.5, xlim[2], 0.5, border = NA, col = labelbg)
    ## Text
    text(0.5 - labwidth/2, (1:length(rows)) + 0.25, rows,
         col = bordercol, adj = c(0.5, 0))
    text(1:length(cols), 0.25, cols, col = bordercol, adj = c(0.5, 0))

    ## Draw cells
    ## textx = rep((1:length(cols)) - 0.45, each = length(rows))
    ## texty = rep(1:length(rows), times = length(cols))
    ## text(textx, texty, datamat, adj = 0)
    textx = (1:length(cols)) - 0.45
    texty = (1:length(rows)) + 0.25
    for(j in 1:length(textx)){
      for(i in 1:length(texty)){
        curcell = datamat[rows[i], cols[j]]
        if(is.null(highmat)){
          ## If cell isn't empty, white out cell first
          if(!is.na(curcell))
            rect(textx[j] - 0.05, texty[i] - 0.75,
                 textx[j] + 0.95, texty[i] + 0.25,
                 col = "white", border = NA)
        } else{
          ## Highlight every cell according to highmat
          curcol = highmat[rows[i], cols[j]][[1]]
          if(!all(is.na(curcol))){
            for(colpart in 1:length(curcol))
              rect(textx[j] - 0.05 + (colpart - 1) * 1/length(curcol),
                   texty[i] - 0.75,
                   textx[j] - 0.05 + colpart * 1/length(curcol),
                   texty[i] + 0.25,
                   col = curcol[colpart],
                   border = NA)
          } else if(!is.na(curcell))
            rect(textx[j] - 0.05, texty[i] - 0.75,
                 textx[j] + 0.95, texty[i] + 0.25,
                 col = "white", border = NA)
        }
        ## Check if it might be a number, in which case format appropriately
        ## By default, digits = 0 (so rounded to whole number)
        ccnumer = suppressWarnings(as.numeric(curcell))
        if(!is.na(ccnumer) && !any(j == colNotNum)){
          curcell = formatC(ccnumer, format = "f", big.mark = ",", digits = digits)
          ## Then draw cell (right-just)
          text(textx[j] + 0.9, texty[i], curcell, adj = c(1, 0))
        } else{
          ## Then draw cell (left-just)
          text(textx[j], texty[i], curcell, adj = c(0, 0))
        }
      }
    }

    ## Draw bounding boxes (intelligently)
    ## Rows always drawn
    segments(xlim[1], -1:length(rows) + 0.5, xlim[2], col = bordercol)
    ## Cols only drawn if it doesn't clash with a cell
    segments(c(0.5 - c(labwidth, 0), xlim[2]), ylim[2], y1 = ylim[1],
             col = bordercol)
    ## Compute overflow of cells into next col
    overfl = apply(datamat, 2, function(x){
      out = strwidth(x) + 0.1
      out[is.na(x)] = NA
      out
    })
    ## Construct overflow logical, taking into account various rules
    overflT = matrix(FALSE, nrow = nrow(overfl), ncol = ncol(overfl))
    for(j in 1:(ncol(overfl) - 1)){
      for(i in 1:nrow(overfl))
        ## If current cell is not empty
        ##    AND next cell is empty,
        ## Then, If current cell > 1
        ## compute max cells overflow can occur and loop
        if(!is.na(overfl[i, j]) && is.na(overfl[i, j + 1]))
          if(overfl[i, j] > 1){
            maxoverfl = min(floor(overfl[i, j]), ncol(overfl) - j)
            for(addj in 1:maxoverfl)
              if(all(is.na(overfl[i, (j + 1):(j + addj)])))
                overflT[i, j - 1 + addj] = TRUE
          }
      ## If no overflow, draw single line
      ## Else draw piece-wise
      if(all(!overflT[, j]))
        segments(j + 0.5, ylim[2], y1 = ylim[1], col = bordercol)
      else{
        ystarts = c(ylim[2], (1:nrow(overfl))[overflT[,j]] + 0.5)
        yends = c((1:nrow(overfl))[overflT[,j]] - 0.5, ylim[1])
        segments(j + 0.5, ystarts, y1 = yends, col = bordercol)
      }
    }
    
  }

drawTableSize =
  ## Given a datamat, compute the appropriate device size
  ##  for a good looking table using drawTable.
  ## Args:
  ## --datamat, rows, cols--
  ## same as drawTable
  ## --cellwidth--
  ## width of the cells in in
  ## --labwidth--
  ## width of row label column, as a proportion of cellwidth
  function(datamat, rows = NULL, cols = NULL, cellwidth = 0.9,
           labwidth = 0.5){
    datamat = as.matrix(datamat)
    if(is.null(rows))
      rows = 1:nrow(datamat)
    else if(max(rows) > nrow(datamat)){
      extramat = matrix("", nrow = max(rows) - nrow(datamat),
        ncol = ncol(datamat))
      datamat = rbind(datamat, extramat)
    }
    if(is.null(cols))
      cols = 1:ncol(datamat)
    else if(max(cols) > ncol(datamat)){
      extramat = matrix("", nrow = nrow(datamat),
        ncol = max(cols) - ncol(datamat))
      datamat = cbind(datamat, extramat)
    }

    nlines = (length(rows) + 1) * 1.1
    height = nlines * par("csi")
    width = (length(cols) + labwidth) * cellwidth
    dev.off()
    list(width = width, height = height)
  }

drawTableFront =
  ## Front-end that takes care of sizing
  ## if pdfout != NULL, output will be to pdf
  function(datamat, rows = NULL, cols = NULL, ...,
           cellwidth = 0.9, labwidth = 0.5, pdfout = NULL){
    size = drawTableSize(datamat, rows = rows, cols = cols,
      cellwidth = cellwidth, labwidth = labwidth)
    if(!is.null(pdfout)){
      pdf(pdfout, width = size$width, height = size$height)
      on.exit(dev.off())
    } else{
      windows(width = size$width, height = size$height)
    }
    drawTable(datamat, rows = rows, cols = cols, labwidth = labwidth, ...)
  }