Nothing
R/sisalTable.R
In sisal: Sequential Input Selection Algorithm
Defines functions
fgGrey
twoPartName
twoPartNameChar
leftRight.sisalTable
bottomTop.sisalTable
widthDetails.sisalTable
heightDetails.sisalTable
xDetails.sisalTable
yDetails.sisalTable
makeContent.sisalTable
validDetails.sisalTable
editDetails.sisalTable
tableMeasures
minConvertXY
sisalTable
Documented in
sisalTable
### File R/sisalTable.R
### This file is part of the sisal package for R.
###
### Copyright (C) 2015, 2020 Aalto University
###
### This program is free software; you can redistribute it and/or modify
### it under the terms of the GNU General Public License as published by
### the Free Software Foundation; either version 2 of the License, or
### (at your option) any later version.
###
### This program is distributed in the hope that it will be useful,
### but WITHOUT ANY WARRANTY; without even the implied warranty of
### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
### GNU General Public License for more details.
###
### A copy of the GNU General Public License is available at
### http://www.r-project.org/Licenses/
## Returns a grey value (as an R color string) that has largest
## minimum distance (best contrast) to bgLumas (numeric where 0 is
## black and 1 is white).
fgGrey <- function(bgLumas) {
distWhite <- min(1 - bgLumas)
distBlack <- min(bgLumas)
meanLuma <- mean(bgLumas)
distMean <- min(abs(meanLuma - bgLumas))
switch(which.max(c(distBlack, distWhite, distMean)),
"black", "white", rgb(meanLuma, meanLuma, meanLuma))
}
## A "standard" way of creating two-part names for viewports / grobs
twoPartName <- function(part1, part2) {
paste(format(part1, scientific = FALSE, trim = TRUE, justify = "none"),
format(part2, scientific = FALSE, trim = TRUE, justify = "none"),
sep=".")
}
## when both part1 and part2 are already character vectors
twoPartNameChar <- function(part1, part2) {
paste(part1, part2, sep=".")
}
### Drawing time auxiliary functions for sisalTable
leftRight.sisalTable <- function(x) {
X <- convertUnit(x[["x"]], unitTo = "inches", axisFrom = "x",
typeFrom = "location", valueOnly = TRUE)
hjust <- x[["internals"]][["hjust"]]
width <- convertUnit(x[["width"]], unitTo = "inches", axisFrom = "x",
typeFrom = "dimension", valueOnly = TRUE)
left <- X - width * hjust
right <- left + width
c(left, right)
}
bottomTop.sisalTable <- function(x) {
Y <- convertUnit(x[["y"]], unitTo = "inches", axisFrom = "y",
typeFrom = "location", valueOnly = TRUE)
vjust <- x[["internals"]][["vjust"]]
height <- convertUnit(x[["height"]], unitTo = "inches", axisFrom = "y",
typeFrom = "dimension", valueOnly = TRUE)
bottom <- Y - height * vjust
top <- bottom + height
c(bottom, top)
}
### S3 methods for sisalTable
## According to "frame" vignette, widthDetails and heightDetails
## should use absolute.size() which returns "null" units if the grob
## does not have an absolute size. I tried absolute.size(x$width),
## absolute.size(x$height), but that only gave an obscure error message:
##
## Error in UseMethod("absolute.units") :
## no applicable method for 'absolute.units' applied to an object of class "unit"
## > traceback()
## 19: FUN(X[[1L]], ...)
## 18: lapply(unit, absolute.units)
## 17: absolute.units.unit.list(unit$arg1)
## 16: absolute.units(unit$arg1)
## 15: unit.arithmetic("sum", absolute.units(unit$arg1))
## 14: absolute.units.unit.arithmetic(unit)
## 13: absolute.units(unit)
## 12: absolute.size(x$width)
## 11: widthDetails.sisalTable(x)
## 10: widthDetails(x)
##
## The error message does not make sense. The (partial) traceback
## isn't too helpful either. So, let's use convertUnit(unitTo =
## "inches") instead.
##
## * Advantage: gives the size of the grob, even if the size is not
## absolute (fixed). Seems reasonable to me.
##
## * Downside: does not work as discussed in the vignette. The
## vignette may be outdated, though. For example, contrary to what
## is stated in the vignette, neither widthDetails.rect() nor
## heightDetails.rect() uses absolute.size(), which gets very little
## use anywhere. Makes me wonder if there is a problem in
## absolute.size(), or if I have overlooked something.
##
## This was checked on R trunk SVN revision 61876.
widthDetails.sisalTable <- function(x, ...) {
convertUnit(x[["width"]], unitTo = "inches", axisFrom = "x",
typeFrom = "dimension")
}
heightDetails.sisalTable <- function(x, ...) {
convertUnit(x[["height"]], unitTo = "inches", axisFrom = "y",
typeFrom = "dimension")
}
## xDetails and yDetails methods of sisalTable are vectorized
## w.r.t. theta, but it may not be possible to take advantage of this
## through grid
xDetails.sisalTable <- function(x, theta, ...) {
leftRight <- leftRight.sisalTable(x)
bottomTop <- bottomTop.sisalTable(x)
width <- leftRight[2] - leftRight[1]
height <- bottomTop[2] - bottomTop[1]
X <- (leftRight[1] + leftRight[2]) / 2
Y <- (bottomTop[1] + bottomTop[2]) / 2
rGrob <- rectGrob(x = X, y = Y, width = width, height = height,
default.units = "inches")
do.call("unit.c", lapply(theta, function (x) xDetails(rGrob, x)))
}
yDetails.sisalTable <- function(x, theta, ...) {
leftRight <- leftRight.sisalTable(x)
bottomTop <- bottomTop.sisalTable(x)
width <- leftRight[2] - leftRight[1]
height <- bottomTop[2] - bottomTop[1]
X <- (leftRight[1] + leftRight[2]) / 2
Y <- (bottomTop[1] + bottomTop[2]) / 2
rGrob <- rectGrob(x = X, y = Y, width = width, height = height,
default.units = "inches")
do.call("unit.c", lapply(theta, function (x) yDetails(rGrob, x)))
}
makeContent.sisalTable <- function(x, ...) {
x2 <- x
## Edit content labels
internals <- x[["internals"]]
cellSide <- convertWidth(internals[["cellSide"]],
unitTo = "inches", valueOnly = TRUE)
nRows <- internals[["nRows"]]
nCols <- internals[["nCols"]]
nResize <- internals[["nResizeLabels"]]
if (nResize > 0) {
labelFS <- cellSide / internals[["labelDim"]]
labelsNotNA <- internals[["labelsNotNA"]]
nLabels <- length(labelsNotNA)
textNames <- internals[["textNames"]]
labelPars <- internals[["labelPars"]]
for (i in seq_along(labelPars)) {
labelPars[[i]][["fontsize"]] <- labelFS
}
labelMeasurements <-
dynTextGrob(internals[["labels"]], adjustJust = TRUE,
gp = labelPars, resize = FALSE,
takeMeasurements = TRUE)
labelJust <- numeric(nLabels)
justTmp <- labelMeasurements[["vjust"]]
labelJust[labelsNotNA] <- justTmp[1:nResize]
linearRowCol <- 0
for (Col in seq_len(nCols)) {
## Actual contents of the table
for (Row in seq_len(nRows)) {
labelsMod <- linearRowCol %% nLabels + 1
if (labelsNotNA[labelsMod]) {
thisName <- textNames[linearRowCol + 1]
labelPar <- gparToList(getGrob(x, thisName)[["gp"]])
labelPar[["fontsize"]] <- labelFS
x2 <- editGrob(x2, thisName,
gp = do.call("gpar", labelPar),
vjust = labelJust[labelsMod])
}
linearRowCol <- linearRowCol + 1
}
}
}
if (internals[["resizeAxes"]]) {
## Edit x axis labels
axesFS <- NULL
xAxisSide <- internals[["xAxisSide"]]
if (!is.null(xAxisSide)) {
xAxisSide <- convertHeight(xAxisSide,
unitTo = "inches", valueOnly = TRUE)
axesFS <- min(cellSide / internals[["xAxisWidth"]],
xAxisSide / internals[["xAxisHeight"]])
xAxisNotNA <- internals[["xAxisNotNA"]]
axesPar <- internals[["axesPar"]]
axesPar[["fontsize"]] <- axesFS
axesPar <- do.call("gpar", axesPar)
xNames <- internals[["xNames"]]
xMeasurements <-
dynTextGrob(internals[["xAxisLabels"]], resize = FALSE,
gp = axesPar, rotJust = TRUE,
rot = internals[["xAxisRot"]],
takeMeasurements = TRUE,
just = internals[["xAxisJust"]], adjustJust = TRUE)
hjust <- numeric(nCols)
vjust <- numeric(nCols)
hjust[xAxisNotNA] <- xMeasurements[["hjust"]]
vjust[xAxisNotNA] <- xMeasurements[["vjust"]]
xShift <- numeric(nCols)
yShift <- numeric(nCols)
xShift[xAxisNotNA] <- xMeasurements[["xShift"]]
yShift[xAxisNotNA] <- xMeasurements[["yShift"]]
nXAxis <- length(xAxisNotNA)
for (Col in seq_len(nCols)[xAxisNotNA]) {
xMod <- (Col - 1) %% nXAxis + 1
thisName <- xNames[Col]
thisGrob <- getGrob(x, thisName)
x2 <- editGrob(x2, thisName, gp = axesPar,
x=thisGrob[["x"]] + unit(xShift[xMod],"inches"),
y=thisGrob[["y"]] + unit(yShift[xMod],"inches"),
hjust = hjust[xMod], vjust = vjust[xMod])
}
}
## Edit y axis labels
yAxisSide <- internals[["yAxisSide"]]
if (!is.null(yAxisSide)) {
if (is.null(axesFS)) {
yAxisSide <- convertWidth(yAxisSide,
unitTo = "inches", valueOnly = TRUE)
axesFS <- min(cellSide / internals[["yAxisHeight"]],
yAxisSide / internals[["yAxisWidth"]])
axesPar <- internals[["axesPar"]]
axesPar[["fontsize"]] <- axesFS
axesPar <- do.call("gpar", axesPar)
}
yAxisNotNA <- internals[["yAxisNotNA"]]
yNames <- internals[["yNames"]]
yMeasurements <-
dynTextGrob(internals[["yAxisLabels"]], resize = FALSE,
gp = axesPar, rotJust = TRUE,
rot = internals[["yAxisRot"]],
takeMeasurements = TRUE,
just = internals[["yAxisJust"]], adjustJust = TRUE)
hjust <- numeric(nRows)
vjust <- numeric(nRows)
hjust[yAxisNotNA] <- yMeasurements[["hjust"]]
vjust[yAxisNotNA] <- yMeasurements[["vjust"]]
xShift <- numeric(nRows)
yShift <- numeric(nRows)
xShift[yAxisNotNA] <- yMeasurements[["xShift"]]
yShift[yAxisNotNA] <- yMeasurements[["yShift"]]
nYAxis <- length(yAxisNotNA)
for (Row in seq_len(nRows)[yAxisNotNA]) {
yMod <- (Row - 1) %% nYAxis + 1
thisName <- yNames[Row]
thisGrob <- getGrob(x, thisName)
x2 <- editGrob(x2, thisName, gp = axesPar,
x=thisGrob[["x"]] + unit(xShift[yMod],"inches"),
y=thisGrob[["y"]] + unit(yShift[yMod],"inches"),
hjust = hjust[yMod], vjust = vjust[yMod])
}
}
}
## Final edited grobTree
x2
}
validDetails.sisalTable <- function(x, ...) {
if (!inherits(x, "gTree")) {
stop("a sisalTable object must be a gTree")
}
slotNames <- names(x)
requiredNames <- c("width", "height", "vpLayout", "x", "y", "just",
"clip", "internals", "name", "gp", "vp")
## Testing that all slots are present
if (!all(requiredNames %in% slotNames)) {
stop("slots missing")
}
## Testing 'x', 'y', 'width', 'height', 'clip', 'just'
X <- x[["x"]]
Y <- x[["y"]]
width <- x[["width"]]
height <- x[["height"]]
if (!inherits(X, "unit") || !inherits(Y, "unit") ||
!inherits(width, "unit") || !inherits(height, "unit")) {
stop("'x', 'y', 'width' and 'height' must be grid units")
}
if (length(X) != 1 || length(Y) != 1 ||
length(width) != 1 || length(height) != 1) {
stop("'x', 'y', 'width' and 'height' must have one element each")
}
clip <- x[["clip"]]
if (!(length(clip) == 1 &&
((is.character(clip) && clip %in% c("on", "inherit", "off")) ||
(is.logical(clip) && is.finite(clip))))) {
stop("'clip' must be TRUE, FALSE, \"on\", \"inherit\" or \"off\"")
}
just <- x[["just"]]
if (!(((is.numeric(just) && all(is.finite(just))) ||
is.character(just)) && length(just) > 0 && length(just) < 3)) {
stop("'just' must be a finite numeric or character vector of length 1 or 2")
}
## Testing internal variables
internals <- x[["internals"]]
if (!is.list(internals)) {
stop(gettextf("'%s' must be a list", 'x[["internals"]]',
domain = "R-sisal"), domain = NA)
}
varNames <-
c("hjust", "vjust", "nResizeLabels", "resizeAxes", "labelDim",
"xAxisWidth", "xAxisHeight", "yAxisWidth", "yAxisHeight", "cellSide",
"xAxisSide", "yAxisSide", "nRows", "nCols", "labelsNotNA",
"xAxisNotNA", "yAxisNotNA", "labels", "labelPars", "axesPar",
"xAxisLabels", "yAxisLabels", "xAxisRot", "yAxisRot", "xAxisJust",
"yAxisJust", "textNames", "xNames", "yNames", "childVps")
if (!all(varNames %in% names(internals))) {
stop(gettextf("'%s' must have the required variables",
'x[["internals"]]', domain = "R-sisal"), domain = NA)
}
hjust <- internals[["hjust"]]
vjust <- internals[["vjust"]]
nResize <- internals[["nResizeLabels"]]
resizeAxes <- internals[["resizeAxes"]]
labelDim <- internals[["labelDim"]]
xAxisWidth <- internals[["xAxisWidth"]]
xAxisHeight <- internals[["xAxisHeight"]]
yAxisWidth <- internals[["yAxisWidth"]]
yAxisHeight <- internals[["yAxisHeight"]]
cellSide <- internals[["cellSide"]]
xAxisSide <- internals[["xAxisSide"]]
yAxisSide <- internals[["yAxisSide"]]
nRows <- internals[["nRows"]]
nCols <- internals[["nCols"]]
labelsNotNA <- internals[["labelsNotNA"]]
labels <- internals[["labels"]]
labelPars <- internals[["labelPars"]]
xAxisNotNA <- internals[["xAxisNotNA"]]
yAxisNotNA <- internals[["yAxisNotNA"]]
xAxisLabels <- internals[["xAxisLabels"]]
yAxisLabels <- internals[["yAxisLabels"]]
xAxisRot <- internals[["xAxisRot"]]
yAxisRot <- internals[["yAxisRot"]]
xAxisJust <- internals[["xAxisJust"]]
yAxisJust <- internals[["yAxisJust"]]
textNames <- internals[["textNames"]]
xNames <- internals[["xNames"]]
yNames <- internals[["yNames"]]
stopifnot(is.numeric(hjust), is.numeric(vjust), is.numeric(nResize),
is.logical(resizeAxes), is.numeric(labelDim),
is.numeric(xAxisWidth), is.numeric(xAxisHeight),
is.numeric(yAxisWidth), is.numeric(yAxisHeight),
inherits(cellSide, "unit"), is.numeric(nRows), is.numeric(nCols),
is.list(internals[["axesPar"]]), is.numeric(xAxisRot),
is.numeric(yAxisRot),
inherits(internals[["childVps"]], "vpList"))
stopifnot(length(hjust) == 1, length(vjust) == 1, length(nResize) == 1,
length(resizeAxes) == 1, length(labelDim) == 1,
length(xAxisWidth) == 1, length(xAxisHeight) == 1,
length(yAxisWidth) == 1, length(yAxisHeight) == 1,
length(cellSide) == 1, length(nRows) == 1, length(nCols) == 1,
length(xAxisRot) == 1, length(yAxisRot) == 1)
stopifnot(is.finite(hjust), is.finite(vjust),
is.finite(nResize) && nResize >= 0, is.finite(resizeAxes),
is.finite(labelDim) && labelDim >= 0,
is.finite(nRows) && nRows > 0, is.finite(nCols) && nCols > 0,
is.finite(xAxisRot), is.finite(yAxisRot))
stopifnot(!resizeAxes || is.null(xAxisSide) ||
(is.finite(xAxisWidth) && xAxisWidth >= 0 &&
is.finite(xAxisHeight) && xAxisHeight >= 0 &&
inherits(xAxisSide, "unit") && length(xAxisSide) == 1 &&
is.logical(xAxisNotNA) && length(xAxisNotNA) >= 1 &&
all(is.finite(xAxisNotNA)) && is.vector(xAxisLabels) &&
length(xAxisLabels) >= 1 && is.character(xNames) &&
length(xNames) == nCols))
stopifnot(!resizeAxes || is.null(yAxisSide) ||
(is.finite(yAxisWidth) && yAxisWidth >= 0 &&
is.finite(yAxisHeight) && yAxisHeight >= 0 &&
inherits(yAxisSide, "unit") && length(yAxisSide) == 1 &&
is.logical(yAxisNotNA) && length(yAxisNotNA) >= 1 &&
all(is.finite(yAxisNotNA)) && is.vector(yAxisLabels) &&
length(yAxisLabels) >= 1 && is.character(yNames) &&
length(yNames) == nRows))
stopifnot(length(xAxisJust) > 0,
is.character(xAxisJust) ||
(is.numeric(xAxisJust) && all(is.finite(xAxisJust))))
stopifnot(length(yAxisJust) > 0,
is.character(yAxisJust) ||
(is.numeric(yAxisJust) && all(is.finite(yAxisJust))))
if (nResize > 0) {
stopifnot(is.logical(labelsNotNA), is.finite(labelsNotNA),
is.character(textNames), length(textNames) == nRows * nCols,
is.list(labelPars), length(labelPars) >= 2,
vapply(labelPars, is.list, logical(1)),
is.vector(labels), length(labels) >= 2)
}
x
}
editDetails.sisalTable <- function(x, specs) {
x2 <- NextMethod("editDetails", x)
slotNames <- names(specs)
if ("internals" %in% slotNames) {
stop("'internals' must not be edited")
}
if (any(c("width", "height", "x", "y",
"just", "clip", "vpLayout") %in% slotNames)) {
internals <- x2[["internals"]]
parentVp <- viewport(x = x2[["x"]], y = x2[["y"]],
width = x2[["width"]], height = x2[["height"]],
just = x2[["just"]], clip = x2[["clip"]],
layout = x2[["vpLayout"]], name = "Parent")
x2 <- editGrob(x2, childrenvp = vpTree(parent = parentVp,
children = internals[["childVps"]]))
if ("just" %in% slotNames) {
x2[["internals"]][c("hjust", "vjust")] <- justHV(x2[["just"]])
}
}
x2
}
### Main functions
## Computes sizes of different graphical elements. Returns those and
## suggested relative space allocations for the various parts of a
## table (based on computed sizes and target ratios specified as
## arguments). All the gp* arguments should be (lists of) ordinary
## lists containing settings accepted by gpar().
tableMeasures <- function(xAxisLabels, yAxisLabels, labels, targetAxesRatio,
gpAxes = list(), gpLabels,
main, xlab, ylab, gpMain, gpLab, nRows, nCols,
targetMainRatio = 0.15, targetLabRatio = 0.15,
scaleLabels = FALSE, xlabExpand = 1, ylabExpand = 1,
mainExpand = 1, xAxisRot = 0, yAxisRot = 0,
xAxisJust, yAxisJust) {
nX <- length(xAxisLabels)
if (nX > 0) {
tmp <- dynTextGrob(xAxisLabels, gp = do.call("gpar", gpAxes),
rot = xAxisRot, rotJust = TRUE,
just = xAxisJust, takeMeasurements = TRUE,
adjustJust = TRUE)
xAxisWidth <- tmp[["sizingWidth"]]
xAxisHeight <- tmp[["sizingHeight"]]
xAxisNZ <- tmp[["nzDim"]]
} else {
xAxisWidth <- NA_real_
xAxisHeight <- NA_real_
xAxisNZ <- FALSE
}
nY <- length(yAxisLabels)
if (nY > 0) {
tmp <- dynTextGrob(yAxisLabels, gp = do.call("gpar", gpAxes),
rot = yAxisRot, rotJust = TRUE,
just = yAxisJust, takeMeasurements = TRUE,
adjustJust = TRUE)
yAxisWidth <- tmp[["sizingWidth"]]
yAxisHeight <- tmp[["sizingHeight"]]
yAxisNZ <- tmp[["nzDim"]]
} else {
yAxisWidth <- NA_real_
yAxisHeight <- NA_real_
yAxisNZ <- FALSE
}
labelCex <- 0
nLabels <- length(labels)
for (i in seq_along(gpLabels)) {
cexTemp <- gpLabels[[i]][["cex"]]
if (is.null(cexTemp)) {
labelCex <- max(1, labelCex)
} else {
labelCex <- max(cexTemp, labelCex)
}
}
mfs <- dynTextGrob(c(labels, "x"), adjustJust = TRUE,
gp = c(gpLabels, list(list())), takeMeasurements = TRUE)
labelDim <- max(unlist(mfs[c("sizingWidth", "sizingHeight")]))
tmpSeq <- seq_len(nLabels)
labelNZ <- mfs[["nzDim"]][tmpSeq]
if (length(main) > 0) {
tmp <- dynTextGrob(main, gp = gpMain, takeMeasurements = TRUE)
maxMainWidth <- tmp[["sizingWidth"]]
maxMainHeight <- tmp[["sizingHeight"]]
mainNZ <- tmp[["nzDim"]]
} else {
maxMainWidth <- NA_real_
maxMainHeight <- NA_real_
mainNZ <- FALSE
}
if (length(xlab) > 0) {
tmp <- dynTextGrob(xlab, gp = gpLab, takeMeasurements = TRUE)
maxXlabWidth <- tmp[["sizingWidth"]]
maxXlabHeight <- tmp[["sizingHeight"]]
xlabNZ <- tmp[["nzDim"]]
} else {
maxXlabWidth <- NA_real_
maxXlabHeight <- NA_real_
xlabNZ <- FALSE
}
if (length(ylab) > 0) {
tmp <- dynTextGrob(ylab, gp = gpLab, rot = 90, takeMeasurements = TRUE)
maxYlabWidth <- tmp[["sizingWidth"]]
maxYlabHeight <- tmp[["sizingHeight"]]
ylabNZ <- tmp[["nzDim"]]
} else {
maxYlabWidth <- NA_real_
maxYlabHeight <- NA_real_
ylabNZ <- FALSE
}
targetAxesRatio2 <- targetAxesRatio * labelCex
if (is.na(xAxisHeight)) {
xAxisRatio <- Inf
} else if (targetAxesRatio2 * xAxisWidth < labelDim) {
xAxisRatio <- xAxisHeight * targetAxesRatio2 / labelDim
} else {
xAxisRatio <- xAxisHeight / xAxisWidth
}
if (is.na(yAxisWidth)) {
yAxisRatio <- Inf
} else if (targetAxesRatio2 * yAxisHeight < labelDim) {
yAxisRatio <- yAxisWidth * targetAxesRatio2 / labelDim
} else {
yAxisRatio <- yAxisWidth / yAxisHeight
}
xFs <- min(1 / xAxisWidth, xAxisRatio / xAxisHeight)
yFs <- min(1 / yAxisHeight, yAxisRatio / yAxisWidth)
xAxisRatio <- min(xAxisRatio, xAxisRatio * yFs / xFs, na.rm = TRUE)
yAxisRatio <- min(yAxisRatio, yAxisRatio * xFs / yFs, na.rm = TRUE)
if (!is.na(xFs) || !is.na(yFs)) {
xyFs <- min(xFs, yFs, na.rm = TRUE)
if (scaleLabels && !is.na(labelDim) &&
xyFs < targetAxesRatio2 / labelDim) {
fontScaleIn <- xyFs / (targetAxesRatio2 / labelDim)
labelDim <- labelDim / fontScaleIn
}
} else {
xyFs <- NA_real_
}
axesCex <- gpAxes[["cex"]]
if (is.null(axesCex)) {
axesCex <- 1
}
mainRatio <- min(min(1, mainExpand) * nCols * maxMainHeight / maxMainWidth,
mainExpand * max(targetMainRatio * nRows,
maxMainHeight * labelCex / labelDim,
maxMainHeight * axesCex * xyFs,
na.rm = TRUE), na.rm = TRUE)
xlabRatio <- min(min(1, xlabExpand) * nCols * maxXlabHeight / maxXlabWidth,
xlabExpand * max(targetLabRatio * min(nRows, nCols),
maxXlabHeight * labelCex / labelDim,
maxXlabHeight * axesCex * xyFs,
na.rm = TRUE), na.rm = TRUE)
ylabRatio <- min(min(1, ylabExpand) * nRows * maxYlabWidth / maxYlabHeight,
ylabExpand * max(targetLabRatio * min(nRows, nCols),
maxYlabWidth * labelCex / labelDim,
maxYlabWidth * axesCex * xyFs,
na.rm = TRUE), na.rm = TRUE)
ylabScale <- min(nRows / maxYlabHeight, ylabRatio / maxYlabWidth) /
ylabExpand
xlabScale <- min(nCols / maxXlabWidth, xlabRatio / maxXlabHeight) /
xlabExpand
if (!is.na(ylabScale) && !is.na(xlabScale)) {
if (ylabScale > xlabScale) {
ylabRatio <- xlabScale / ylabScale * ylabRatio
} else {
xlabRatio <- ylabScale / xlabScale * xlabRatio
}
}
## * *Ratio: Ratio of space reserved (along a dimension) for
## various graphical objects to length of the sides of each
## (square) cell in the table
## * *Dim, *Width, *Height: Maximum normalized size (Dim: max of
## width and height) of a graphical object. Normalized means size
## of the graphical object in points divided by the specified font
## size.
list(xAxisRatio = xAxisRatio, # x axis labels (one for each column)
yAxisRatio = yAxisRatio, # y axis labels (one for each row)
labelDim = labelDim, # labels in the table
labelNZ = labelNZ,
xAxisWidth = xAxisWidth, # x axis labels
xAxisHeight = xAxisHeight, # x axis labels
xAxisNZ = xAxisNZ,
yAxisWidth = yAxisWidth, # y axis labels
yAxisHeight = yAxisHeight, # y axis labels
yAxisNZ = yAxisNZ,
mainRatio = mainRatio, # main title
mainWidth = maxMainWidth, # main title
mainHeight = maxMainHeight, # main title
mainNZ = mainNZ,
xlabRatio = xlabRatio, # x label (one across all cols)
ylabRatio = ylabRatio, # y label (one across all rows)
xlabWidth = maxXlabWidth, # x label
xlabHeight = maxXlabHeight, # x label
ylabWidth = maxYlabWidth, # y label
ylabHeight = maxYlabHeight, # y label
xlabNZ = xlabNZ,
ylabNZ = ylabNZ)
}
## Convert unit() object x to inches (value only) in the current
## context. Uses both axisFrom = "x" and axisFrom = "y" and takes the
## minimum.
minConvertXY <- function(x) {
min(convertUnit(x, unitTo = "inches",
axisFrom = "x", typeFrom = "dimension",
valueOnly = TRUE),
convertUnit(x, unitTo = "inches",
axisFrom = "y", typeFrom = "dimension",
valueOnly = TRUE))
}
sisalTable <- function(labels = matrix(seq_len(12), 3, 4),
nRows = NROW(labels), nCols = NCOL(labels),
bg = sample(colors(), nRows * nCols, replace=TRUE),
stripeCol = NULL,
fg = NULL, naFill = "white", naStripes = "grey50",
main = NULL, xlab = NULL, ylab = NULL,
xAxisLabels = NULL, yAxisLabels = NULL,
draw = TRUE, outerRect = TRUE, innerLines = TRUE,
nStripes = 7, stripeRot = 45, stripeWidth = 0.2,
stripeScale = 0.95, resizeText = TRUE,
resizeTable = TRUE, resizeMain = resizeText,
resizeLab = resizeText, resizeAxes = resizeText,
resizeLabels = resizeTable && resizeText,
x = unit(0.5, "npc"), y = unit(0.5, "npc"),
width = unit(0.97, "npc"), height = unit(0.97, "npc"),
default.units = "npc", just = "center",
clip = "inherit", xAxisRot = 0, yAxisRot = 0,
xAxisJust = c(0.5, 1), xAxisX = 0.5, xAxisY = 1,
yAxisJust = c(1, 0.5), yAxisX = 1, yAxisY = 0.5,
mainMargin = if(resizeMain) 0.15 else unit(8, "points"),
xlabMargin = if (resizeLab) 0.1 else unit(5, "points"),
ylabMargin = if (resizeLab) 0.1 else unit(5, "points"),
axesMargin = if (resizeAxes) 0.1 else unit(5, "points"),
axesSize = 0.8, forceAxesSize = FALSE, mainSize = 1,
xlabSize = 1, ylabSize = 1,
mainPar = gpar(fontface="bold", fontsize=14),
labPar = gpar(fontface="plain", fontsize=14),
labelPars = gpar(fontsize = 20, cex = 0.6),
axesPar = gpar(fontsize = 10),
rectPar = gpar(), linePar = gpar(),
name = NULL, gp = NULL, vp = NULL) {
## Argument checking
stopifnot(is.numeric(xAxisX), length(xAxisX) == 1,
is.finite(xAxisX), is.numeric(xAxisY), length(xAxisY) == 1,
is.finite(xAxisY), is.numeric(yAxisX), length(yAxisX) == 1,
is.finite(yAxisX), is.numeric(yAxisY), length(yAxisY) == 1,
is.finite(yAxisY))
stopifnot(identical(resizeMain, TRUE) || identical(resizeMain, FALSE),
identical(resizeLab, TRUE) || identical(resizeLab, FALSE),
identical(resizeLabels, TRUE) || identical(resizeLabels, FALSE),
identical(resizeAxes, TRUE) || identical(resizeAxes, FALSE),
identical(resizeTable, TRUE) || identical(resizeTable, FALSE),
identical(draw, TRUE) || identical(draw, FALSE),
identical(outerRect, TRUE) || identical(outerRect, FALSE),
identical(innerLines, TRUE) || identical(innerLines, FALSE),
identical(forceAxesSize, TRUE) ||
identical(forceAxesSize, FALSE))
stopifnot(length(just) > 0,
is.character(just) || (is.numeric(just) && all(is.finite(just))))
stopifnot(length(xAxisJust) > 0,
is.character(xAxisJust) ||
(is.numeric(xAxisJust) && all(is.finite(xAxisJust))))
stopifnot(length(yAxisJust) > 0,
is.character(yAxisJust) ||
(is.numeric(yAxisJust) && all(is.finite(yAxisJust))))
stopifnot(length(just) > 0,
is.character(just) || (is.numeric(just) && all(is.finite(just))))
stopifnot(is.null(name) ||
(is.character(name) && length(name) == 1 && !is.na(name)))
stopifnot(inherits(mainPar, "gpar"), inherits(labPar, "gpar"),
inherits(labelPars, "gpar") ||
(is.list(labelPars) &&
all(vapply(labelPars, inherits, TRUE, what = "gpar"))),
inherits(axesPar, "gpar"), inherits(rectPar, "gpar"),
inherits(linePar, "gpar"))
stopifnot(is.numeric(axesSize), length(axesSize) == 1, is.finite(axesSize),
axesSize > 0, is.numeric(mainSize), length(mainSize) == 1,
is.finite(mainSize), mainSize > 0, is.numeric(xlabSize),
length(xlabSize) == 1, is.finite(xlabSize), xlabSize > 0,
is.numeric(ylabSize), length(ylabSize) == 1, is.finite(ylabSize),
ylabSize > 0)
stopifnot(is.numeric(nRows), length(nRows) == 1,
is.finite(nRows), nRows > 0, round(nRows) == nRows,
is.numeric(nCols), length(nCols) == 1, is.finite(nCols),
nCols > 0, round(nCols) == nCols)
stopifnot(is.numeric(xAxisRot), length(xAxisRot) == 1, is.finite(xAxisRot),
is.numeric(yAxisRot), length(yAxisRot) == 1, is.finite(yAxisRot))
stopifnot(is.numeric(stripeRot), length(stripeRot) == 1,
is.finite(stripeRot), is.numeric(nStripes),
length(nStripes) == 1,
is.finite(nStripes), nStripes >= 1, round(nStripes) == nStripes,
is.numeric(stripeWidth), length(stripeWidth) == 1,
is.finite(stripeWidth), stripeWidth > 0, stripeWidth < 1,
is.numeric(stripeScale), length(stripeScale) == 1,
is.finite(stripeScale), stripeScale >= 0, stripeScale <= 1)
allNA <- function (x) {
all(suppressWarnings(is.na(x))) || identical(x, "")
}
linearizeDf <- function(x) {
do.call("c",
lapply(x,
function(x) {
if (is.factor(x)) {
as.list(levels(x)[x])
} else {
as.list(x)
}
}))
}
## resizeLabels doesn't count in anyResize
anyResize <- any(resizeTable, resizeMain, resizeLab, resizeAxes)
if (!draw && dev.cur() == 1) {
## Open dummy device => avoid opening a window when using
## convertUnit(). As far as I can see, the unit conversions
## used here are independent of device parameters and thus
## should not be confused by the dummy device.
tFile <- tempfile()
pdf(file = tFile) # pdf device is always available
tDev <- dev.cur()
on.exit(dev.off(tDev))
on.exit(unlink(tFile), add = TRUE)
}
nCells <- nRows * nCols
if (is.data.frame(bg)) {
bg2 <- linearizeDf(bg)
} else {
bg2 <- bg
}
if (length(bg2) == 0) {
bg2 <- rep.int(NA_character_, nCells)
} else {
bg2 <- rep_len(bg2, nCells)
}
if (is.data.frame(stripeCol)) {
stripeCol2 <- linearizeDf(stripeCol)
} else {
stripeCol2 <- stripeCol
}
if (length(stripeCol2) == 0) {
stripeCol2 <- rep.int(NA_character_, nCells)
} else {
stripeCol2 <- rep_len(stripeCol2, nCells)
}
## Conversion coefficients from RGB to brightness / luminance / luma...
## Sources referenced on 2015-10-09.
## http://stackoverflow.com/q/596216
## https://en.wikipedia.org/wiki/Luma_%28video%29
LUMA.CONVERSION <- c(0.2126, 0.7152, 0.0722) # R, G, B
## Get RGB values of bg colors (checks that bg colors are valid)
bgNA <- is.na(bg2)
bgRGB <- t(col2rgb(bg2[!bgNA]))
stripeNA <- is.na(stripeCol2)
bgLuma <- numeric(nCells)
bgAndStripes <- which(!bgNA & !stripeNA)
onlyBg <- !bgNA & stripeNA
foo <- stripeNA[!bgNA]
bgRGBBoth <- bgRGB[!foo, , drop=FALSE]
bgRGBOnly <- bgRGB[foo, , drop=FALSE]
stripeRGB <- t(col2rgb(stripeCol2[bgAndStripes]))
luma1 <- drop(stripeRGB %*% LUMA.CONVERSION) / 255
dist1 <- abs(luma1 - 0.5)
luma2 <- drop(bgRGBBoth %*% LUMA.CONVERSION) / 255
dist2 <- abs(luma2 - 0.5)
dist1Larger <- dist1 > dist2
dist2Larger <- !dist1Larger
bgLuma[bgAndStripes[dist1Larger]] <- luma1[dist1Larger]
bgLuma[bgAndStripes[dist2Larger]] <- luma2[dist2Larger]
bgLuma[onlyBg] <- drop(bgRGBOnly %*% LUMA.CONVERSION / 255)
bgLuma[bgNA] <- drop(c(stripeWidth, 1 - stripeWidth) %*%
(t(col2rgb(c(naStripes, naFill))) %*%
LUMA.CONVERSION)) / 255
if (is.data.frame(fg)) {
fg2 <- linearizeDf(fg)
} else {
fg2 <- fg
}
if (length(fg2) == 0) {
fg2 <- rep.int("black", nCells)
fg2[bgLuma < 0.5] <- "white"
} else if (length(fg2) > nCells) {
fg2 <- fg2[seq_len(nCells)]
}
nFg <- length(fg2)
if (is.data.frame(labels)) {
labels2 <- linearizeDf(labels)
} else {
labels2 <- labels
}
if (length(labels2) == 0) {
labelsNA <- TRUE
nLabels <- 1
labels2 <- character(0)
} else if (length(labels2) > nCells) {
labels2 <- labels2[seq_len(nCells)]
}
## labels2,xAxisLabels2, yAxisLabels2 will be indexed with `[[`
if (is.expression(labels2)) {
labelTmp <- vector(mode = "list", length = length(labels2))
for (i in seq_along(labelTmp)) {
labelTmp[[i]] <- labels2[i]
}
labels2 <- labelTmp
} else if (!is.vector(labels2)) {
labels2 <- as.list(labels2)
}
if (length(labels2) > 0) {
labelsNA <- vapply(labels2, allNA, TRUE, USE.NAMES = FALSE)
nLabels <- length(labels2)
}
if (length(xAxisLabels) == 0) {
xAxisNA <- TRUE
nXAxis <- 1
have.xAxisLabels <- FALSE
xAxisLabels2 <- character(0)
} else if (length(xAxisLabels) > nCols) {
xAxisLabels2 <- xAxisLabels[seq_len(nCols)]
} else {
xAxisLabels2 <- xAxisLabels
}
if (is.expression(xAxisLabels2)) {
labelTmp <- vector(mode = "list", length = length(xAxisLabels2))
for (i in seq_along(labelTmp)) {
labelTmp[[i]] <- xAxisLabels2[i]
}
xAxisLabels2 <- labelTmp
} else if (!is.vector(xAxisLabels2)) {
xAxisLabels2 <- as.list(xAxisLabels2)
}
if (length(xAxisLabels2) > 0) {
xAxisNA <- vapply(xAxisLabels2, allNA, TRUE, USE.NAMES = FALSE)
nXAxis <- length(xAxisLabels2)
have.xAxisLabels <- !all(xAxisNA)
}
if (length(yAxisLabels) == 0) {
yAxisNA <- TRUE
nYAxis <- 1
have.yAxisLabels <- FALSE
yAxisLabels2 <- character(0)
} else if (length(yAxisLabels) > nRows) {
yAxisLabels2 <- yAxisLabels[seq_len(nRows)]
} else {
yAxisLabels2 <- yAxisLabels
}
if (is.expression(yAxisLabels2)) {
labelTmp <- vector(mode = "list", length = length(yAxisLabels2))
for (i in seq_along(labelTmp)) {
labelTmp[[i]] <- yAxisLabels2[i]
}
yAxisLabels2 <- labelTmp
} else if (!is.vector(yAxisLabels2)) {
yAxisLabels2 <- as.list(yAxisLabels2)
}
if (length(yAxisLabels2) > 0) {
yAxisNA <- vapply(yAxisLabels2, allNA, TRUE, USE.NAMES = FALSE)
nYAxis <- length(yAxisLabels2)
have.yAxisLabels <- !all(yAxisNA)
}
if (inherits(labelPars, "gpar")) {
labelPars2 <- list(gparToList(labelPars))
nLabelPars <- 1
} else if (length(labelPars) == 0) {
labelPars2 <- list(list())
nLabelPars <- 1
} else if (length(labelPars) > nCells) {
labelPars2 <- lapply(labelPars[seq_len(nCells)], "gparToList")
nLabelPars <- nCells
} else {
labelPars2 <- lapply(labelPars, "gparToList")
nLabelPars <- length(labelPars)
}
parToLabelRatio <- nLabelPars / nLabels
if (nLabelPars > nLabels && round(parToLabelRatio) == parToLabelRatio) {
labels2 <- rep(labels2, length.out = nLabelPars)
labelsNA <- rep_len(labelsNA, nLabelPars)
nLabels <- nLabelPars
} else if (nLabelPars != nLabels) {
labels2 <- rep(labels2, length.out = nCells)
labelsNA <- rep_len(labelsNA, nCells)
labelPars2 <- rep_len(labelPars2, nCells)
nLabels <- nCells
}
fsPar <- unname(unlist(get.gpar("fontsize")))
maxLabelFS <- fsPar
for (i in seq_along(labelPars2)) {
thisSize <- labelPars2[[i]][["fontsize"]]
if (is.null(thisSize)) {
labelPars2[[i]][["fontsize"]] <- fsPar
} else {
maxLabelFS <- max(maxLabelFS, thisSize)
}
}
axesParList <- gparToList(axesPar)
if (!resizeAxes) {
thisSize <- axesParList[["fontsize"]]
if (is.null(thisSize)) {
axesParList[["fontsize"]] <- fsPar
}
axesPar2 <- do.call("gpar", axesParList)
}
mainParList <- gparToList(mainPar)
if (!resizeMain) {
thisSize <- mainParList[["fontsize"]]
if (is.null(thisSize)) {
mainParList[["fontsize"]] <- fsPar
}
mainPar2 <- do.call("gpar", mainParList)
}
labParList <- gparToList(labPar)
if (!resizeLab) {
thisSize <- labParList[["fontsize"]]
if (is.null(thisSize)) {
labParList[["fontsize"]] <- fsPar
}
labPar2 <- do.call("gpar", labParList)
}
have.main <- length(main) > 0 && !all(vapply(main, allNA, TRUE,
USE.NAMES = FALSE))
if (have.main) {
if (is.expression(main)) {
main2 <- list(main[1])
} else {
main2 <- as.list(main)[1]
}
}
have.xlab <- length(xlab) > 0 && !all(vapply(xlab, allNA, TRUE,
USE.NAMES = FALSE))
if (have.xlab) {
if (is.expression(xlab)) {
xlab2 <- list(xlab[1])
} else {
xlab2 <- as.list(xlab)[1]
}
}
have.ylab <- length(ylab) > 0 && !all(vapply(ylab, allNA, TRUE,
USE.NAMES = FALSE))
if (have.ylab) {
if (is.expression(ylab)) {
ylab2 <- list(ylab[1])
} else {
ylab2 <- as.list(ylab)[1]
}
}
## Argument checking
if (have.xAxisLabels || have.yAxisLabels) {
if (inherits(axesMargin, "unit")) {
if (resizeAxes) {
stop(gettextf("when '%s' is TRUE, '%s' must be a non-negative number",
"resizeAxes", "axesMargin", domain = "R-sisal"),
domain = NA)
}
} else if (!(is.numeric(axesMargin) && length(axesMargin) == 1 &&
is.finite(axesMargin) && axesMargin >= 0)) {
stop(gettextf("if '%s' is not a unit, it must be a non-negative number",
"axesMargin", domain = "R-sisal"),
domain = NA)
}
}
if (have.xlab) {
if (inherits(xlabMargin, "unit")) {
if (resizeLab) {
stop(gettextf("when '%s' is TRUE, '%s' must be a non-negative number",
"resizeLab", "xlabMargin", domain = "R-sisal"),
domain = NA)
}
} else if (!is.numeric(xlabMargin) || length(xlabMargin) != 1 ||
!is.finite(xlabMargin) || xlabMargin < 0) {
stop(gettextf("if '%s' is not a unit, it must be a non-negative number",
"xlabMargin", domain = "R-sisal"),
domain = NA)
}
}
if (have.ylab) {
if (inherits(ylabMargin, "unit")) {
if (resizeLab) {
stop(gettextf("when '%s' is TRUE, '%s' must be a non-negative number",
"resizeLab", "ylabMargin", domain = "R-sisal"),
domain = NA)
}
} else if (!is.numeric(ylabMargin) || length(ylabMargin) != 1 ||
!is.finite(ylabMargin) || ylabMargin < 0) {
stop(gettextf("if '%s' is not a unit, it must be a non-negative number",
"ylabMargin", domain = "R-sisal"),
domain = NA)
}
}
if (have.main) {
if (inherits(mainMargin, "unit")) {
if (resizeMain) {
stop(gettextf("when '%s' is TRUE, '%s' must be a non-negative number",
"resizeMain", "mainMargin", domain = "R-sisal"),
domain = NA)
}
} else if (!is.numeric(mainMargin) || length(mainMargin) != 1 ||
!is.finite(mainMargin) || mainMargin < 0) {
stop(gettextf("if '%s' is not a unit, it must be a non-negative number",
"mainMargin", domain = "R-sisal"),
domain = NA)
}
}
## Compute the actual sizes of different text elements and the
## relative sizes of different elements in the plot, taking into
## account some font size parameters etc.
xy <- tableMeasures(xAxisLabels2[!xAxisNA], yAxisLabels2[!yAxisNA],
labels2[!labelsNA], targetAxesRatio = axesSize,
gpAxes = axesParList, gpLabels = labelPars2[!labelsNA],
main = if (have.main) main2,
xlab = if (have.xlab) xlab2,
ylab = if (have.ylab) ylab2,
gpMain = mainParList, gpLab = labParList,
nRows = nRows, nCols = nCols,
xlabExpand = xlabSize, ylabExpand = ylabSize,
mainExpand = mainSize, scaleLabels = forceAxesSize,
xAxisRot = xAxisRot, yAxisRot = yAxisRot,
xAxisJust = xAxisJust, yAxisJust = yAxisJust)
labelJust <- rep.int(0.5, nLabels)
labelsNA[!labelsNA] <- !xy[["labelNZ"]]
labelsNotNA <- !labelsNA
have.labels <- any(labelsNotNA)
xAxisNA[!xAxisNA] <- !xy[["xAxisNZ"]]
have.xAxisLabels <- !all(xAxisNA)
yAxisNA[!yAxisNA] <- !xy[["yAxisNZ"]]
have.yAxisLabels <- !all(yAxisNA)
have.main <- xy[["mainNZ"]]
have.xlab <- xy[["xlabNZ"]]
have.ylab <- xy[["ylabNZ"]]
internalLabels <- c(labels2[labelsNotNA], "x")
internalLabelPars <- c(labelPars2[labelsNotNA],
list(list(fontsize = maxLabelFS)))
if (have.labels && (!resizeLabels || !resizeTable)) {
justTmp <- dynTextGrob(internalLabels, adjustJust = TRUE,
gp = internalLabelPars, resize = FALSE,
takeMeasurements = TRUE)[["vjust"]]
labelJust[labelsNotNA] <- justTmp[1:(length(justTmp) - 1)]
}
## Size of xlab, ylab margin (fixed size)
resizeXlabMargin <- TRUE
resizeYlabMargin <- TRUE
if (!resizeLab) {
if (have.xlab) {
mfs <- dynTextGrob(xlab2, gp = labPar2,
resize = FALSE, takeMeasurements = TRUE)
xlabWidthInches <- mfs[["sizingWidth"]]
xlabHeightInches <- mfs[["sizingHeight"]]
xlabHeight <- unit(xlabHeightInches, "inches")
}
if (have.ylab) {
mfs <- dynTextGrob(ylab2, rot = 90, gp = labPar2,
resize = FALSE, takeMeasurements = TRUE)
ylabWidthInches <- mfs[["sizingWidth"]]
ylabHeightInches <- mfs[["sizingHeight"]]
ylabWidth <- unit(ylabWidthInches, "inches")
}
if (inherits(xlabMargin, "unit")) {
resizeXlabMargin <- FALSE
xlabMarInches <-
convertUnit(xlabMargin, unitTo = "inches",
axisFrom = "x", typeFrom = "dimension",
valueOnly = TRUE)
xlabMar <- unit(xlabMarInches, "inches")
}
if (inherits(ylabMargin, "unit")) {
resizeYlabMargin <- FALSE
ylabMarInches <-
convertUnit(ylabMargin, unitTo = "inches",
axisFrom = "y", typeFrom = "dimension",
valueOnly = TRUE)
ylabMar <- unit(ylabMarInches, "inches")
}
}
## Size of x and y axes and their margin (fixed size)
resizeAxesMargin <- TRUE
xAxisNotNA <- !xAxisNA
yAxisNotNA <- !yAxisNA
if (!resizeAxes) {
maxXAxisHeightInches <- 0
xAxisLabelLeft <- numeric(nCols)
xAxisLabelRight <- numeric(nCols)
xAxisHJust <- numeric(nCols)
xAxisVJust <- numeric(nCols)
xAxisXShift <- numeric(nCols)
xAxisYShift <- numeric(nCols)
if (have.xAxisLabels) {
xMeasurements <-
dynTextGrob(xAxisLabels[xAxisNotNA], adjustJust = TRUE,
gp = axesPar2, resize = FALSE, rotJust = TRUE,
rot = xAxisRot, just = xAxisJust,
takeMeasurements = TRUE)
maxXAxisHeightInches <- xMeasurements[["sizingHeight"]]
xAxisLabelLeft[xAxisNotNA] <- xMeasurements[["left"]]
xAxisLabelRight[xAxisNotNA] <- xMeasurements[["right"]]
xAxisHJust[xAxisNotNA] <- xMeasurements[["hjust"]]
xAxisVJust[xAxisNotNA] <- xMeasurements[["vjust"]]
xAxisXShift[xAxisNotNA] <- xMeasurements[["xShift"]]
xAxisYShift[xAxisNotNA] <- xMeasurements[["yShift"]]
xAxisX2 <- xAxisX + xAxisXShift
xAxisY2 <- xAxisY + xAxisYShift
}
maxYAxisWidthInches <- 0
yAxisLabelBottom <- numeric(nRows)
yAxisLabelTop <- numeric(nRows)
yAxisHJust <- numeric(nRows)
yAxisVJust <- numeric(nRows)
yAxisXShift <- numeric(nRows)
yAxisYShift <- numeric(nRows)
if (have.yAxisLabels) {
yMeasurements <-
dynTextGrob(yAxisLabels[yAxisNotNA], adjustJust = TRUE,
gp = axesPar2, resize = FALSE, rotJust = TRUE,
rot = yAxisRot, just = yAxisJust,
takeMeasurements = TRUE)
maxYAxisWidthInches <- yMeasurements[["sizingWidth"]]
yAxisLabelBottom[yAxisNotNA] <- yMeasurements[["bottom"]]
yAxisLabelTop[yAxisNotNA] <- yMeasurements[["top"]]
yAxisHJust[yAxisNotNA] <- yMeasurements[["hjust"]]
yAxisVJust[yAxisNotNA] <- yMeasurements[["vjust"]]
yAxisXShift[yAxisNotNA] <- yMeasurements[["xShift"]]
yAxisYShift[yAxisNotNA] <- yMeasurements[["yShift"]]
yAxisX2 <- yAxisX + yAxisXShift
yAxisY2 <- yAxisY + yAxisYShift
}
if (have.xAxisLabels) {
xAxisSide <- unit(maxXAxisHeightInches, "inches")
}
if (have.yAxisLabels) {
yAxisSide <- unit(maxYAxisWidthInches, "inches")
}
if (inherits(axesMargin, "unit")) {
resizeAxesMargin <- FALSE
xyMarginSideInches <- minConvertXY(axesMargin)
xyMarginSide <- unit(xyMarginSideInches, "inches")
}
}
## Size of main title and its margin (fixed size)
resizeMainMargin <- TRUE
if (have.main && !resizeMain) {
mfs <- dynTextGrob(main2, gp = mainPar2,
resize = FALSE, takeMeasurements = TRUE)
mainWidthInches <- mfs[["sizingWidth"]]
mainHeightInches <- mfs[["sizingHeight"]]
mainHeight <- unit(mainHeightInches, "inches")
if (inherits(mainMargin, "unit")) {
resizeMainMargin <- FALSE
mainMarginInches <- minConvertXY(mainMargin)
mainMargin2 <- unit(mainMarginInches, "inches")
}
}
## Layout, number of rows and columns
layRows <- 1 + 2 * have.main + nRows + 2 * have.xAxisLabels +
2 * have.xlab
layCols <- 1 + 2 * have.ylab + 2 * have.yAxisLabels + nCols
## Sums of width and height of fixed-size ("rigid") objects
rigidWidthInches <- 0
rigidHeightInches <- 0
## Width and height of the table when resizeTable is FALSE (adds
## to rigidWidthInches and rigidHeightInches)
if (!resizeTable) {
labelsCex <- FALSE
if (have.labels) {
whichLabels <- which(labelsNotNA)
nNotNA <- length(whichLabels)
gpS <- labelPars2[whichLabels]
theCex <- numeric(nNotNA)
for (i in seq_len(nNotNA)) {
thisCex <- gpS[[i]][["cex"]]
if (is.numeric(thisCex) && length(thisCex) == 1) {
theCex[i] <- thisCex
}
gpS[[i]][["cex"]] <- NULL
}
mfs <- dynTextGrob(labels2[whichLabels], takeMeasurements = TRUE,
gp = gpS, resize = FALSE, adjustJust = FALSE,
vjust = labelJust[whichLabels])
cellSideInches <- max(unlist(mfs[c("sizingWidth", "sizingHeight")]))
if (!anyResize) {
labelHalfWidths <- numeric(length(labelsNA))
labelTops <- numeric(length(labelsNA))
labelBottoms <- numeric(length(labelsNA))
bigCex <- logical(length(labelsNA))
labelHalfWidths[whichLabels] <- mfs[["right"]]
labelTops[whichLabels] <- mfs[["top"]]
labelBottoms[whichLabels] <- mfs[["bottom"]]
idx <- which(theCex > 1)
labelsCex <- length(idx) > 0
if (labelsCex) {
bigCex[idx] <- TRUE
theCex <- theCex[idx]
labelHalfWidths[idx] <- theCex * labelHalfWidths[idx]
labelTops[idx] <- theCex * labelTops[idx]
labelBottoms[idx] <- theCex * labelBottoms[idx]
}
}
} else {
tmpGrob <- textGrob("x", gp = gpar(fontsize = maxLabelFS))
cellSideInches <-
max(convertWidth(grobWidth(tmpGrob),
unitTo = "inches", valueOnly = TRUE),
convertHeight(grobHeight(tmpGrob),
unitTo = "inches", valueOnly = TRUE))
}
cellSide <- unit(cellSideInches, "inches")
xCell <- nCols * cellSideInches
yCell <- nRows * cellSideInches
rigidWidthInches <- rigidWidthInches + xCell
rigidHeightInches <- rigidHeightInches + yCell
if (!resizeAxes && resizeAxesMargin) {
resizeAxesMargin <- FALSE
xyMarginSideInches <- axesMargin * cellSideInches
xyMarginSide <- unit(xyMarginSideInches, "inches")
}
if (have.main && !resizeMain && resizeMainMargin) {
resizeMainMargin <- FALSE
mainMarginInches <- mainMargin * cellSideInches
mainMargin2 <- unit(mainMarginInches, "inches")
}
if (!resizeLab && resizeXlabMargin) {
resizeXlabMargin <- FALSE
xlabMarInches <- xlabMargin * cellSideInches
xlabMar <- unit(xlabMarInches, "inches")
}
if (!resizeLab && resizeYlabMargin) {
resizeYlabMargin <- FALSE
ylabMarInches <- ylabMargin * cellSideInches
ylabMar <- unit(ylabMarInches, "inches")
}
}
if (have.ylab && !resizeLab) {
rigidWidthInches <- rigidWidthInches + ylabWidthInches
if (!resizeYlabMargin) {
rigidWidthInches <- rigidWidthInches + ylabMarInches
}
}
if (have.yAxisLabels && !resizeAxes) {
rigidWidthInches <- rigidWidthInches + maxYAxisWidthInches
if (!resizeAxesMargin) {
rigidWidthInches <- rigidWidthInches + xyMarginSideInches
}
}
if (have.main && !resizeMain) {
rigidHeightInches <- rigidHeightInches + mainHeightInches
if (!resizeMainMargin) {
rigidHeightInches <- rigidHeightInches + mainMarginInches
}
}
if (have.xAxisLabels && !resizeAxes) {
rigidHeightInches <- rigidHeightInches + maxXAxisHeightInches
if (!resizeAxesMargin) {
rigidHeightInches <- rigidHeightInches + xyMarginSideInches
}
}
if (have.xlab && !resizeLab) {
rigidHeightInches <- rigidHeightInches + xlabHeightInches
if (!resizeXlabMargin) {
rigidHeightInches <- rigidHeightInches + xlabMarInches
}
}
## Sizes of dummGrob and objects depending on it can be constant or dynamic
if (inherits(width, "unit") && inherits(height, "unit")) {
hSize <- width
vSize <- height
} else {
hSize <- unit(width, default.units)
vSize <- unit(height, default.units)
}
## This is never drawn
dummGrob <- rectGrob(width = max(unit(0, "inches"),
hSize - unit(rigidWidthInches, "inches")),
height = max(unit(0, "inches"),
vSize - unit(rigidHeightInches, "inches")))
## hUnits and vUnits are the total horizontal and vertical size of
## table cells whose size depends on the size of dummGrob, where 1
## unit is the size of a square cell in the nRows * nCols contents
## section (if resizeTable is TRUE)
if (resizeTable) {
hUnits <- nCols
} else {
hUnits <- 0
}
if (have.yAxisLabels) {
if (resizeAxes) {
hUnits <- hUnits + xy[["yAxisRatio"]]
}
if (resizeAxesMargin) {
hUnits <- hUnits + axesMargin
}
}
if (have.ylab) {
if (resizeLab) {
hUnits <- hUnits + xy[["ylabRatio"]]
}
if (resizeYlabMargin) {
hUnits <- hUnits + ylabMargin
}
}
if (resizeTable) {
vUnits <- nRows
} else {
vUnits <- 0
}
if (have.xAxisLabels) {
if (resizeAxes) {
vUnits <- vUnits + xy[["xAxisRatio"]]
}
if (resizeAxesMargin) {
vUnits <- vUnits + axesMargin
}
}
if (have.xlab) {
if (resizeLab) {
vUnits <- vUnits + xy[["xlabRatio"]]
}
if (resizeXlabMargin) {
vUnits <- vUnits + xlabMargin
}
}
if (have.main) {
if (resizeMain) {
vUnits <- vUnits + xy[["mainRatio"]]
}
if (resizeMainMargin) {
vUnits <- vUnits + mainMargin
}
}
## Width and / or height of graphical objects as units
if (resizeTable) {
cellSide <- min(unit(1 / hUnits, "grobwidth", data = dummGrob),
unit(1 / vUnits, "grobheight", data = dummGrob))
}
xAxisWidth <- xy[["xAxisWidth"]]
xAxisHeight <- xy[["xAxisHeight"]]
yAxisWidth <- xy[["yAxisWidth"]]
yAxisHeight <- xy[["yAxisHeight"]]
if (resizeAxes) {
xyMarginSide <- axesMargin * cellSide
if (have.xAxisLabels) {
xAxisSide <-
min(xAxisHeight / xAxisWidth * cellSide,
unit(xy[["xAxisRatio"]] / hUnits, "grobwidth",
data = dummGrob),
unit(xy[["xAxisRatio"]] / vUnits, "grobheight",
data = dummGrob))
}
if (have.yAxisLabels) {
yAxisSide <-
min(yAxisWidth / yAxisHeight * cellSide,
unit(xy[["yAxisRatio"]] / hUnits, "grobwidth",
data = dummGrob),
unit(xy[["yAxisRatio"]] / vUnits, "grobheight",
data = dummGrob))
}
}
layHeights <- vector(mode = "list", length = layRows)
layHeights[[1]] <- unit(0, "inches")
rowCount <- 1
if (have.main) {
if (resizeMain) {
mainMargin2 <- mainMargin * cellSide
mainHeight <- min(xy[["mainHeight"]] / xy[["mainWidth"]] *
nCols * cellSide,
unit(xy[["mainRatio"]] / hUnits, "grobwidth",
data = dummGrob),
unit(xy[["mainRatio"]] / vUnits, "grobheight",
data = dummGrob))
}
layHeights[rowCount + 1:2] <- list(mainHeight, mainMargin2)
rowCount <- rowCount + 2
}
layHeights[rowCount + seq_len(nRows)] <- rep(list(cellSide), nRows)
rowCount <- rowCount + nRows
if (have.xAxisLabels) {
layHeights[rowCount + 1:2] <- list(xyMarginSide, xAxisSide)
rowCount <- rowCount + 2
} else {
xAxisSide <- NULL
}
if (resizeLab) {
if (have.xlab) {
xlabMar <- xlabMargin * cellSide
xlabHeight <- min(xy[["xlabHeight"]] / xy[["xlabWidth"]] *
nCols * cellSide,
unit(xy[["xlabRatio"]] / hUnits, "grobwidth",
data = dummGrob),
unit(xy[["xlabRatio"]] / vUnits, "grobheight",
data = dummGrob))
}
if (have.ylab) {
ylabMar <- ylabMargin * cellSide
ylabWidth <- min(xy[["ylabWidth"]] / xy[["ylabHeight"]] *
nRows * cellSide,
unit(xy[["ylabRatio"]] / hUnits, "grobwidth",
data = dummGrob),
unit(xy[["ylabRatio"]] / vUnits, "grobheight",
data = dummGrob))
}
}
if (have.xlab) {
layHeights[rowCount + 1:2] <- list(xlabMar, xlabHeight)
}
layHeights <- do.call("unit.c", layHeights)
layWidths <- vector(mode = "list", length = layCols)
layWidths[[1]] <- unit(0, "inches")
colCount <- 1
if (have.ylab) {
layWidths[colCount + 1:2] <- list(ylabWidth, ylabMar)
colCount <- colCount + 2
}
if (have.yAxisLabels) {
layWidths[colCount + 1:2] <- list(yAxisSide, xyMarginSide)
colCount <- colCount + 2
} else {
yAxisSide <- NULL
}
layWidths[colCount + seq_len(nCols)] <- rep(list(cellSide), nCols)
layWidths <- do.call("unit.c", layWidths)
## Lists for grobs and viewports, with some excess length.
## The drawing order will be innerGrobs before outerGrobs.
outerGrobs <- vector(mode = "list",
length = layRows * layCols - nRows * nCols)
innerGrobs <- vector(mode = "list",
length = nRows * nCols + outerRect +
innerLines * ((nRows-1) * nCols + (nCols-1) * nRows))
vps <- vector(mode = "list", length = layRows * layCols + outerRect)
## Counts how many grobs and viewports have been added to the lists
vpCounter <- 0
outerCount <- 0
innerCount <- 0
### Create grobs and viewports, add to the lists
if (any(bgNA) || any(!stripeNA[!bgNA])) {
stripeWidth2 <- stripeWidth / nStripes
stripeSep <- 1 / nStripes
stripeY <- seq(from=stripeSep / 2, by = stripeSep, length.out=nStripes)
stripeGrobNA <-
grobTree(rectGrob(gp = gpar(fill=naFill, col=naFill),
name = "stripeBg"),
stripePolygon(y = stripeY, rot = stripeRot,
width = stripeWidth2,
xyScale = stripeScale,
default.units = "npc",
name = "stripes"),
gp = gpar(col = naStripes, fill = naStripes))
}
xAxisGrobs <- vector(mode = "list", length = nXAxis)
yAxisGrobs <- vector(mode = "list", length = nYAxis)
if (resizeAxes) {
for (i in which(xAxisNotNA)) {
xAxisGrobs[[i]] <-
textGrob(xAxisLabels2[[i]], gp = axesPar,
rot = xAxisRot, x = xAxisX, y = xAxisY)
}
for (i in which(yAxisNotNA)) {
yAxisGrobs[[i]] <-
textGrob(yAxisLabels2[[i]], gp = axesPar,
rot = yAxisRot, x = yAxisX, y = yAxisY)
}
} else {
for (i in which(xAxisNotNA)) {
xAxisGrobs[[i]] <-
textGrob(xAxisLabels2[[i]], gp = axesPar2,
rot = xAxisRot, x = xAxisX2[i], y = xAxisY2[i],
hjust = xAxisHJust[i], vjust = xAxisVJust[i])
}
for (i in which(yAxisNotNA)) {
yAxisGrobs[[i]] <-
textGrob(yAxisLabels2[[i]], gp = axesPar2,
rot = yAxisRot, x = yAxisX2[i], y = yAxisY2[i],
hjust = yAxisHJust[i], vjust = yAxisVJust[i])
}
}
## Row by row...
cellNames <- twoPartName(rep.int(seq_len(nRows), nCols),
rep(seq_len(nCols), each = nRows))
bgNames <- twoPartNameChar("bg", cellNames)
textNames <- twoPartNameChar("text", cellNames)
treeNames <- twoPartNameChar("tree", cellNames)
yNames <- twoPartName(seq_len(nRows), "yaxis")
for (Row in seq_len(nRows)) {
Row2 <- 1 + Row + 2 * have.main
## Y axis label
yAxisMod <- (Row - 1) %% nYAxis + 1
if (yAxisNotNA[yAxisMod]) {
vpCounter <- vpCounter + 1
outerCount <- outerCount + 1
Col2 <- 2 + 2 * have.ylab
thisName <- yNames[Row]
vps[[vpCounter]] <-
viewport(layout.pos.row = Row2, layout.pos.col = Col2,
name = thisName)
outerGrobs[[outerCount]] <-
editGrob(yAxisGrobs[[yAxisMod]], name = thisName,
vp = vpPath("Parent", thisName))
}
Col2 <- 2 + 2 * have.yAxisLabels + 2 * have.ylab
## Actual contents of the table
for (Col in seq_len(nCols)) {
linearRowCol <- Row - 1 + (Col - 1) * nRows
vpCounter <- vpCounter + 1
innerCount <- innerCount + 1
thisName <- cellNames[linearRowCol + 1]
vps[[vpCounter]] <-
viewport(layout.pos.row = Row2, layout.pos.col = Col2,
name = thisName)
vpP <- vpPath("Parent", thisName)
labelsMod <- linearRowCol %% nLabels + 1
labelPar <- labelPars2[[labelsMod]]
labelPar[["col"]] <- fg2[[linearRowCol %% nFg + 1]]
bgMod <- linearRowCol + 1
if (bgNA[bgMod]) {
bgGrob <- editGrob(stripeGrobNA, vp = vpP,
name = bgNames[linearRowCol + 1])
} else if (stripeNA[bgMod]) {
thisBg <- bg2[[bgMod]]
bgGrob <- rectGrob(gp = gpar(fill = thisBg, col = thisBg),
vp = vpP,
name = bgNames[linearRowCol + 1])
} else {
thisBg1 <- bg2[[bgMod]]
thisBg2 <- stripeCol2[[bgMod]]
bgGrob <- editGrob(stripeGrobNA, vp = vpP,
name = bgNames[linearRowCol + 1],
gp = gpar(col = thisBg2, fill = thisBg2))
bgGrob <- editGrob(bgGrob, gPath = "stripeBg",
gp = gpar(col = thisBg1, fill = thisBg1))
}
if (resizeLabels) {
labelPar["fontsize"] <- NULL
}
if (labelsNA[labelsMod]) {
fgGrob <- NULL
} else {
fgGrob <- textGrob(labels2[[labelsMod]],
gp = do.call("gpar", labelPar), vp = vpP,
name = textNames[linearRowCol + 1],
vjust = labelJust[labelsMod])
}
innerGrobs[[innerCount]] <-
grobTree(bgGrob, fgGrob, name = treeNames[linearRowCol + 1])
Col2 <- Col2 + 1
}
}
## X axis labels
Row2 <- nRows + 3 + 2 * have.main
Col2 <- 1 + 2 * have.yAxisLabels + 2 * have.ylab
xNames <- twoPartName("xaxis", seq_len(nCols))
for (Col in seq_len(nCols)[xAxisNotNA]) {
vpCounter <- vpCounter + 1
outerCount <- outerCount + 1
thisName <- xNames[Col]
vps[[vpCounter]] <- viewport(layout.pos.row = Row2, name = thisName,
layout.pos.col = Col2 + Col)
outerGrobs[[outerCount]] <-
editGrob(xAxisGrobs[[(Col - 1) %% nXAxis + 1]], name = thisName,
vp = vpPath("Parent", thisName))
}
## X label
if (have.xlab) {
vpCounter <- vpCounter + 1
outerCount <- outerCount + 1
xlabRow <- nRows + 2 * have.xAxisLabels + 3 + 2 * have.main
firstCol <- 2 + 2 * have.yAxisLabels + 2 * have.ylab
lastCol <- firstCol + nCols - 1
xlabCol <- c(firstCol, lastCol)
vps[[vpCounter]] <-
viewport(layout.pos.row = xlabRow, layout.pos.col = xlabCol,
name = "xlab")
if (resizeLab) {
outerGrobs[[outerCount]] <-
dynTextGrob(xlab2[[1]], gp = labPar,
sizingWidth = xy[["xlabWidth"]],
sizingHeight = xy[["xlabHeight"]],
name = "xlab", vp = vpPath("Parent", "xlab"),)
} else {
outerGrobs[[outerCount]] <-
textGrob(xlab2[[1]], gp = labPar2, name = "xlab",
vp = vpPath("Parent", "xlab"))
}
}
## Y label
if (have.ylab) {
vpCounter <- vpCounter + 1
outerCount <- outerCount + 1
ylabCol <- 2
firstRow <- 2 + 2 * have.main
lastRow <- firstRow + nRows - 1
ylabRow <- c(firstRow, lastRow)
vps[[vpCounter]] <-
viewport(layout.pos.row = ylabRow, layout.pos.col = ylabCol,
name = "ylab")
if (resizeLab) {
outerGrobs[[outerCount]] <-
dynTextGrob(ylab2[[1]], gp = labPar, rot = 90, name = "ylab",
vp = vpPath("Parent", "ylab"),
sizingWidth = xy[["ylabWidth"]],
sizingHeight = xy[["ylabHeight"]])
} else {
outerGrobs[[outerCount]] <-
textGrob(ylab2[[1]], gp = labPar2, rot = 90, name = "ylab",
vp = vpPath("Parent", "ylab"))
}
}
## Main title
if (have.main) {
vpCounter <- vpCounter + 1
outerCount <- outerCount + 1
firstCol <- 2 + 2 * have.yAxisLabels + 2 * have.ylab
lastCol <- firstCol + nCols - 1
mainCol <- c(firstCol, lastCol)
mainRow <- 2
vps[[vpCounter]] <-
viewport(layout.pos.row = mainRow, layout.pos.col = mainCol,
name = "main")
if (resizeMain) {
outerGrobs[[outerCount]] <-
dynTextGrob(main2[[1]],
gp = mainPar, vp = vpPath("Parent", "main"),
sizingWidth = xy[["mainWidth"]],
sizingHeight = xy[["mainHeight"]],
name = "main")
} else {
outerGrobs[[outerCount]] <- textGrob(main2[[1]], gp = mainPar2,
vp = vpPath("Parent", "main"),
name = "main")
}
}
## Line segments between table cells: Maximize contrast to
## neighboring cells (black, white and different shades of gray
## available)
if (innerLines) {
linePar2 <- gparToList(linePar)
colorMissing <- !("col" %in% names(linePar2))
if (colorMissing) {
linePar2[["col"]] <- "black"
colorIdx <- which(names(linePar2) == "col")[1]
}
## Horizontal
hLineNames <- twoPartNameChar("hLine", cellNames)
for (Row in seq_len(nRows - 1)) {
for (Col in seq_len(nCols)) {
linearRowCol <- c(Row, Row + 1) - 1 + (Col - 1) * nRows + 1
innerCount <- innerCount + 1
vpName <- cellNames[linearRowCol[1]]
if (colorMissing) {
linePar2[[colorIdx]] <- fgGrey(bgLuma[linearRowCol])
}
innerGrobs[[innerCount]] <-
segmentsGrob(x0 = 0, y0 = 0, x1 = 1, y1 = 0,
gp = do.call("gpar", linePar2),
name = hLineNames[linearRowCol[1]],
vp = vpPath("Parent", vpName))
}
}
## Vertical
vLineNames <- twoPartNameChar("vLine", cellNames)
for (Col in seq_len(nCols - 1)) {
for (Row in seq_len(nRows)) {
linearRowCol <- Row - 1 + (c(Col, Col + 1) - 1) * nRows + 1
innerCount <- innerCount + 1
vpName <- cellNames[linearRowCol[1]]
if (colorMissing) {
linePar2[[colorIdx]] <- fgGrey(bgLuma[linearRowCol])
}
innerGrobs[[innerCount]] <-
segmentsGrob(x0 = 1, y0 = 0, x1 = 1, y1 = 1,
gp = do.call("gpar", linePar2),
name = vLineNames[linearRowCol[1]],
vp = vpPath("Parent", vpName))
}
}
}
## Frame around table
if (outerRect) {
rectPar2 <- gparToList(rectPar)
rectPar2[["fill"]] <- 0 # transparent
vpCounter <- vpCounter + 1
innerCount <- innerCount + 1
Row <- seq(from = 2 + 2 * have.main, by = 1, length.out = nRows)
Col <- seq(from = 2 + 2 * have.yAxisLabels + 2 * have.ylab,
by = 1, length.out = nCols)
vps[[vpCounter]] <- viewport(layout.pos.row = Row,
layout.pos.col = Col, name = "outerRect")
innerGrobs[[innerCount]] <- rectGrob(gp = do.call("gpar", rectPar2),
name = "outerRect",
vp = vpPath("Parent", "outerRect"))
}
## Compute numeric 'hjust' and 'vjust'
tmpJust <- justHV(just)
hjust <- tmpJust[[1]]
vjust <- tmpJust[[2]]
## Convert 'x' and 'y' to unit objects
if (inherits(x, "unit")) {
X <- x
} else {
X <- unit(x, default.units)
}
if (inherits(y, "unit")) {
Y <- y
} else {
Y <- unit(y, default.units)
}
## Create parent viewport
if (anyResize) {
vpWidth <- sum(layWidths)
vpHeight <- sum(layHeights)
} else {
## In this branch, everything has fixed size. Therefore it is
## possible to check if the text elements will overflow the
## layout and by how much. The margin is then widened to cover
## all the oversized elements..
leftHang <- 0
rightHang <- 0
if ((have.main && mainWidthInches > xCell) ||
(have.xlab && xlabWidthInches > xCell) ||
have.xAxisLabels) {
xLeft <- 0
if (have.ylab) {
xLeft <- xLeft + ylabWidthInches + ylabMarInches
}
if (have.yAxisLabels) {
xLeft <- xLeft + maxYAxisWidthInches + xyMarginSideInches
}
xCenter <- xLeft + xCell / 2
if (have.main) {
leftHang <- max(leftHang, mainWidthInches / 2 - xCenter)
rightHang <-
max(rightHang,
xCenter + mainWidthInches / 2 - rigidWidthInches)
}
if (have.xlab) {
leftHang <- max(leftHang, xlabWidthInches / 2 - xCenter)
rightHang <-
max(rightHang,
xCenter + xlabWidthInches / 2 - rigidWidthInches)
}
if (have.xAxisLabels) {
colSeq <- cellSideInches *
(xAxisX2 + seq(from = 0, by = 1, length.out = nCols))
xAxisLabelLeftMaxHang <-
xLeft - min(colSeq + xAxisLabelLeft)
xAxisLabelRightMaxHang <-
max(colSeq + xAxisLabelRight) - xCell
leftHang <- max(leftHang, xAxisLabelLeftMaxHang)
rightHang <- max(rightHang, xAxisLabelRightMaxHang)
}
}
bottomHang <- 0
topHang <- 0
if ((have.ylab && ylabHeightInches > yCell) || have.yAxisLabels) {
yBottom <- 0
if (have.xlab) {
yBottom <- yBottom + xlabHeightInches + xlabMarInches
}
if (have.xAxisLabels) {
yBottom <- yBottom + maxXAxisHeightInches + xyMarginSideInches
}
yCenter <- yBottom + yCell / 2
if (have.ylab) {
bottomHang <- max(bottomHang, ylabHeightInches / 2 - yCenter)
topHang <-
max(topHang,
yCenter + ylabHeightInches / 2 - rigidHeightInches)
}
if (have.yAxisLabels) {
rowSeq <- cellSideInches *
(yAxisY2 +
seq(from = nRows - 1, by = -1, length.out = nRows))
yAxisLabelBottomMaxHang <-
yBottom - min(rowSeq + yAxisLabelBottom)
yAxisLabelTopMaxHang <-
max(rowSeq + yAxisLabelTop) - yCell
bottomHang <- max(bottomHang, yAxisLabelBottomMaxHang)
topHang <- max(topHang, yAxisLabelTopMaxHang)
}
if (labelsCex) {
bigHalfWidths <- labelHalfWidths[bigCex]
bigTops <- labelTops[bigCex]
bigBottoms <- labelBottoms[bigCex]
bigCex2 <- rep(0, length(bigCex))
nBigCex <- sum(bigCex)
bigCex2[bigCex] <- 1:nBigCex
bigCexLong <- rep_len(bigCex, nRows * nCols)
bigCex2Long <- rep_len(bigCex2, nRows * nCols)[bigCexLong]
rowNums <- rep(nRows:1, nCols)[bigCexLong]
colNums <- rep(1:nCols, each = nRows)[bigCexLong]
for (i in seq_len(nBigCex)) {
matches <- which(bigCex2Long == i)
rowMatches <- rowNums[matches]
colMatches <- colNums[matches]
halfWidth <- bigHalfWidths[i]
rowSeq <- (rowMatches - 0.5) * cellSideInches
colSeq <- (colMatches - 0.5) * cellSideInches
labelLeftMaxHang <- max(-colSeq) + halfWidth - xLeft
labelRightMaxHang <- max(colSeq) + halfWidth - xCell
labelBottomMaxHang <- yBottom - min(rowSeq) - bigBottoms[i]
labelTopMaxHang <- max(rowSeq) + bigTops[i] - yCell
leftHang <- max(leftHang, labelLeftMaxHang)
rightHang <- max(rightHang, labelRightMaxHang)
bottomHang <- max(bottomHang, labelBottomMaxHang)
topHang <- max(topHang, labelTopMaxHang)
}
}
}
vpWidth <- unit(rigidWidthInches + leftHang + rightHang, "inches")
vpHeight <- unit(rigidHeightInches + bottomHang + topHang, "inches")
if (leftHang > 0) {
layWidths <- unit.c(unit(leftHang, "inches"), layWidths[-1])
}
if (rightHang > 0) {
layCols <- layCols + 1
layWidths <- unit.c(layWidths, unit(rightHang, "inches"))
}
if (topHang > 0) {
layHeights <- unit.c(unit(topHang, "inches"), layHeights[-1])
}
if (bottomHang > 0) {
layRows <- layRows + 1
layHeights <- unit.c(layHeights, unit(bottomHang, "inches"))
}
}
the.layout <- grid.layout(layRows, layCols,
widths = layWidths, heights = layHeights)
parentVp <- viewport(x = X, y = Y, width = vpWidth, height = vpHeight,
just = just, clip = clip,
layout = the.layout, name = "Parent")
## A gList (the grobs) and a vpTree (the viewports) go to a gTree
grobs <- do.call("gList", c(innerGrobs[seq_len(innerCount)],
outerGrobs[seq_len(outerCount)]))
childVps <- do.call("vpList", vps[seq_len(vpCounter)])
viewports <- vpTree(parent = parentVp, children = childVps)
if (resizeLabels && resizeTable && have.labels) {
nResizeLabels <- sum(labelsNotNA)
} else {
nResizeLabels <- 0
}
myPlot <-
gTree(children = grobs, childrenvp = viewports,
width = vpWidth, height = vpHeight, vpLayout = the.layout,
x = X, y = Y, just = just, clip = clip,
internals = list(hjust = hjust, vjust = vjust,
resizeAxes = resizeAxes, labelDim = xy[["labelDim"]],
xAxisWidth = xAxisWidth, xAxisHeight = xAxisHeight,
yAxisWidth = yAxisWidth, yAxisHeight = yAxisHeight,
cellSide = cellSide, xAxisSide = xAxisSide,
yAxisSide = yAxisSide, nRows = nRows, nCols = nCols,
labelsNotNA = labelsNotNA, xAxisNotNA = xAxisNotNA,
yAxisNotNA = yAxisNotNA, labels = internalLabels,
labelPars = internalLabelPars, axesPar = axesParList,
xAxisLabels = xAxisLabels2[xAxisNotNA],
yAxisLabels = yAxisLabels2[yAxisNotNA],
xAxisRot = xAxisRot, yAxisRot = yAxisRot,
xAxisJust = xAxisJust, yAxisJust = yAxisJust,
textNames = textNames, xNames = xNames, yNames = yNames,
nResizeLabels = nResizeLabels, childVps = childVps),
cl = "sisalTable", name = name, gp = gp, vp = vp)
if (draw) {
grid.draw(myPlot)
}
## An object of class c("sisalTable", "gTree", ...) is returned
invisible(myPlot)
}
Try the sisal package in your browser
Any scripts or data that you put into this service are public.
sisal documentation built on Feb. 16, 2020, 1:07 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions fgGrey twoPartName twoPartNameChar leftRight.sisalTable bottomTop.sisalTable widthDetails.sisalTable heightDetails.sisalTable xDetails.sisalTable yDetails.sisalTable makeContent.sisalTable validDetails.sisalTable editDetails.sisalTable tableMeasures minConvertXY sisalTable
Documented in sisalTable
### File R/sisalTable.R
### This file is part of the sisal package for R.
###
### Copyright (C) 2015, 2020 Aalto University
###
### This program is free software; you can redistribute it and/or modify
### it under the terms of the GNU General Public License as published by
### the Free Software Foundation; either version 2 of the License, or
### (at your option) any later version.
###
### This program is distributed in the hope that it will be useful,
### but WITHOUT ANY WARRANTY; without even the implied warranty of
### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
### GNU General Public License for more details.
###
### A copy of the GNU General Public License is available at
### http://www.r-project.org/Licenses/
## Returns a grey value (as an R color string) that has largest
## minimum distance (best contrast) to bgLumas (numeric where 0 is
## black and 1 is white).
fgGrey <- function(bgLumas) {
distWhite <- min(1 - bgLumas)
distBlack <- min(bgLumas)
meanLuma <- mean(bgLumas)
distMean <- min(abs(meanLuma - bgLumas))
switch(which.max(c(distBlack, distWhite, distMean)),
"black", "white", rgb(meanLuma, meanLuma, meanLuma))
}
## A "standard" way of creating two-part names for viewports / grobs
twoPartName <- function(part1, part2) {
paste(format(part1, scientific = FALSE, trim = TRUE, justify = "none"),
format(part2, scientific = FALSE, trim = TRUE, justify = "none"),
sep=".")
}
## when both part1 and part2 are already character vectors
twoPartNameChar <- function(part1, part2) {
paste(part1, part2, sep=".")
}
### Drawing time auxiliary functions for sisalTable
leftRight.sisalTable <- function(x) {
X <- convertUnit(x[["x"]], unitTo = "inches", axisFrom = "x",
typeFrom = "location", valueOnly = TRUE)
hjust <- x[["internals"]][["hjust"]]
width <- convertUnit(x[["width"]], unitTo = "inches", axisFrom = "x",
typeFrom = "dimension", valueOnly = TRUE)
left <- X - width * hjust
right <- left + width
c(left, right)
}
bottomTop.sisalTable <- function(x) {
Y <- convertUnit(x[["y"]], unitTo = "inches", axisFrom = "y",
typeFrom = "location", valueOnly = TRUE)
vjust <- x[["internals"]][["vjust"]]
height <- convertUnit(x[["height"]], unitTo = "inches", axisFrom = "y",
typeFrom = "dimension", valueOnly = TRUE)
bottom <- Y - height * vjust
top <- bottom + height
c(bottom, top)
}
### S3 methods for sisalTable
## According to "frame" vignette, widthDetails and heightDetails
## should use absolute.size() which returns "null" units if the grob
## does not have an absolute size. I tried absolute.size(x$width),
## absolute.size(x$height), but that only gave an obscure error message:
##
## Error in UseMethod("absolute.units") :
## no applicable method for 'absolute.units' applied to an object of class "unit"
## > traceback()
## 19: FUN(X[[1L]], ...)
## 18: lapply(unit, absolute.units)
## 17: absolute.units.unit.list(unit$arg1)
## 16: absolute.units(unit$arg1)
## 15: unit.arithmetic("sum", absolute.units(unit$arg1))
## 14: absolute.units.unit.arithmetic(unit)
## 13: absolute.units(unit)
## 12: absolute.size(x$width)
## 11: widthDetails.sisalTable(x)
## 10: widthDetails(x)
##
## The error message does not make sense. The (partial) traceback
## isn't too helpful either. So, let's use convertUnit(unitTo =
## "inches") instead.
##
## * Advantage: gives the size of the grob, even if the size is not
## absolute (fixed). Seems reasonable to me.
##
## * Downside: does not work as discussed in the vignette. The
## vignette may be outdated, though. For example, contrary to what
## is stated in the vignette, neither widthDetails.rect() nor
## heightDetails.rect() uses absolute.size(), which gets very little
## use anywhere. Makes me wonder if there is a problem in
## absolute.size(), or if I have overlooked something.
##
## This was checked on R trunk SVN revision 61876.
widthDetails.sisalTable <- function(x, ...) {
convertUnit(x[["width"]], unitTo = "inches", axisFrom = "x",
typeFrom = "dimension")
}
heightDetails.sisalTable <- function(x, ...) {
convertUnit(x[["height"]], unitTo = "inches", axisFrom = "y",
typeFrom = "dimension")
}
## xDetails and yDetails methods of sisalTable are vectorized
## w.r.t. theta, but it may not be possible to take advantage of this
## through grid
xDetails.sisalTable <- function(x, theta, ...) {
leftRight <- leftRight.sisalTable(x)
bottomTop <- bottomTop.sisalTable(x)
width <- leftRight[2] - leftRight[1]
height <- bottomTop[2] - bottomTop[1]
X <- (leftRight[1] + leftRight[2]) / 2
Y <- (bottomTop[1] + bottomTop[2]) / 2
rGrob <- rectGrob(x = X, y = Y, width = width, height = height,
default.units = "inches")
do.call("unit.c", lapply(theta, function (x) xDetails(rGrob, x)))
}
yDetails.sisalTable <- function(x, theta, ...) {
leftRight <- leftRight.sisalTable(x)
bottomTop <- bottomTop.sisalTable(x)
width <- leftRight[2] - leftRight[1]
height <- bottomTop[2] - bottomTop[1]
X <- (leftRight[1] + leftRight[2]) / 2
Y <- (bottomTop[1] + bottomTop[2]) / 2
rGrob <- rectGrob(x = X, y = Y, width = width, height = height,
default.units = "inches")
do.call("unit.c", lapply(theta, function (x) yDetails(rGrob, x)))
}
makeContent.sisalTable <- function(x, ...) {
x2 <- x
## Edit content labels
internals <- x[["internals"]]
cellSide <- convertWidth(internals[["cellSide"]],
unitTo = "inches", valueOnly = TRUE)
nRows <- internals[["nRows"]]
nCols <- internals[["nCols"]]
nResize <- internals[["nResizeLabels"]]
if (nResize > 0) {
labelFS <- cellSide / internals[["labelDim"]]
labelsNotNA <- internals[["labelsNotNA"]]
nLabels <- length(labelsNotNA)
textNames <- internals[["textNames"]]
labelPars <- internals[["labelPars"]]
for (i in seq_along(labelPars)) {
labelPars[[i]][["fontsize"]] <- labelFS
}
labelMeasurements <-
dynTextGrob(internals[["labels"]], adjustJust = TRUE,
gp = labelPars, resize = FALSE,
takeMeasurements = TRUE)
labelJust <- numeric(nLabels)
justTmp <- labelMeasurements[["vjust"]]
labelJust[labelsNotNA] <- justTmp[1:nResize]
linearRowCol <- 0
for (Col in seq_len(nCols)) {
## Actual contents of the table
for (Row in seq_len(nRows)) {
labelsMod <- linearRowCol %% nLabels + 1
if (labelsNotNA[labelsMod]) {
thisName <- textNames[linearRowCol + 1]
labelPar <- gparToList(getGrob(x, thisName)[["gp"]])
labelPar[["fontsize"]] <- labelFS
x2 <- editGrob(x2, thisName,
gp = do.call("gpar", labelPar),
vjust = labelJust[labelsMod])
}
linearRowCol <- linearRowCol + 1
}
}
}
if (internals[["resizeAxes"]]) {
## Edit x axis labels
axesFS <- NULL
xAxisSide <- internals[["xAxisSide"]]
if (!is.null(xAxisSide)) {
xAxisSide <- convertHeight(xAxisSide,
unitTo = "inches", valueOnly = TRUE)
axesFS <- min(cellSide / internals[["xAxisWidth"]],
xAxisSide / internals[["xAxisHeight"]])
xAxisNotNA <- internals[["xAxisNotNA"]]
axesPar <- internals[["axesPar"]]
axesPar[["fontsize"]] <- axesFS
axesPar <- do.call("gpar", axesPar)
xNames <- internals[["xNames"]]
xMeasurements <-
dynTextGrob(internals[["xAxisLabels"]], resize = FALSE,
gp = axesPar, rotJust = TRUE,
rot = internals[["xAxisRot"]],
takeMeasurements = TRUE,
just = internals[["xAxisJust"]], adjustJust = TRUE)
hjust <- numeric(nCols)
vjust <- numeric(nCols)
hjust[xAxisNotNA] <- xMeasurements[["hjust"]]
vjust[xAxisNotNA] <- xMeasurements[["vjust"]]
xShift <- numeric(nCols)
yShift <- numeric(nCols)
xShift[xAxisNotNA] <- xMeasurements[["xShift"]]
yShift[xAxisNotNA] <- xMeasurements[["yShift"]]
nXAxis <- length(xAxisNotNA)
for (Col in seq_len(nCols)[xAxisNotNA]) {
xMod <- (Col - 1) %% nXAxis + 1
thisName <- xNames[Col]
thisGrob <- getGrob(x, thisName)
x2 <- editGrob(x2, thisName, gp = axesPar,
x=thisGrob[["x"]] + unit(xShift[xMod],"inches"),
y=thisGrob[["y"]] + unit(yShift[xMod],"inches"),
hjust = hjust[xMod], vjust = vjust[xMod])
}
}
## Edit y axis labels
yAxisSide <- internals[["yAxisSide"]]
if (!is.null(yAxisSide)) {
if (is.null(axesFS)) {
yAxisSide <- convertWidth(yAxisSide,
unitTo = "inches", valueOnly = TRUE)
axesFS <- min(cellSide / internals[["yAxisHeight"]],
yAxisSide / internals[["yAxisWidth"]])
axesPar <- internals[["axesPar"]]
axesPar[["fontsize"]] <- axesFS
axesPar <- do.call("gpar", axesPar)
}
yAxisNotNA <- internals[["yAxisNotNA"]]
yNames <- internals[["yNames"]]
yMeasurements <-
dynTextGrob(internals[["yAxisLabels"]], resize = FALSE,
gp = axesPar, rotJust = TRUE,
rot = internals[["yAxisRot"]],
takeMeasurements = TRUE,
just = internals[["yAxisJust"]], adjustJust = TRUE)
hjust <- numeric(nRows)
vjust <- numeric(nRows)
hjust[yAxisNotNA] <- yMeasurements[["hjust"]]
vjust[yAxisNotNA] <- yMeasurements[["vjust"]]
xShift <- numeric(nRows)
yShift <- numeric(nRows)
xShift[yAxisNotNA] <- yMeasurements[["xShift"]]
yShift[yAxisNotNA] <- yMeasurements[["yShift"]]
nYAxis <- length(yAxisNotNA)
for (Row in seq_len(nRows)[yAxisNotNA]) {
yMod <- (Row - 1) %% nYAxis + 1
thisName <- yNames[Row]
thisGrob <- getGrob(x, thisName)
x2 <- editGrob(x2, thisName, gp = axesPar,
x=thisGrob[["x"]] + unit(xShift[yMod],"inches"),
y=thisGrob[["y"]] + unit(yShift[yMod],"inches"),
hjust = hjust[yMod], vjust = vjust[yMod])
}
}
}
## Final edited grobTree
x2
}
validDetails.sisalTable <- function(x, ...) {
if (!inherits(x, "gTree")) {
stop("a sisalTable object must be a gTree")
}
slotNames <- names(x)
requiredNames <- c("width", "height", "vpLayout", "x", "y", "just",
"clip", "internals", "name", "gp", "vp")
## Testing that all slots are present
if (!all(requiredNames %in% slotNames)) {
stop("slots missing")
}
## Testing 'x', 'y', 'width', 'height', 'clip', 'just'
X <- x[["x"]]
Y <- x[["y"]]
width <- x[["width"]]
height <- x[["height"]]
if (!inherits(X, "unit") || !inherits(Y, "unit") ||
!inherits(width, "unit") || !inherits(height, "unit")) {
stop("'x', 'y', 'width' and 'height' must be grid units")
}
if (length(X) != 1 || length(Y) != 1 ||
length(width) != 1 || length(height) != 1) {
stop("'x', 'y', 'width' and 'height' must have one element each")
}
clip <- x[["clip"]]
if (!(length(clip) == 1 &&
((is.character(clip) && clip %in% c("on", "inherit", "off")) ||
(is.logical(clip) && is.finite(clip))))) {
stop("'clip' must be TRUE, FALSE, \"on\", \"inherit\" or \"off\"")
}
just <- x[["just"]]
if (!(((is.numeric(just) && all(is.finite(just))) ||
is.character(just)) && length(just) > 0 && length(just) < 3)) {
stop("'just' must be a finite numeric or character vector of length 1 or 2")
}
## Testing internal variables
internals <- x[["internals"]]
if (!is.list(internals)) {
stop(gettextf("'%s' must be a list", 'x[["internals"]]',
domain = "R-sisal"), domain = NA)
}
varNames <-
c("hjust", "vjust", "nResizeLabels", "resizeAxes", "labelDim",
"xAxisWidth", "xAxisHeight", "yAxisWidth", "yAxisHeight", "cellSide",
"xAxisSide", "yAxisSide", "nRows", "nCols", "labelsNotNA",
"xAxisNotNA", "yAxisNotNA", "labels", "labelPars", "axesPar",
"xAxisLabels", "yAxisLabels", "xAxisRot", "yAxisRot", "xAxisJust",
"yAxisJust", "textNames", "xNames", "yNames", "childVps")
if (!all(varNames %in% names(internals))) {
stop(gettextf("'%s' must have the required variables",
'x[["internals"]]', domain = "R-sisal"), domain = NA)
}
hjust <- internals[["hjust"]]
vjust <- internals[["vjust"]]
nResize <- internals[["nResizeLabels"]]
resizeAxes <- internals[["resizeAxes"]]
labelDim <- internals[["labelDim"]]
xAxisWidth <- internals[["xAxisWidth"]]
xAxisHeight <- internals[["xAxisHeight"]]
yAxisWidth <- internals[["yAxisWidth"]]
yAxisHeight <- internals[["yAxisHeight"]]
cellSide <- internals[["cellSide"]]
xAxisSide <- internals[["xAxisSide"]]
yAxisSide <- internals[["yAxisSide"]]
nRows <- internals[["nRows"]]
nCols <- internals[["nCols"]]
labelsNotNA <- internals[["labelsNotNA"]]
labels <- internals[["labels"]]
labelPars <- internals[["labelPars"]]
xAxisNotNA <- internals[["xAxisNotNA"]]
yAxisNotNA <- internals[["yAxisNotNA"]]
xAxisLabels <- internals[["xAxisLabels"]]
yAxisLabels <- internals[["yAxisLabels"]]
xAxisRot <- internals[["xAxisRot"]]
yAxisRot <- internals[["yAxisRot"]]
xAxisJust <- internals[["xAxisJust"]]
yAxisJust <- internals[["yAxisJust"]]
textNames <- internals[["textNames"]]
xNames <- internals[["xNames"]]
yNames <- internals[["yNames"]]
stopifnot(is.numeric(hjust), is.numeric(vjust), is.numeric(nResize),
is.logical(resizeAxes), is.numeric(labelDim),
is.numeric(xAxisWidth), is.numeric(xAxisHeight),
is.numeric(yAxisWidth), is.numeric(yAxisHeight),
inherits(cellSide, "unit"), is.numeric(nRows), is.numeric(nCols),
is.list(internals[["axesPar"]]), is.numeric(xAxisRot),
is.numeric(yAxisRot),
inherits(internals[["childVps"]], "vpList"))
stopifnot(length(hjust) == 1, length(vjust) == 1, length(nResize) == 1,
length(resizeAxes) == 1, length(labelDim) == 1,
length(xAxisWidth) == 1, length(xAxisHeight) == 1,
length(yAxisWidth) == 1, length(yAxisHeight) == 1,
length(cellSide) == 1, length(nRows) == 1, length(nCols) == 1,
length(xAxisRot) == 1, length(yAxisRot) == 1)
stopifnot(is.finite(hjust), is.finite(vjust),
is.finite(nResize) && nResize >= 0, is.finite(resizeAxes),
is.finite(labelDim) && labelDim >= 0,
is.finite(nRows) && nRows > 0, is.finite(nCols) && nCols > 0,
is.finite(xAxisRot), is.finite(yAxisRot))
stopifnot(!resizeAxes || is.null(xAxisSide) ||
(is.finite(xAxisWidth) && xAxisWidth >= 0 &&
is.finite(xAxisHeight) && xAxisHeight >= 0 &&
inherits(xAxisSide, "unit") && length(xAxisSide) == 1 &&
is.logical(xAxisNotNA) && length(xAxisNotNA) >= 1 &&
all(is.finite(xAxisNotNA)) && is.vector(xAxisLabels) &&
length(xAxisLabels) >= 1 && is.character(xNames) &&
length(xNames) == nCols))
stopifnot(!resizeAxes || is.null(yAxisSide) ||
(is.finite(yAxisWidth) && yAxisWidth >= 0 &&
is.finite(yAxisHeight) && yAxisHeight >= 0 &&
inherits(yAxisSide, "unit") && length(yAxisSide) == 1 &&
is.logical(yAxisNotNA) && length(yAxisNotNA) >= 1 &&
all(is.finite(yAxisNotNA)) && is.vector(yAxisLabels) &&
length(yAxisLabels) >= 1 && is.character(yNames) &&
length(yNames) == nRows))
stopifnot(length(xAxisJust) > 0,
is.character(xAxisJust) ||
(is.numeric(xAxisJust) && all(is.finite(xAxisJust))))
stopifnot(length(yAxisJust) > 0,
is.character(yAxisJust) ||
(is.numeric(yAxisJust) && all(is.finite(yAxisJust))))
if (nResize > 0) {
stopifnot(is.logical(labelsNotNA), is.finite(labelsNotNA),
is.character(textNames), length(textNames) == nRows * nCols,
is.list(labelPars), length(labelPars) >= 2,
vapply(labelPars, is.list, logical(1)),
is.vector(labels), length(labels) >= 2)
}
x
}
editDetails.sisalTable <- function(x, specs) {
x2 <- NextMethod("editDetails", x)
slotNames <- names(specs)
if ("internals" %in% slotNames) {
stop("'internals' must not be edited")
}
if (any(c("width", "height", "x", "y",
"just", "clip", "vpLayout") %in% slotNames)) {
internals <- x2[["internals"]]
parentVp <- viewport(x = x2[["x"]], y = x2[["y"]],
width = x2[["width"]], height = x2[["height"]],
just = x2[["just"]], clip = x2[["clip"]],
layout = x2[["vpLayout"]], name = "Parent")
x2 <- editGrob(x2, childrenvp = vpTree(parent = parentVp,
children = internals[["childVps"]]))
if ("just" %in% slotNames) {
x2[["internals"]][c("hjust", "vjust")] <- justHV(x2[["just"]])
}
}
x2
}
### Main functions
## Computes sizes of different graphical elements. Returns those and
## suggested relative space allocations for the various parts of a
## table (based on computed sizes and target ratios specified as
## arguments). All the gp* arguments should be (lists of) ordinary
## lists containing settings accepted by gpar().
tableMeasures <- function(xAxisLabels, yAxisLabels, labels, targetAxesRatio,
gpAxes = list(), gpLabels,
main, xlab, ylab, gpMain, gpLab, nRows, nCols,
targetMainRatio = 0.15, targetLabRatio = 0.15,
scaleLabels = FALSE, xlabExpand = 1, ylabExpand = 1,
mainExpand = 1, xAxisRot = 0, yAxisRot = 0,
xAxisJust, yAxisJust) {
nX <- length(xAxisLabels)
if (nX > 0) {
tmp <- dynTextGrob(xAxisLabels, gp = do.call("gpar", gpAxes),
rot = xAxisRot, rotJust = TRUE,
just = xAxisJust, takeMeasurements = TRUE,
adjustJust = TRUE)
xAxisWidth <- tmp[["sizingWidth"]]
xAxisHeight <- tmp[["sizingHeight"]]
xAxisNZ <- tmp[["nzDim"]]
} else {
xAxisWidth <- NA_real_
xAxisHeight <- NA_real_
xAxisNZ <- FALSE
}
nY <- length(yAxisLabels)
if (nY > 0) {
tmp <- dynTextGrob(yAxisLabels, gp = do.call("gpar", gpAxes),
rot = yAxisRot, rotJust = TRUE,
just = yAxisJust, takeMeasurements = TRUE,
adjustJust = TRUE)
yAxisWidth <- tmp[["sizingWidth"]]
yAxisHeight <- tmp[["sizingHeight"]]
yAxisNZ <- tmp[["nzDim"]]
} else {
yAxisWidth <- NA_real_
yAxisHeight <- NA_real_
yAxisNZ <- FALSE
}
labelCex <- 0
nLabels <- length(labels)
for (i in seq_along(gpLabels)) {
cexTemp <- gpLabels[[i]][["cex"]]
if (is.null(cexTemp)) {
labelCex <- max(1, labelCex)
} else {
labelCex <- max(cexTemp, labelCex)
}
}
mfs <- dynTextGrob(c(labels, "x"), adjustJust = TRUE,
gp = c(gpLabels, list(list())), takeMeasurements = TRUE)
labelDim <- max(unlist(mfs[c("sizingWidth", "sizingHeight")]))
tmpSeq <- seq_len(nLabels)
labelNZ <- mfs[["nzDim"]][tmpSeq]
if (length(main) > 0) {
tmp <- dynTextGrob(main, gp = gpMain, takeMeasurements = TRUE)
maxMainWidth <- tmp[["sizingWidth"]]
maxMainHeight <- tmp[["sizingHeight"]]
mainNZ <- tmp[["nzDim"]]
} else {
maxMainWidth <- NA_real_
maxMainHeight <- NA_real_
mainNZ <- FALSE
}
if (length(xlab) > 0) {
tmp <- dynTextGrob(xlab, gp = gpLab, takeMeasurements = TRUE)
maxXlabWidth <- tmp[["sizingWidth"]]
maxXlabHeight <- tmp[["sizingHeight"]]
xlabNZ <- tmp[["nzDim"]]
} else {
maxXlabWidth <- NA_real_
maxXlabHeight <- NA_real_
xlabNZ <- FALSE
}
if (length(ylab) > 0) {
tmp <- dynTextGrob(ylab, gp = gpLab, rot = 90, takeMeasurements = TRUE)
maxYlabWidth <- tmp[["sizingWidth"]]
maxYlabHeight <- tmp[["sizingHeight"]]
ylabNZ <- tmp[["nzDim"]]
} else {
maxYlabWidth <- NA_real_
maxYlabHeight <- NA_real_
ylabNZ <- FALSE
}
targetAxesRatio2 <- targetAxesRatio * labelCex
if (is.na(xAxisHeight)) {
xAxisRatio <- Inf
} else if (targetAxesRatio2 * xAxisWidth < labelDim) {
xAxisRatio <- xAxisHeight * targetAxesRatio2 / labelDim
} else {
xAxisRatio <- xAxisHeight / xAxisWidth
}
if (is.na(yAxisWidth)) {
yAxisRatio <- Inf
} else if (targetAxesRatio2 * yAxisHeight < labelDim) {
yAxisRatio <- yAxisWidth * targetAxesRatio2 / labelDim
} else {
yAxisRatio <- yAxisWidth / yAxisHeight
}
xFs <- min(1 / xAxisWidth, xAxisRatio / xAxisHeight)
yFs <- min(1 / yAxisHeight, yAxisRatio / yAxisWidth)
xAxisRatio <- min(xAxisRatio, xAxisRatio * yFs / xFs, na.rm = TRUE)
yAxisRatio <- min(yAxisRatio, yAxisRatio * xFs / yFs, na.rm = TRUE)
if (!is.na(xFs) || !is.na(yFs)) {
xyFs <- min(xFs, yFs, na.rm = TRUE)
if (scaleLabels && !is.na(labelDim) &&
xyFs < targetAxesRatio2 / labelDim) {
fontScaleIn <- xyFs / (targetAxesRatio2 / labelDim)
labelDim <- labelDim / fontScaleIn
}
} else {
xyFs <- NA_real_
}
axesCex <- gpAxes[["cex"]]
if (is.null(axesCex)) {
axesCex <- 1
}
mainRatio <- min(min(1, mainExpand) * nCols * maxMainHeight / maxMainWidth,
mainExpand * max(targetMainRatio * nRows,
maxMainHeight * labelCex / labelDim,
maxMainHeight * axesCex * xyFs,
na.rm = TRUE), na.rm = TRUE)
xlabRatio <- min(min(1, xlabExpand) * nCols * maxXlabHeight / maxXlabWidth,
xlabExpand * max(targetLabRatio * min(nRows, nCols),
maxXlabHeight * labelCex / labelDim,
maxXlabHeight * axesCex * xyFs,
na.rm = TRUE), na.rm = TRUE)
ylabRatio <- min(min(1, ylabExpand) * nRows * maxYlabWidth / maxYlabHeight,
ylabExpand * max(targetLabRatio * min(nRows, nCols),
maxYlabWidth * labelCex / labelDim,
maxYlabWidth * axesCex * xyFs,
na.rm = TRUE), na.rm = TRUE)
ylabScale <- min(nRows / maxYlabHeight, ylabRatio / maxYlabWidth) /
ylabExpand
xlabScale <- min(nCols / maxXlabWidth, xlabRatio / maxXlabHeight) /
xlabExpand
if (!is.na(ylabScale) && !is.na(xlabScale)) {
if (ylabScale > xlabScale) {
ylabRatio <- xlabScale / ylabScale * ylabRatio
} else {
xlabRatio <- ylabScale / xlabScale * xlabRatio
}
}
## * *Ratio: Ratio of space reserved (along a dimension) for
## various graphical objects to length of the sides of each
## (square) cell in the table
## * *Dim, *Width, *Height: Maximum normalized size (Dim: max of
## width and height) of a graphical object. Normalized means size
## of the graphical object in points divided by the specified font
## size.
list(xAxisRatio = xAxisRatio, # x axis labels (one for each column)
yAxisRatio = yAxisRatio, # y axis labels (one for each row)
labelDim = labelDim, # labels in the table
labelNZ = labelNZ,
xAxisWidth = xAxisWidth, # x axis labels
xAxisHeight = xAxisHeight, # x axis labels
xAxisNZ = xAxisNZ,
yAxisWidth = yAxisWidth, # y axis labels
yAxisHeight = yAxisHeight, # y axis labels
yAxisNZ = yAxisNZ,
mainRatio = mainRatio, # main title
mainWidth = maxMainWidth, # main title
mainHeight = maxMainHeight, # main title
mainNZ = mainNZ,
xlabRatio = xlabRatio, # x label (one across all cols)
ylabRatio = ylabRatio, # y label (one across all rows)
xlabWidth = maxXlabWidth, # x label
xlabHeight = maxXlabHeight, # x label
ylabWidth = maxYlabWidth, # y label
ylabHeight = maxYlabHeight, # y label
xlabNZ = xlabNZ,
ylabNZ = ylabNZ)
}
## Convert unit() object x to inches (value only) in the current
## context. Uses both axisFrom = "x" and axisFrom = "y" and takes the
## minimum.
minConvertXY <- function(x) {
min(convertUnit(x, unitTo = "inches",
axisFrom = "x", typeFrom = "dimension",
valueOnly = TRUE),
convertUnit(x, unitTo = "inches",
axisFrom = "y", typeFrom = "dimension",
valueOnly = TRUE))
}
sisalTable <- function(labels = matrix(seq_len(12), 3, 4),
nRows = NROW(labels), nCols = NCOL(labels),
bg = sample(colors(), nRows * nCols, replace=TRUE),
stripeCol = NULL,
fg = NULL, naFill = "white", naStripes = "grey50",
main = NULL, xlab = NULL, ylab = NULL,
xAxisLabels = NULL, yAxisLabels = NULL,
draw = TRUE, outerRect = TRUE, innerLines = TRUE,
nStripes = 7, stripeRot = 45, stripeWidth = 0.2,
stripeScale = 0.95, resizeText = TRUE,
resizeTable = TRUE, resizeMain = resizeText,
resizeLab = resizeText, resizeAxes = resizeText,
resizeLabels = resizeTable && resizeText,
x = unit(0.5, "npc"), y = unit(0.5, "npc"),
width = unit(0.97, "npc"), height = unit(0.97, "npc"),
default.units = "npc", just = "center",
clip = "inherit", xAxisRot = 0, yAxisRot = 0,
xAxisJust = c(0.5, 1), xAxisX = 0.5, xAxisY = 1,
yAxisJust = c(1, 0.5), yAxisX = 1, yAxisY = 0.5,
mainMargin = if(resizeMain) 0.15 else unit(8, "points"),
xlabMargin = if (resizeLab) 0.1 else unit(5, "points"),
ylabMargin = if (resizeLab) 0.1 else unit(5, "points"),
axesMargin = if (resizeAxes) 0.1 else unit(5, "points"),
axesSize = 0.8, forceAxesSize = FALSE, mainSize = 1,
xlabSize = 1, ylabSize = 1,
mainPar = gpar(fontface="bold", fontsize=14),
labPar = gpar(fontface="plain", fontsize=14),
labelPars = gpar(fontsize = 20, cex = 0.6),
axesPar = gpar(fontsize = 10),
rectPar = gpar(), linePar = gpar(),
name = NULL, gp = NULL, vp = NULL) {
## Argument checking
stopifnot(is.numeric(xAxisX), length(xAxisX) == 1,
is.finite(xAxisX), is.numeric(xAxisY), length(xAxisY) == 1,
is.finite(xAxisY), is.numeric(yAxisX), length(yAxisX) == 1,
is.finite(yAxisX), is.numeric(yAxisY), length(yAxisY) == 1,
is.finite(yAxisY))
stopifnot(identical(resizeMain, TRUE) || identical(resizeMain, FALSE),
identical(resizeLab, TRUE) || identical(resizeLab, FALSE),
identical(resizeLabels, TRUE) || identical(resizeLabels, FALSE),
identical(resizeAxes, TRUE) || identical(resizeAxes, FALSE),
identical(resizeTable, TRUE) || identical(resizeTable, FALSE),
identical(draw, TRUE) || identical(draw, FALSE),
identical(outerRect, TRUE) || identical(outerRect, FALSE),
identical(innerLines, TRUE) || identical(innerLines, FALSE),
identical(forceAxesSize, TRUE) ||
identical(forceAxesSize, FALSE))
stopifnot(length(just) > 0,
is.character(just) || (is.numeric(just) && all(is.finite(just))))
stopifnot(length(xAxisJust) > 0,
is.character(xAxisJust) ||
(is.numeric(xAxisJust) && all(is.finite(xAxisJust))))
stopifnot(length(yAxisJust) > 0,
is.character(yAxisJust) ||
(is.numeric(yAxisJust) && all(is.finite(yAxisJust))))
stopifnot(length(just) > 0,
is.character(just) || (is.numeric(just) && all(is.finite(just))))
stopifnot(is.null(name) ||
(is.character(name) && length(name) == 1 && !is.na(name)))
stopifnot(inherits(mainPar, "gpar"), inherits(labPar, "gpar"),
inherits(labelPars, "gpar") ||
(is.list(labelPars) &&
all(vapply(labelPars, inherits, TRUE, what = "gpar"))),
inherits(axesPar, "gpar"), inherits(rectPar, "gpar"),
inherits(linePar, "gpar"))
stopifnot(is.numeric(axesSize), length(axesSize) == 1, is.finite(axesSize),
axesSize > 0, is.numeric(mainSize), length(mainSize) == 1,
is.finite(mainSize), mainSize > 0, is.numeric(xlabSize),
length(xlabSize) == 1, is.finite(xlabSize), xlabSize > 0,
is.numeric(ylabSize), length(ylabSize) == 1, is.finite(ylabSize),
ylabSize > 0)
stopifnot(is.numeric(nRows), length(nRows) == 1,
is.finite(nRows), nRows > 0, round(nRows) == nRows,
is.numeric(nCols), length(nCols) == 1, is.finite(nCols),
nCols > 0, round(nCols) == nCols)
stopifnot(is.numeric(xAxisRot), length(xAxisRot) == 1, is.finite(xAxisRot),
is.numeric(yAxisRot), length(yAxisRot) == 1, is.finite(yAxisRot))
stopifnot(is.numeric(stripeRot), length(stripeRot) == 1,
is.finite(stripeRot), is.numeric(nStripes),
length(nStripes) == 1,
is.finite(nStripes), nStripes >= 1, round(nStripes) == nStripes,
is.numeric(stripeWidth), length(stripeWidth) == 1,
is.finite(stripeWidth), stripeWidth > 0, stripeWidth < 1,
is.numeric(stripeScale), length(stripeScale) == 1,
is.finite(stripeScale), stripeScale >= 0, stripeScale <= 1)
allNA <- function (x) {
all(suppressWarnings(is.na(x))) || identical(x, "")
}
linearizeDf <- function(x) {
do.call("c",
lapply(x,
function(x) {
if (is.factor(x)) {
as.list(levels(x)[x])
} else {
as.list(x)
}
}))
}
## resizeLabels doesn't count in anyResize
anyResize <- any(resizeTable, resizeMain, resizeLab, resizeAxes)
if (!draw && dev.cur() == 1) {
## Open dummy device => avoid opening a window when using
## convertUnit(). As far as I can see, the unit conversions
## used here are independent of device parameters and thus
## should not be confused by the dummy device.
tFile <- tempfile()
pdf(file = tFile) # pdf device is always available
tDev <- dev.cur()
on.exit(dev.off(tDev))
on.exit(unlink(tFile), add = TRUE)
}
nCells <- nRows * nCols
if (is.data.frame(bg)) {
bg2 <- linearizeDf(bg)
} else {
bg2 <- bg
}
if (length(bg2) == 0) {
bg2 <- rep.int(NA_character_, nCells)
} else {
bg2 <- rep_len(bg2, nCells)
}
if (is.data.frame(stripeCol)) {
stripeCol2 <- linearizeDf(stripeCol)
} else {
stripeCol2 <- stripeCol
}
if (length(stripeCol2) == 0) {
stripeCol2 <- rep.int(NA_character_, nCells)
} else {
stripeCol2 <- rep_len(stripeCol2, nCells)
}
## Conversion coefficients from RGB to brightness / luminance / luma...
## Sources referenced on 2015-10-09.
## http://stackoverflow.com/q/596216
## https://en.wikipedia.org/wiki/Luma_%28video%29
LUMA.CONVERSION <- c(0.2126, 0.7152, 0.0722) # R, G, B
## Get RGB values of bg colors (checks that bg colors are valid)
bgNA <- is.na(bg2)
bgRGB <- t(col2rgb(bg2[!bgNA]))
stripeNA <- is.na(stripeCol2)
bgLuma <- numeric(nCells)
bgAndStripes <- which(!bgNA & !stripeNA)
onlyBg <- !bgNA & stripeNA
foo <- stripeNA[!bgNA]
bgRGBBoth <- bgRGB[!foo, , drop=FALSE]
bgRGBOnly <- bgRGB[foo, , drop=FALSE]
stripeRGB <- t(col2rgb(stripeCol2[bgAndStripes]))
luma1 <- drop(stripeRGB %*% LUMA.CONVERSION) / 255
dist1 <- abs(luma1 - 0.5)
luma2 <- drop(bgRGBBoth %*% LUMA.CONVERSION) / 255
dist2 <- abs(luma2 - 0.5)
dist1Larger <- dist1 > dist2
dist2Larger <- !dist1Larger
bgLuma[bgAndStripes[dist1Larger]] <- luma1[dist1Larger]
bgLuma[bgAndStripes[dist2Larger]] <- luma2[dist2Larger]
bgLuma[onlyBg] <- drop(bgRGBOnly %*% LUMA.CONVERSION / 255)
bgLuma[bgNA] <- drop(c(stripeWidth, 1 - stripeWidth) %*%
(t(col2rgb(c(naStripes, naFill))) %*%
LUMA.CONVERSION)) / 255
if (is.data.frame(fg)) {
fg2 <- linearizeDf(fg)
} else {
fg2 <- fg
}
if (length(fg2) == 0) {
fg2 <- rep.int("black", nCells)
fg2[bgLuma < 0.5] <- "white"
} else if (length(fg2) > nCells) {
fg2 <- fg2[seq_len(nCells)]
}
nFg <- length(fg2)
if (is.data.frame(labels)) {
labels2 <- linearizeDf(labels)
} else {
labels2 <- labels
}
if (length(labels2) == 0) {
labelsNA <- TRUE
nLabels <- 1
labels2 <- character(0)
} else if (length(labels2) > nCells) {
labels2 <- labels2[seq_len(nCells)]
}
## labels2,xAxisLabels2, yAxisLabels2 will be indexed with `[[`
if (is.expression(labels2)) {
labelTmp <- vector(mode = "list", length = length(labels2))
for (i in seq_along(labelTmp)) {
labelTmp[[i]] <- labels2[i]
}
labels2 <- labelTmp
} else if (!is.vector(labels2)) {
labels2 <- as.list(labels2)
}
if (length(labels2) > 0) {
labelsNA <- vapply(labels2, allNA, TRUE, USE.NAMES = FALSE)
nLabels <- length(labels2)
}
if (length(xAxisLabels) == 0) {
xAxisNA <- TRUE
nXAxis <- 1
have.xAxisLabels <- FALSE
xAxisLabels2 <- character(0)
} else if (length(xAxisLabels) > nCols) {
xAxisLabels2 <- xAxisLabels[seq_len(nCols)]
} else {
xAxisLabels2 <- xAxisLabels
}
if (is.expression(xAxisLabels2)) {
labelTmp <- vector(mode = "list", length = length(xAxisLabels2))
for (i in seq_along(labelTmp)) {
labelTmp[[i]] <- xAxisLabels2[i]
}
xAxisLabels2 <- labelTmp
} else if (!is.vector(xAxisLabels2)) {
xAxisLabels2 <- as.list(xAxisLabels2)
}
if (length(xAxisLabels2) > 0) {
xAxisNA <- vapply(xAxisLabels2, allNA, TRUE, USE.NAMES = FALSE)
nXAxis <- length(xAxisLabels2)
have.xAxisLabels <- !all(xAxisNA)
}
if (length(yAxisLabels) == 0) {
yAxisNA <- TRUE
nYAxis <- 1
have.yAxisLabels <- FALSE
yAxisLabels2 <- character(0)
} else if (length(yAxisLabels) > nRows) {
yAxisLabels2 <- yAxisLabels[seq_len(nRows)]
} else {
yAxisLabels2 <- yAxisLabels
}
if (is.expression(yAxisLabels2)) {
labelTmp <- vector(mode = "list", length = length(yAxisLabels2))
for (i in seq_along(labelTmp)) {
labelTmp[[i]] <- yAxisLabels2[i]
}
yAxisLabels2 <- labelTmp
} else if (!is.vector(yAxisLabels2)) {
yAxisLabels2 <- as.list(yAxisLabels2)
}
if (length(yAxisLabels2) > 0) {
yAxisNA <- vapply(yAxisLabels2, allNA, TRUE, USE.NAMES = FALSE)
nYAxis <- length(yAxisLabels2)
have.yAxisLabels <- !all(yAxisNA)
}
if (inherits(labelPars, "gpar")) {
labelPars2 <- list(gparToList(labelPars))
nLabelPars <- 1
} else if (length(labelPars) == 0) {
labelPars2 <- list(list())
nLabelPars <- 1
} else if (length(labelPars) > nCells) {
labelPars2 <- lapply(labelPars[seq_len(nCells)], "gparToList")
nLabelPars <- nCells
} else {
labelPars2 <- lapply(labelPars, "gparToList")
nLabelPars <- length(labelPars)
}
parToLabelRatio <- nLabelPars / nLabels
if (nLabelPars > nLabels && round(parToLabelRatio) == parToLabelRatio) {
labels2 <- rep(labels2, length.out = nLabelPars)
labelsNA <- rep_len(labelsNA, nLabelPars)
nLabels <- nLabelPars
} else if (nLabelPars != nLabels) {
labels2 <- rep(labels2, length.out = nCells)
labelsNA <- rep_len(labelsNA, nCells)
labelPars2 <- rep_len(labelPars2, nCells)
nLabels <- nCells
}
fsPar <- unname(unlist(get.gpar("fontsize")))
maxLabelFS <- fsPar
for (i in seq_along(labelPars2)) {
thisSize <- labelPars2[[i]][["fontsize"]]
if (is.null(thisSize)) {
labelPars2[[i]][["fontsize"]] <- fsPar
} else {
maxLabelFS <- max(maxLabelFS, thisSize)
}
}
axesParList <- gparToList(axesPar)
if (!resizeAxes) {
thisSize <- axesParList[["fontsize"]]
if (is.null(thisSize)) {
axesParList[["fontsize"]] <- fsPar
}
axesPar2 <- do.call("gpar", axesParList)
}
mainParList <- gparToList(mainPar)
if (!resizeMain) {
thisSize <- mainParList[["fontsize"]]
if (is.null(thisSize)) {
mainParList[["fontsize"]] <- fsPar
}
mainPar2 <- do.call("gpar", mainParList)
}
labParList <- gparToList(labPar)
if (!resizeLab) {
thisSize <- labParList[["fontsize"]]
if (is.null(thisSize)) {
labParList[["fontsize"]] <- fsPar
}
labPar2 <- do.call("gpar", labParList)
}
have.main <- length(main) > 0 && !all(vapply(main, allNA, TRUE,
USE.NAMES = FALSE))
if (have.main) {
if (is.expression(main)) {
main2 <- list(main[1])
} else {
main2 <- as.list(main)[1]
}
}
have.xlab <- length(xlab) > 0 && !all(vapply(xlab, allNA, TRUE,
USE.NAMES = FALSE))
if (have.xlab) {
if (is.expression(xlab)) {
xlab2 <- list(xlab[1])
} else {
xlab2 <- as.list(xlab)[1]
}
}
have.ylab <- length(ylab) > 0 && !all(vapply(ylab, allNA, TRUE,
USE.NAMES = FALSE))
if (have.ylab) {
if (is.expression(ylab)) {
ylab2 <- list(ylab[1])
} else {
ylab2 <- as.list(ylab)[1]
}
}
## Argument checking
if (have.xAxisLabels || have.yAxisLabels) {
if (inherits(axesMargin, "unit")) {
if (resizeAxes) {
stop(gettextf("when '%s' is TRUE, '%s' must be a non-negative number",
"resizeAxes", "axesMargin", domain = "R-sisal"),
domain = NA)
}
} else if (!(is.numeric(axesMargin) && length(axesMargin) == 1 &&
is.finite(axesMargin) && axesMargin >= 0)) {
stop(gettextf("if '%s' is not a unit, it must be a non-negative number",
"axesMargin", domain = "R-sisal"),
domain = NA)
}
}
if (have.xlab) {
if (inherits(xlabMargin, "unit")) {
if (resizeLab) {
stop(gettextf("when '%s' is TRUE, '%s' must be a non-negative number",
"resizeLab", "xlabMargin", domain = "R-sisal"),
domain = NA)
}
} else if (!is.numeric(xlabMargin) || length(xlabMargin) != 1 ||
!is.finite(xlabMargin) || xlabMargin < 0) {
stop(gettextf("if '%s' is not a unit, it must be a non-negative number",
"xlabMargin", domain = "R-sisal"),
domain = NA)
}
}
if (have.ylab) {
if (inherits(ylabMargin, "unit")) {
if (resizeLab) {
stop(gettextf("when '%s' is TRUE, '%s' must be a non-negative number",
"resizeLab", "ylabMargin", domain = "R-sisal"),
domain = NA)
}
} else if (!is.numeric(ylabMargin) || length(ylabMargin) != 1 ||
!is.finite(ylabMargin) || ylabMargin < 0) {
stop(gettextf("if '%s' is not a unit, it must be a non-negative number",
"ylabMargin", domain = "R-sisal"),
domain = NA)
}
}
if (have.main) {
if (inherits(mainMargin, "unit")) {
if (resizeMain) {
stop(gettextf("when '%s' is TRUE, '%s' must be a non-negative number",
"resizeMain", "mainMargin", domain = "R-sisal"),
domain = NA)
}
} else if (!is.numeric(mainMargin) || length(mainMargin) != 1 ||
!is.finite(mainMargin) || mainMargin < 0) {
stop(gettextf("if '%s' is not a unit, it must be a non-negative number",
"mainMargin", domain = "R-sisal"),
domain = NA)
}
}
## Compute the actual sizes of different text elements and the
## relative sizes of different elements in the plot, taking into
## account some font size parameters etc.
xy <- tableMeasures(xAxisLabels2[!xAxisNA], yAxisLabels2[!yAxisNA],
labels2[!labelsNA], targetAxesRatio = axesSize,
gpAxes = axesParList, gpLabels = labelPars2[!labelsNA],
main = if (have.main) main2,
xlab = if (have.xlab) xlab2,
ylab = if (have.ylab) ylab2,
gpMain = mainParList, gpLab = labParList,
nRows = nRows, nCols = nCols,
xlabExpand = xlabSize, ylabExpand = ylabSize,
mainExpand = mainSize, scaleLabels = forceAxesSize,
xAxisRot = xAxisRot, yAxisRot = yAxisRot,
xAxisJust = xAxisJust, yAxisJust = yAxisJust)
labelJust <- rep.int(0.5, nLabels)
labelsNA[!labelsNA] <- !xy[["labelNZ"]]
labelsNotNA <- !labelsNA
have.labels <- any(labelsNotNA)
xAxisNA[!xAxisNA] <- !xy[["xAxisNZ"]]
have.xAxisLabels <- !all(xAxisNA)
yAxisNA[!yAxisNA] <- !xy[["yAxisNZ"]]
have.yAxisLabels <- !all(yAxisNA)
have.main <- xy[["mainNZ"]]
have.xlab <- xy[["xlabNZ"]]
have.ylab <- xy[["ylabNZ"]]
internalLabels <- c(labels2[labelsNotNA], "x")
internalLabelPars <- c(labelPars2[labelsNotNA],
list(list(fontsize = maxLabelFS)))
if (have.labels && (!resizeLabels || !resizeTable)) {
justTmp <- dynTextGrob(internalLabels, adjustJust = TRUE,
gp = internalLabelPars, resize = FALSE,
takeMeasurements = TRUE)[["vjust"]]
labelJust[labelsNotNA] <- justTmp[1:(length(justTmp) - 1)]
}
## Size of xlab, ylab margin (fixed size)
resizeXlabMargin <- TRUE
resizeYlabMargin <- TRUE
if (!resizeLab) {
if (have.xlab) {
mfs <- dynTextGrob(xlab2, gp = labPar2,
resize = FALSE, takeMeasurements = TRUE)
xlabWidthInches <- mfs[["sizingWidth"]]
xlabHeightInches <- mfs[["sizingHeight"]]
xlabHeight <- unit(xlabHeightInches, "inches")
}
if (have.ylab) {
mfs <- dynTextGrob(ylab2, rot = 90, gp = labPar2,
resize = FALSE, takeMeasurements = TRUE)
ylabWidthInches <- mfs[["sizingWidth"]]
ylabHeightInches <- mfs[["sizingHeight"]]
ylabWidth <- unit(ylabWidthInches, "inches")
}
if (inherits(xlabMargin, "unit")) {
resizeXlabMargin <- FALSE
xlabMarInches <-
convertUnit(xlabMargin, unitTo = "inches",
axisFrom = "x", typeFrom = "dimension",
valueOnly = TRUE)
xlabMar <- unit(xlabMarInches, "inches")
}
if (inherits(ylabMargin, "unit")) {
resizeYlabMargin <- FALSE
ylabMarInches <-
convertUnit(ylabMargin, unitTo = "inches",
axisFrom = "y", typeFrom = "dimension",
valueOnly = TRUE)
ylabMar <- unit(ylabMarInches, "inches")
}
}
## Size of x and y axes and their margin (fixed size)
resizeAxesMargin <- TRUE
xAxisNotNA <- !xAxisNA
yAxisNotNA <- !yAxisNA
if (!resizeAxes) {
maxXAxisHeightInches <- 0
xAxisLabelLeft <- numeric(nCols)
xAxisLabelRight <- numeric(nCols)
xAxisHJust <- numeric(nCols)
xAxisVJust <- numeric(nCols)
xAxisXShift <- numeric(nCols)
xAxisYShift <- numeric(nCols)
if (have.xAxisLabels) {
xMeasurements <-
dynTextGrob(xAxisLabels[xAxisNotNA], adjustJust = TRUE,
gp = axesPar2, resize = FALSE, rotJust = TRUE,
rot = xAxisRot, just = xAxisJust,
takeMeasurements = TRUE)
maxXAxisHeightInches <- xMeasurements[["sizingHeight"]]
xAxisLabelLeft[xAxisNotNA] <- xMeasurements[["left"]]
xAxisLabelRight[xAxisNotNA] <- xMeasurements[["right"]]
xAxisHJust[xAxisNotNA] <- xMeasurements[["hjust"]]
xAxisVJust[xAxisNotNA] <- xMeasurements[["vjust"]]
xAxisXShift[xAxisNotNA] <- xMeasurements[["xShift"]]
xAxisYShift[xAxisNotNA] <- xMeasurements[["yShift"]]
xAxisX2 <- xAxisX + xAxisXShift
xAxisY2 <- xAxisY + xAxisYShift
}
maxYAxisWidthInches <- 0
yAxisLabelBottom <- numeric(nRows)
yAxisLabelTop <- numeric(nRows)
yAxisHJust <- numeric(nRows)
yAxisVJust <- numeric(nRows)
yAxisXShift <- numeric(nRows)
yAxisYShift <- numeric(nRows)
if (have.yAxisLabels) {
yMeasurements <-
dynTextGrob(yAxisLabels[yAxisNotNA], adjustJust = TRUE,
gp = axesPar2, resize = FALSE, rotJust = TRUE,
rot = yAxisRot, just = yAxisJust,
takeMeasurements = TRUE)
maxYAxisWidthInches <- yMeasurements[["sizingWidth"]]
yAxisLabelBottom[yAxisNotNA] <- yMeasurements[["bottom"]]
yAxisLabelTop[yAxisNotNA] <- yMeasurements[["top"]]
yAxisHJust[yAxisNotNA] <- yMeasurements[["hjust"]]
yAxisVJust[yAxisNotNA] <- yMeasurements[["vjust"]]
yAxisXShift[yAxisNotNA] <- yMeasurements[["xShift"]]
yAxisYShift[yAxisNotNA] <- yMeasurements[["yShift"]]
yAxisX2 <- yAxisX + yAxisXShift
yAxisY2 <- yAxisY + yAxisYShift
}
if (have.xAxisLabels) {
xAxisSide <- unit(maxXAxisHeightInches, "inches")
}
if (have.yAxisLabels) {
yAxisSide <- unit(maxYAxisWidthInches, "inches")
}
if (inherits(axesMargin, "unit")) {
resizeAxesMargin <- FALSE
xyMarginSideInches <- minConvertXY(axesMargin)
xyMarginSide <- unit(xyMarginSideInches, "inches")
}
}
## Size of main title and its margin (fixed size)
resizeMainMargin <- TRUE
if (have.main && !resizeMain) {
mfs <- dynTextGrob(main2, gp = mainPar2,
resize = FALSE, takeMeasurements = TRUE)
mainWidthInches <- mfs[["sizingWidth"]]
mainHeightInches <- mfs[["sizingHeight"]]
mainHeight <- unit(mainHeightInches, "inches")
if (inherits(mainMargin, "unit")) {
resizeMainMargin <- FALSE
mainMarginInches <- minConvertXY(mainMargin)
mainMargin2 <- unit(mainMarginInches, "inches")
}
}
## Layout, number of rows and columns
layRows <- 1 + 2 * have.main + nRows + 2 * have.xAxisLabels +
2 * have.xlab
layCols <- 1 + 2 * have.ylab + 2 * have.yAxisLabels + nCols
## Sums of width and height of fixed-size ("rigid") objects
rigidWidthInches <- 0
rigidHeightInches <- 0
## Width and height of the table when resizeTable is FALSE (adds
## to rigidWidthInches and rigidHeightInches)
if (!resizeTable) {
labelsCex <- FALSE
if (have.labels) {
whichLabels <- which(labelsNotNA)
nNotNA <- length(whichLabels)
gpS <- labelPars2[whichLabels]
theCex <- numeric(nNotNA)
for (i in seq_len(nNotNA)) {
thisCex <- gpS[[i]][["cex"]]
if (is.numeric(thisCex) && length(thisCex) == 1) {
theCex[i] <- thisCex
}
gpS[[i]][["cex"]] <- NULL
}
mfs <- dynTextGrob(labels2[whichLabels], takeMeasurements = TRUE,
gp = gpS, resize = FALSE, adjustJust = FALSE,
vjust = labelJust[whichLabels])
cellSideInches <- max(unlist(mfs[c("sizingWidth", "sizingHeight")]))
if (!anyResize) {
labelHalfWidths <- numeric(length(labelsNA))
labelTops <- numeric(length(labelsNA))
labelBottoms <- numeric(length(labelsNA))
bigCex <- logical(length(labelsNA))
labelHalfWidths[whichLabels] <- mfs[["right"]]
labelTops[whichLabels] <- mfs[["top"]]
labelBottoms[whichLabels] <- mfs[["bottom"]]
idx <- which(theCex > 1)
labelsCex <- length(idx) > 0
if (labelsCex) {
bigCex[idx] <- TRUE
theCex <- theCex[idx]
labelHalfWidths[idx] <- theCex * labelHalfWidths[idx]
labelTops[idx] <- theCex * labelTops[idx]
labelBottoms[idx] <- theCex * labelBottoms[idx]
}
}
} else {
tmpGrob <- textGrob("x", gp = gpar(fontsize = maxLabelFS))
cellSideInches <-
max(convertWidth(grobWidth(tmpGrob),
unitTo = "inches", valueOnly = TRUE),
convertHeight(grobHeight(tmpGrob),
unitTo = "inches", valueOnly = TRUE))
}
cellSide <- unit(cellSideInches, "inches")
xCell <- nCols * cellSideInches
yCell <- nRows * cellSideInches
rigidWidthInches <- rigidWidthInches + xCell
rigidHeightInches <- rigidHeightInches + yCell
if (!resizeAxes && resizeAxesMargin) {
resizeAxesMargin <- FALSE
xyMarginSideInches <- axesMargin * cellSideInches
xyMarginSide <- unit(xyMarginSideInches, "inches")
}
if (have.main && !resizeMain && resizeMainMargin) {
resizeMainMargin <- FALSE
mainMarginInches <- mainMargin * cellSideInches
mainMargin2 <- unit(mainMarginInches, "inches")
}
if (!resizeLab && resizeXlabMargin) {
resizeXlabMargin <- FALSE
xlabMarInches <- xlabMargin * cellSideInches
xlabMar <- unit(xlabMarInches, "inches")
}
if (!resizeLab && resizeYlabMargin) {
resizeYlabMargin <- FALSE
ylabMarInches <- ylabMargin * cellSideInches
ylabMar <- unit(ylabMarInches, "inches")
}
}
if (have.ylab && !resizeLab) {
rigidWidthInches <- rigidWidthInches + ylabWidthInches
if (!resizeYlabMargin) {
rigidWidthInches <- rigidWidthInches + ylabMarInches
}
}
if (have.yAxisLabels && !resizeAxes) {
rigidWidthInches <- rigidWidthInches + maxYAxisWidthInches
if (!resizeAxesMargin) {
rigidWidthInches <- rigidWidthInches + xyMarginSideInches
}
}
if (have.main && !resizeMain) {
rigidHeightInches <- rigidHeightInches + mainHeightInches
if (!resizeMainMargin) {
rigidHeightInches <- rigidHeightInches + mainMarginInches
}
}
if (have.xAxisLabels && !resizeAxes) {
rigidHeightInches <- rigidHeightInches + maxXAxisHeightInches
if (!resizeAxesMargin) {
rigidHeightInches <- rigidHeightInches + xyMarginSideInches
}
}
if (have.xlab && !resizeLab) {
rigidHeightInches <- rigidHeightInches + xlabHeightInches
if (!resizeXlabMargin) {
rigidHeightInches <- rigidHeightInches + xlabMarInches
}
}
## Sizes of dummGrob and objects depending on it can be constant or dynamic
if (inherits(width, "unit") && inherits(height, "unit")) {
hSize <- width
vSize <- height
} else {
hSize <- unit(width, default.units)
vSize <- unit(height, default.units)
}
## This is never drawn
dummGrob <- rectGrob(width = max(unit(0, "inches"),
hSize - unit(rigidWidthInches, "inches")),
height = max(unit(0, "inches"),
vSize - unit(rigidHeightInches, "inches")))
## hUnits and vUnits are the total horizontal and vertical size of
## table cells whose size depends on the size of dummGrob, where 1
## unit is the size of a square cell in the nRows * nCols contents
## section (if resizeTable is TRUE)
if (resizeTable) {
hUnits <- nCols
} else {
hUnits <- 0
}
if (have.yAxisLabels) {
if (resizeAxes) {
hUnits <- hUnits + xy[["yAxisRatio"]]
}
if (resizeAxesMargin) {
hUnits <- hUnits + axesMargin
}
}
if (have.ylab) {
if (resizeLab) {
hUnits <- hUnits + xy[["ylabRatio"]]
}
if (resizeYlabMargin) {
hUnits <- hUnits + ylabMargin
}
}
if (resizeTable) {
vUnits <- nRows
} else {
vUnits <- 0
}
if (have.xAxisLabels) {
if (resizeAxes) {
vUnits <- vUnits + xy[["xAxisRatio"]]
}
if (resizeAxesMargin) {
vUnits <- vUnits + axesMargin
}
}
if (have.xlab) {
if (resizeLab) {
vUnits <- vUnits + xy[["xlabRatio"]]
}
if (resizeXlabMargin) {
vUnits <- vUnits + xlabMargin
}
}
if (have.main) {
if (resizeMain) {
vUnits <- vUnits + xy[["mainRatio"]]
}
if (resizeMainMargin) {
vUnits <- vUnits + mainMargin
}
}
## Width and / or height of graphical objects as units
if (resizeTable) {
cellSide <- min(unit(1 / hUnits, "grobwidth", data = dummGrob),
unit(1 / vUnits, "grobheight", data = dummGrob))
}
xAxisWidth <- xy[["xAxisWidth"]]
xAxisHeight <- xy[["xAxisHeight"]]
yAxisWidth <- xy[["yAxisWidth"]]
yAxisHeight <- xy[["yAxisHeight"]]
if (resizeAxes) {
xyMarginSide <- axesMargin * cellSide
if (have.xAxisLabels) {
xAxisSide <-
min(xAxisHeight / xAxisWidth * cellSide,
unit(xy[["xAxisRatio"]] / hUnits, "grobwidth",
data = dummGrob),
unit(xy[["xAxisRatio"]] / vUnits, "grobheight",
data = dummGrob))
}
if (have.yAxisLabels) {
yAxisSide <-
min(yAxisWidth / yAxisHeight * cellSide,
unit(xy[["yAxisRatio"]] / hUnits, "grobwidth",
data = dummGrob),
unit(xy[["yAxisRatio"]] / vUnits, "grobheight",
data = dummGrob))
}
}
layHeights <- vector(mode = "list", length = layRows)
layHeights[[1]] <- unit(0, "inches")
rowCount <- 1
if (have.main) {
if (resizeMain) {
mainMargin2 <- mainMargin * cellSide
mainHeight <- min(xy[["mainHeight"]] / xy[["mainWidth"]] *
nCols * cellSide,
unit(xy[["mainRatio"]] / hUnits, "grobwidth",
data = dummGrob),
unit(xy[["mainRatio"]] / vUnits, "grobheight",
data = dummGrob))
}
layHeights[rowCount + 1:2] <- list(mainHeight, mainMargin2)
rowCount <- rowCount + 2
}
layHeights[rowCount + seq_len(nRows)] <- rep(list(cellSide), nRows)
rowCount <- rowCount + nRows
if (have.xAxisLabels) {
layHeights[rowCount + 1:2] <- list(xyMarginSide, xAxisSide)
rowCount <- rowCount + 2
} else {
xAxisSide <- NULL
}
if (resizeLab) {
if (have.xlab) {
xlabMar <- xlabMargin * cellSide
xlabHeight <- min(xy[["xlabHeight"]] / xy[["xlabWidth"]] *
nCols * cellSide,
unit(xy[["xlabRatio"]] / hUnits, "grobwidth",
data = dummGrob),
unit(xy[["xlabRatio"]] / vUnits, "grobheight",
data = dummGrob))
}
if (have.ylab) {
ylabMar <- ylabMargin * cellSide
ylabWidth <- min(xy[["ylabWidth"]] / xy[["ylabHeight"]] *
nRows * cellSide,
unit(xy[["ylabRatio"]] / hUnits, "grobwidth",
data = dummGrob),
unit(xy[["ylabRatio"]] / vUnits, "grobheight",
data = dummGrob))
}
}
if (have.xlab) {
layHeights[rowCount + 1:2] <- list(xlabMar, xlabHeight)
}
layHeights <- do.call("unit.c", layHeights)
layWidths <- vector(mode = "list", length = layCols)
layWidths[[1]] <- unit(0, "inches")
colCount <- 1
if (have.ylab) {
layWidths[colCount + 1:2] <- list(ylabWidth, ylabMar)
colCount <- colCount + 2
}
if (have.yAxisLabels) {
layWidths[colCount + 1:2] <- list(yAxisSide, xyMarginSide)
colCount <- colCount + 2
} else {
yAxisSide <- NULL
}
layWidths[colCount + seq_len(nCols)] <- rep(list(cellSide), nCols)
layWidths <- do.call("unit.c", layWidths)
## Lists for grobs and viewports, with some excess length.
## The drawing order will be innerGrobs before outerGrobs.
outerGrobs <- vector(mode = "list",
length = layRows * layCols - nRows * nCols)
innerGrobs <- vector(mode = "list",
length = nRows * nCols + outerRect +
innerLines * ((nRows-1) * nCols + (nCols-1) * nRows))
vps <- vector(mode = "list", length = layRows * layCols + outerRect)
## Counts how many grobs and viewports have been added to the lists
vpCounter <- 0
outerCount <- 0
innerCount <- 0
### Create grobs and viewports, add to the lists
if (any(bgNA) || any(!stripeNA[!bgNA])) {
stripeWidth2 <- stripeWidth / nStripes
stripeSep <- 1 / nStripes
stripeY <- seq(from=stripeSep / 2, by = stripeSep, length.out=nStripes)
stripeGrobNA <-
grobTree(rectGrob(gp = gpar(fill=naFill, col=naFill),
name = "stripeBg"),
stripePolygon(y = stripeY, rot = stripeRot,
width = stripeWidth2,
xyScale = stripeScale,
default.units = "npc",
name = "stripes"),
gp = gpar(col = naStripes, fill = naStripes))
}
xAxisGrobs <- vector(mode = "list", length = nXAxis)
yAxisGrobs <- vector(mode = "list", length = nYAxis)
if (resizeAxes) {
for (i in which(xAxisNotNA)) {
xAxisGrobs[[i]] <-
textGrob(xAxisLabels2[[i]], gp = axesPar,
rot = xAxisRot, x = xAxisX, y = xAxisY)
}
for (i in which(yAxisNotNA)) {
yAxisGrobs[[i]] <-
textGrob(yAxisLabels2[[i]], gp = axesPar,
rot = yAxisRot, x = yAxisX, y = yAxisY)
}
} else {
for (i in which(xAxisNotNA)) {
xAxisGrobs[[i]] <-
textGrob(xAxisLabels2[[i]], gp = axesPar2,
rot = xAxisRot, x = xAxisX2[i], y = xAxisY2[i],
hjust = xAxisHJust[i], vjust = xAxisVJust[i])
}
for (i in which(yAxisNotNA)) {
yAxisGrobs[[i]] <-
textGrob(yAxisLabels2[[i]], gp = axesPar2,
rot = yAxisRot, x = yAxisX2[i], y = yAxisY2[i],
hjust = yAxisHJust[i], vjust = yAxisVJust[i])
}
}
## Row by row...
cellNames <- twoPartName(rep.int(seq_len(nRows), nCols),
rep(seq_len(nCols), each = nRows))
bgNames <- twoPartNameChar("bg", cellNames)
textNames <- twoPartNameChar("text", cellNames)
treeNames <- twoPartNameChar("tree", cellNames)
yNames <- twoPartName(seq_len(nRows), "yaxis")
for (Row in seq_len(nRows)) {
Row2 <- 1 + Row + 2 * have.main
## Y axis label
yAxisMod <- (Row - 1) %% nYAxis + 1
if (yAxisNotNA[yAxisMod]) {
vpCounter <- vpCounter + 1
outerCount <- outerCount + 1
Col2 <- 2 + 2 * have.ylab
thisName <- yNames[Row]
vps[[vpCounter]] <-
viewport(layout.pos.row = Row2, layout.pos.col = Col2,
name = thisName)
outerGrobs[[outerCount]] <-
editGrob(yAxisGrobs[[yAxisMod]], name = thisName,
vp = vpPath("Parent", thisName))
}
Col2 <- 2 + 2 * have.yAxisLabels + 2 * have.ylab
## Actual contents of the table
for (Col in seq_len(nCols)) {
linearRowCol <- Row - 1 + (Col - 1) * nRows
vpCounter <- vpCounter + 1
innerCount <- innerCount + 1
thisName <- cellNames[linearRowCol + 1]
vps[[vpCounter]] <-
viewport(layout.pos.row = Row2, layout.pos.col = Col2,
name = thisName)
vpP <- vpPath("Parent", thisName)
labelsMod <- linearRowCol %% nLabels + 1
labelPar <- labelPars2[[labelsMod]]
labelPar[["col"]] <- fg2[[linearRowCol %% nFg + 1]]
bgMod <- linearRowCol + 1
if (bgNA[bgMod]) {
bgGrob <- editGrob(stripeGrobNA, vp = vpP,
name = bgNames[linearRowCol + 1])
} else if (stripeNA[bgMod]) {
thisBg <- bg2[[bgMod]]
bgGrob <- rectGrob(gp = gpar(fill = thisBg, col = thisBg),
vp = vpP,
name = bgNames[linearRowCol + 1])
} else {
thisBg1 <- bg2[[bgMod]]
thisBg2 <- stripeCol2[[bgMod]]
bgGrob <- editGrob(stripeGrobNA, vp = vpP,
name = bgNames[linearRowCol + 1],
gp = gpar(col = thisBg2, fill = thisBg2))
bgGrob <- editGrob(bgGrob, gPath = "stripeBg",
gp = gpar(col = thisBg1, fill = thisBg1))
}
if (resizeLabels) {
labelPar["fontsize"] <- NULL
}
if (labelsNA[labelsMod]) {
fgGrob <- NULL
} else {
fgGrob <- textGrob(labels2[[labelsMod]],
gp = do.call("gpar", labelPar), vp = vpP,
name = textNames[linearRowCol + 1],
vjust = labelJust[labelsMod])
}
innerGrobs[[innerCount]] <-
grobTree(bgGrob, fgGrob, name = treeNames[linearRowCol + 1])
Col2 <- Col2 + 1
}
}
## X axis labels
Row2 <- nRows + 3 + 2 * have.main
Col2 <- 1 + 2 * have.yAxisLabels + 2 * have.ylab
xNames <- twoPartName("xaxis", seq_len(nCols))
for (Col in seq_len(nCols)[xAxisNotNA]) {
vpCounter <- vpCounter + 1
outerCount <- outerCount + 1
thisName <- xNames[Col]
vps[[vpCounter]] <- viewport(layout.pos.row = Row2, name = thisName,
layout.pos.col = Col2 + Col)
outerGrobs[[outerCount]] <-
editGrob(xAxisGrobs[[(Col - 1) %% nXAxis + 1]], name = thisName,
vp = vpPath("Parent", thisName))
}
## X label
if (have.xlab) {
vpCounter <- vpCounter + 1
outerCount <- outerCount + 1
xlabRow <- nRows + 2 * have.xAxisLabels + 3 + 2 * have.main
firstCol <- 2 + 2 * have.yAxisLabels + 2 * have.ylab
lastCol <- firstCol + nCols - 1
xlabCol <- c(firstCol, lastCol)
vps[[vpCounter]] <-
viewport(layout.pos.row = xlabRow, layout.pos.col = xlabCol,
name = "xlab")
if (resizeLab) {
outerGrobs[[outerCount]] <-
dynTextGrob(xlab2[[1]], gp = labPar,
sizingWidth = xy[["xlabWidth"]],
sizingHeight = xy[["xlabHeight"]],
name = "xlab", vp = vpPath("Parent", "xlab"),)
} else {
outerGrobs[[outerCount]] <-
textGrob(xlab2[[1]], gp = labPar2, name = "xlab",
vp = vpPath("Parent", "xlab"))
}
}
## Y label
if (have.ylab) {
vpCounter <- vpCounter + 1
outerCount <- outerCount + 1
ylabCol <- 2
firstRow <- 2 + 2 * have.main
lastRow <- firstRow + nRows - 1
ylabRow <- c(firstRow, lastRow)
vps[[vpCounter]] <-
viewport(layout.pos.row = ylabRow, layout.pos.col = ylabCol,
name = "ylab")
if (resizeLab) {
outerGrobs[[outerCount]] <-
dynTextGrob(ylab2[[1]], gp = labPar, rot = 90, name = "ylab",
vp = vpPath("Parent", "ylab"),
sizingWidth = xy[["ylabWidth"]],
sizingHeight = xy[["ylabHeight"]])
} else {
outerGrobs[[outerCount]] <-
textGrob(ylab2[[1]], gp = labPar2, rot = 90, name = "ylab",
vp = vpPath("Parent", "ylab"))
}
}
## Main title
if (have.main) {
vpCounter <- vpCounter + 1
outerCount <- outerCount + 1
firstCol <- 2 + 2 * have.yAxisLabels + 2 * have.ylab
lastCol <- firstCol + nCols - 1
mainCol <- c(firstCol, lastCol)
mainRow <- 2
vps[[vpCounter]] <-
viewport(layout.pos.row = mainRow, layout.pos.col = mainCol,
name = "main")
if (resizeMain) {
outerGrobs[[outerCount]] <-
dynTextGrob(main2[[1]],
gp = mainPar, vp = vpPath("Parent", "main"),
sizingWidth = xy[["mainWidth"]],
sizingHeight = xy[["mainHeight"]],
name = "main")
} else {
outerGrobs[[outerCount]] <- textGrob(main2[[1]], gp = mainPar2,
vp = vpPath("Parent", "main"),
name = "main")
}
}
## Line segments between table cells: Maximize contrast to
## neighboring cells (black, white and different shades of gray
## available)
if (innerLines) {
linePar2 <- gparToList(linePar)
colorMissing <- !("col" %in% names(linePar2))
if (colorMissing) {
linePar2[["col"]] <- "black"
colorIdx <- which(names(linePar2) == "col")[1]
}
## Horizontal
hLineNames <- twoPartNameChar("hLine", cellNames)
for (Row in seq_len(nRows - 1)) {
for (Col in seq_len(nCols)) {
linearRowCol <- c(Row, Row + 1) - 1 + (Col - 1) * nRows + 1
innerCount <- innerCount + 1
vpName <- cellNames[linearRowCol[1]]
if (colorMissing) {
linePar2[[colorIdx]] <- fgGrey(bgLuma[linearRowCol])
}
innerGrobs[[innerCount]] <-
segmentsGrob(x0 = 0, y0 = 0, x1 = 1, y1 = 0,
gp = do.call("gpar", linePar2),
name = hLineNames[linearRowCol[1]],
vp = vpPath("Parent", vpName))
}
}
## Vertical
vLineNames <- twoPartNameChar("vLine", cellNames)
for (Col in seq_len(nCols - 1)) {
for (Row in seq_len(nRows)) {
linearRowCol <- Row - 1 + (c(Col, Col + 1) - 1) * nRows + 1
innerCount <- innerCount + 1
vpName <- cellNames[linearRowCol[1]]
if (colorMissing) {
linePar2[[colorIdx]] <- fgGrey(bgLuma[linearRowCol])
}
innerGrobs[[innerCount]] <-
segmentsGrob(x0 = 1, y0 = 0, x1 = 1, y1 = 1,
gp = do.call("gpar", linePar2),
name = vLineNames[linearRowCol[1]],
vp = vpPath("Parent", vpName))
}
}
}
## Frame around table
if (outerRect) {
rectPar2 <- gparToList(rectPar)
rectPar2[["fill"]] <- 0 # transparent
vpCounter <- vpCounter + 1
innerCount <- innerCount + 1
Row <- seq(from = 2 + 2 * have.main, by = 1, length.out = nRows)
Col <- seq(from = 2 + 2 * have.yAxisLabels + 2 * have.ylab,
by = 1, length.out = nCols)
vps[[vpCounter]] <- viewport(layout.pos.row = Row,
layout.pos.col = Col, name = "outerRect")
innerGrobs[[innerCount]] <- rectGrob(gp = do.call("gpar", rectPar2),
name = "outerRect",
vp = vpPath("Parent", "outerRect"))
}
## Compute numeric 'hjust' and 'vjust'
tmpJust <- justHV(just)
hjust <- tmpJust[[1]]
vjust <- tmpJust[[2]]
## Convert 'x' and 'y' to unit objects
if (inherits(x, "unit")) {
X <- x
} else {
X <- unit(x, default.units)
}
if (inherits(y, "unit")) {
Y <- y
} else {
Y <- unit(y, default.units)
}
## Create parent viewport
if (anyResize) {
vpWidth <- sum(layWidths)
vpHeight <- sum(layHeights)
} else {
## In this branch, everything has fixed size. Therefore it is
## possible to check if the text elements will overflow the
## layout and by how much. The margin is then widened to cover
## all the oversized elements..
leftHang <- 0
rightHang <- 0
if ((have.main && mainWidthInches > xCell) ||
(have.xlab && xlabWidthInches > xCell) ||
have.xAxisLabels) {
xLeft <- 0
if (have.ylab) {
xLeft <- xLeft + ylabWidthInches + ylabMarInches
}
if (have.yAxisLabels) {
xLeft <- xLeft + maxYAxisWidthInches + xyMarginSideInches
}
xCenter <- xLeft + xCell / 2
if (have.main) {
leftHang <- max(leftHang, mainWidthInches / 2 - xCenter)
rightHang <-
max(rightHang,
xCenter + mainWidthInches / 2 - rigidWidthInches)
}
if (have.xlab) {
leftHang <- max(leftHang, xlabWidthInches / 2 - xCenter)
rightHang <-
max(rightHang,
xCenter + xlabWidthInches / 2 - rigidWidthInches)
}
if (have.xAxisLabels) {
colSeq <- cellSideInches *
(xAxisX2 + seq(from = 0, by = 1, length.out = nCols))
xAxisLabelLeftMaxHang <-
xLeft - min(colSeq + xAxisLabelLeft)
xAxisLabelRightMaxHang <-
max(colSeq + xAxisLabelRight) - xCell
leftHang <- max(leftHang, xAxisLabelLeftMaxHang)
rightHang <- max(rightHang, xAxisLabelRightMaxHang)
}
}
bottomHang <- 0
topHang <- 0
if ((have.ylab && ylabHeightInches > yCell) || have.yAxisLabels) {
yBottom <- 0
if (have.xlab) {
yBottom <- yBottom + xlabHeightInches + xlabMarInches
}
if (have.xAxisLabels) {
yBottom <- yBottom + maxXAxisHeightInches + xyMarginSideInches
}
yCenter <- yBottom + yCell / 2
if (have.ylab) {
bottomHang <- max(bottomHang, ylabHeightInches / 2 - yCenter)
topHang <-
max(topHang,
yCenter + ylabHeightInches / 2 - rigidHeightInches)
}
if (have.yAxisLabels) {
rowSeq <- cellSideInches *
(yAxisY2 +
seq(from = nRows - 1, by = -1, length.out = nRows))
yAxisLabelBottomMaxHang <-
yBottom - min(rowSeq + yAxisLabelBottom)
yAxisLabelTopMaxHang <-
max(rowSeq + yAxisLabelTop) - yCell
bottomHang <- max(bottomHang, yAxisLabelBottomMaxHang)
topHang <- max(topHang, yAxisLabelTopMaxHang)
}
if (labelsCex) {
bigHalfWidths <- labelHalfWidths[bigCex]
bigTops <- labelTops[bigCex]
bigBottoms <- labelBottoms[bigCex]
bigCex2 <- rep(0, length(bigCex))
nBigCex <- sum(bigCex)
bigCex2[bigCex] <- 1:nBigCex
bigCexLong <- rep_len(bigCex, nRows * nCols)
bigCex2Long <- rep_len(bigCex2, nRows * nCols)[bigCexLong]
rowNums <- rep(nRows:1, nCols)[bigCexLong]
colNums <- rep(1:nCols, each = nRows)[bigCexLong]
for (i in seq_len(nBigCex)) {
matches <- which(bigCex2Long == i)
rowMatches <- rowNums[matches]
colMatches <- colNums[matches]
halfWidth <- bigHalfWidths[i]
rowSeq <- (rowMatches - 0.5) * cellSideInches
colSeq <- (colMatches - 0.5) * cellSideInches
labelLeftMaxHang <- max(-colSeq) + halfWidth - xLeft
labelRightMaxHang <- max(colSeq) + halfWidth - xCell
labelBottomMaxHang <- yBottom - min(rowSeq) - bigBottoms[i]
labelTopMaxHang <- max(rowSeq) + bigTops[i] - yCell
leftHang <- max(leftHang, labelLeftMaxHang)
rightHang <- max(rightHang, labelRightMaxHang)
bottomHang <- max(bottomHang, labelBottomMaxHang)
topHang <- max(topHang, labelTopMaxHang)
}
}
}
vpWidth <- unit(rigidWidthInches + leftHang + rightHang, "inches")
vpHeight <- unit(rigidHeightInches + bottomHang + topHang, "inches")
if (leftHang > 0) {
layWidths <- unit.c(unit(leftHang, "inches"), layWidths[-1])
}
if (rightHang > 0) {
layCols <- layCols + 1
layWidths <- unit.c(layWidths, unit(rightHang, "inches"))
}
if (topHang > 0) {
layHeights <- unit.c(unit(topHang, "inches"), layHeights[-1])
}
if (bottomHang > 0) {
layRows <- layRows + 1
layHeights <- unit.c(layHeights, unit(bottomHang, "inches"))
}
}
the.layout <- grid.layout(layRows, layCols,
widths = layWidths, heights = layHeights)
parentVp <- viewport(x = X, y = Y, width = vpWidth, height = vpHeight,
just = just, clip = clip,
layout = the.layout, name = "Parent")
## A gList (the grobs) and a vpTree (the viewports) go to a gTree
grobs <- do.call("gList", c(innerGrobs[seq_len(innerCount)],
outerGrobs[seq_len(outerCount)]))
childVps <- do.call("vpList", vps[seq_len(vpCounter)])
viewports <- vpTree(parent = parentVp, children = childVps)
if (resizeLabels && resizeTable && have.labels) {
nResizeLabels <- sum(labelsNotNA)
} else {
nResizeLabels <- 0
}
myPlot <-
gTree(children = grobs, childrenvp = viewports,
width = vpWidth, height = vpHeight, vpLayout = the.layout,
x = X, y = Y, just = just, clip = clip,
internals = list(hjust = hjust, vjust = vjust,
resizeAxes = resizeAxes, labelDim = xy[["labelDim"]],
xAxisWidth = xAxisWidth, xAxisHeight = xAxisHeight,
yAxisWidth = yAxisWidth, yAxisHeight = yAxisHeight,
cellSide = cellSide, xAxisSide = xAxisSide,
yAxisSide = yAxisSide, nRows = nRows, nCols = nCols,
labelsNotNA = labelsNotNA, xAxisNotNA = xAxisNotNA,
yAxisNotNA = yAxisNotNA, labels = internalLabels,
labelPars = internalLabelPars, axesPar = axesParList,
xAxisLabels = xAxisLabels2[xAxisNotNA],
yAxisLabels = yAxisLabels2[yAxisNotNA],
xAxisRot = xAxisRot, yAxisRot = yAxisRot,
xAxisJust = xAxisJust, yAxisJust = yAxisJust,
textNames = textNames, xNames = xNames, yNames = yNames,
nResizeLabels = nResizeLabels, childVps = childVps),
cl = "sisalTable", name = name, gp = gp, vp = vp)
if (draw) {
grid.draw(myPlot)
}
## An object of class c("sisalTable", "gTree", ...) is returned
invisible(myPlot)
}
Try the sisal package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.