Show gtable names and grill
2020-06-08
library(ggplot2)
library(gtable)
## Warning: package 'gtable' was built under R version 4.1.0
library(grid)
dat1 <- data.frame(
gp = factor(rep(letters[1:3], each = 10)),
y = rnorm(30),
cl = sample.int(3, 30, replace=TRUE),
cl2 = sample(c('a','b','c'), 30, replace=TRUE)
)
my.theme <- theme_light()
(
p <- ggplot(dat1, aes(gp, y)) + geom_point() + my.theme
)
g <- ggplotGrob(p)
for (i in 1:nrow(g$layout)) {
if (g$layout$name[i] == 'lemon') next
h <- g$heights[[g$layout$t[i]]]
# if h == null
rot <- if (as.character(h) == "1null") 90 else 0
w <- g$widths[[g$layout$l[i]]]
rot <- if (rot == 90 && as.character(w) == "1null") 0 else rot
r <- rectGrob(gp=gpar(col='black', fill='white', alpha=1/4))
t <- textGrob(g$layout$name[i], rot = rot)
g$grobs[[i]] <- grobTree(r, t)
}
grid.newpage()
grid.draw(g)
is.small <- function(x) {
#if (is.list(x) & !inherits(x[[1]], 'unit.list') & length(x) == 1) x <- x[[1]]
#if (inherits(x, 'unit.list')) return(FALSE)
if (!is.unit(x)) stop('`h` is not a unit.')
if (is.null(attr(x, 'unit'))) return(FALSE)
if (as.numeric(x) == 1 & attr(x, 'unit') == 'null') return(FALSE)
if (as.numeric(x) == 0) return(TRUE)
n <- as.numeric(x)
r <- switch(attr(x, 'unit'),
'null'= FALSE,
'line'= n < 1,
'pt'= n < 10,
'cm' = n < 1,
'grobheight' = FALSE,
'grobwidth' = FALSE,
NA) # i.e. not implemented
return(r)
}
g <- ggplotGrob(p)
gp.gutter <- gpar(colour='grey', lty='dashed')
g <- gtable_add_cols(g, unit(2, 'line'), 0)
for (i in 2:nrow(g)) {
g <- gtable_add_grob(g, t=i, l=1, clip='off', grobs=grobTree(
textGrob(sprintf('(%d, )', i-1)),
linesGrob(x=unit(c(-100,100), 'npc'), y=1, gp=gp.gutter)
), name='lemon')
if (is.small(g$heights[[i]])) g$heights[[i]] <- unit(1, 'line')
}
g <- gtable_add_rows(g, unit(1, 'line'), 0)
for (i in 2:ncol(g)) {
g <- gtable_add_grob(g, t=1, l=i, clip='off', grobs=grobTree(
textGrob(sprintf('( ,%d)', i-1)),
linesGrob(x=1, unit(c(-100, 100), 'npc'), gp=gp.gutter)
), name='lemon')
if (is.small(g$widths[[i]])) g$widths[[i]] <- unit(2, 'line')
}
grid.newpage()
grid.draw(g)
gtable_show_grill <- function(x, plot=TRUE) {
if (is.ggplot(x)) x <- ggplotGrob(x)
gp.gutter <- gpar(colour='grey', lty='dashed')
if (is.null(x$vp)) {
x$vp <- viewport(clip = 'on')
}
x <- gtable_add_cols(x, unit(2, 'line'), 0)
for (i in 2:nrow(x)) {
x <- gtable_add_grob(x, t=i, l=1, clip='off', grobs=grobTree(
textGrob(sprintf('[%d, ]', i-1)),
linesGrob(x=unit(c(-100,100), 'npc'), y=1, gp=gp.gutter)
), name='lemon')
if (is.small(x$heights[[i]])) x$heights[[i]] <- unit(1, 'line')
}
x <- gtable_add_rows(x, unit(1, 'line'), 0)
for (i in 2:ncol(x)) {
x <- gtable_add_grob(x, t=1, l=i, clip='off', grobs=grobTree(
textGrob(sprintf('[ ,%d]', i-1)),
linesGrob(x=1, unit(c(-100, 100), 'npc'), gp=gp.gutter)
), name='lemon')
if (is.small(x$widths[[i]])) x$widths[[i]] <- unit(2, 'line')
}
if (plot) {
grid.newpage()
grid.draw(x)
}
invisible(x)
}
gtable_show_grill(p)
gtable_show_names <- function(x, plot=TRUE) {
if (is.ggplot(x)) x <- ggplotGrob(x)
for (i in 1:nrow(x$layout)) {
if (x$layout$name[i] == 'lemon') next
if (grepl('ylab', x$layout$name[i])) {
rot <- 90
} else if (grepl('-l', x$layout$name[i])) {
rot <- 90
} else if (grepl('-r', x$layout$name[i])) {
rot <- 90
} else {
rot <- 0
}
r <- rectGrob(gp=gpar(col='black', fill='white', alpha=1/4))
t <- textGrob(x$layout$name[i], rot = rot)
x$grobs[[i]] <- grobTree(r, t)
}
if (plot) {
grid.newpage()
grid.draw(x)
}
invisible(x)
}
gtable_show_names(p)
gtable_show_names(gtable_show_grill(p, plot=FALSE))
try(rm(list=c('gtable_show_names','gtable_show_grill')), silent=TRUE)
library(lemon)
print(p)
grid.draw(gtable_show_names(p, plot=FALSE))
gp <- ggplotGrob(p)
gp <- gtable_add_rows(gp, g$heights[1], 0)
gp <- gtable_add_cols(gp, unit(1.5, 'line'))
gp <- gtable_add_grob(gp, linesGrob(x=0.5, gp=gpar(colour='grey', lwd=1.2)), t=1, b=nrow(gp), l=ncol(gp))
g <- gtable_show_names(gtable_show_grill(p, plot=FALSE), plot=FALSE)
g <- cbind(gp, g)
grid.newpage()
grid.draw(g)