vertical alignment of gridExtra tableGrob (R grid graphics/grob) - r

Having some trouble aligning a grid graphics object -- have read all the docs I can find, including the Murrell book, but no success. I think what I'm trying to do is pretty straightforward, so hopefully I'm missing simple.
Here's a reproducible example that will make a PDF of all the air carriers by destination in Hadley's hflights package (mirrors what I am trying to do on a different data set).
require(hflights)
require(gridExtra)
require(Cairo)
make_table <- function(df) {
p <- tableGrob(
df
,padding.h=unit(.25, "mm")
,show.rownames=FALSE
,gpar.coretext = gpar(fontsize=8, lineheight=0)
#this doesn't seem to justify the table
,just = c("bottom")
,show.box = T
)
return(p)
}
dests <- unique(hflights$Dest)
#list to hold the plots
plot_list <- list()
#loop over destinations and make a simple report
for (i in dests) {
#just this destination
this_dest <- hflights[hflights$Dest == i, ]
#the title
title <- textGrob(label = i, gp = gpar(fontsize=72, fontface = 'bold'))
#a table of carriers
carriers <- unique(this_dest$UniqueCarrier)
carriers <- data.frame(
carrier=carriers
)
carrier_table <- make_table(carriers)
#put them together
p <- arrangeGrob(
title, carrier_table
,nrow=2
)
plot_list[[i]] <- p
}
#print the report
Cairo(
width = 11, height = 8.5
,file = paste('destinations.pdf', sep = ''), type="pdf"
,units = "in"
)
print(plot_list)
dev.off()
I want the entire table produced by tableGrob (in the make_table function) to justify to the top of the grob. Right now it is centered vertically and horizontally inside the grob. Do I need to do that in the call to tableGrob, or is it in the arrangeGrob call? To ask it another way, in case the above is not clear, how can I make the whole table (not the text inside of it) justify to the top/bottom/left/right of its container?
Thanks!

try this,
library(gridExtra)
justify <- function(x, hjust="center", vjust="center", draw=TRUE){
w <- sum(x$widths)
h <- sum(x$heights)
xj <- switch(hjust,
center = 0.5,
left = 0.5*w,
right=unit(1,"npc") - 0.5*w)
yj <- switch(vjust,
center = 0.5,
bottom = 0.5*h,
top=unit(1,"npc") - 0.5*h)
x$vp <- viewport(x=xj, y=yj)
if(draw) grid.draw(x)
return(x)
}
g <- tableGrob(iris[1:3,1:2])
grid.newpage()
justify(g,"right", "top")

Related

Save/export plots from list of plots as single .png files

I'm a bit stuck on this issue. I have this data obtained from a likert survey (so I make everything a factor):
df1<-data.frame(A=c(1,2,2,3,4,5,1,1,2,3),
B=c(4,4,2,3,4,2,1,5,2,2),
C=c(3,3,3,3,4,2,5,1,2,3),
D=c(1,2,5,5,5,4,5,5,2,3),
E=c(1,4,2,3,4,2,5,1,2,3),
dummy1=c("yes","yes","no","no","no","no","yes","no","yes","yes"),
dummy2=c("high","low","low","low","high","high","high","low","low","high"))
df1[colnames(df1)] <- lapply(df1[colnames(df1)], factor)
I then create a list of dataframes to be used in each plot:
vals <- colnames(df1)[1:5]
dummies <- colnames(df1)[-(1:5)]
step1 <- lapply(dummies, function(x) df1[, c(vals, x)])
step2 <- lapply(step1, function(x) split(x, x[, 6]))
names(step2) <- dummies
tbls <- unlist(step2, recursive=FALSE)
tbls<-lapply(tbls, function(x) x[(names(x) %in% names(df1[c(1:5)]))])
This is the plotting function I made (I used the likert package)
plot_likert <- function(x){
y<-deparse(substitute(x))
y<-sub("\\$", " - ",y)
p<-plot(likert(x),
type ="bar",center=3,
group.order=names(x))+
labs(x = "Theme", subtitle=paste("Number of observations:",nrow(x)))+
guides(fill=guide_legend("Rank"))+
ggtitle(paste("How do they rank? -",gsub("\\.",": ",y)))
png(filename=paste("Ranking -",y,".png"), width = 3000, height = 2000, res=300)
print(p)
dev.off()
}
So that now I can make the plot by writing:
plot_likert(tbls$dummy1.no)
Finally, I apply the function over the whole table by using
lapply(tbls,function(x) {
y<-deparse(substitute(x))
y<-sub("\\$", " - ",y)
plot(likert(x),
type ="bar",center=3,
group.order=names(x))+
labs(x = "Theme", subtitle=paste("Number of observations:",nrow(x)))+
guides(fill=guide_legend("Rank"))+
ggtitle(paste("How do these themes rank? -",gsub("\\.",": ",y)))
}) -> list_plots
But now I don't know how to save each graph in the list as a separate .png file! I managed to put everything in a pdf like this, but it's not what I actually want:
ggsave(
filename = "plots.pdf",
plot = marrangeGrob(list_plots, nrow=1, ncol=1),
width = 15, height = 9
)
Do you have any suggestions on how to fix this? Also, if you have anything to add about my function/procedure overall, everything is welcome! I'm still quite new to R.
Thanks in advance
we can use:
sapply(1:length(list_plots), function(i) ggsave(
filename = paste0("plots ",i,".pdf"),
plot = list_plots[[i]],
width = 15, height = 9
))
For names: see https://stackoverflow.com/a/73370416/5224236
mynames <- sapply(names(tbls), function(x) {
paste("How do they rank? -",gsub("\\.",": ",x))
})
myfilenames <- names(tbls)
plot_likert <- function(x, myname, myfilename){
p <- plot(likert(x),
type ="bar",center=3,
group.order=names(x))+
labs(x = "Theme", subtitle=paste("Number of observations:",nrow(x)))+
guides(fill=guide_legend("Rank"))+
ggtitle(myname)
p
}
list_plots <- lapply(1:length(tbls),function(i) {
plot_likert(tbls[[i]], mynames[i], myfilenames[i])
})

saving multiple ggplots WITHOUT for loop

using ggsave and a for loop, I know I can save multiple ggplots onto an excel spreadsheet
For example from Save multiple ggplots using a for loop :
for (i in uniq_species) {
temp_plot = ggplot(data= subset(iris, Species == i)) +
geom_point(size=3, aes(x=Petal.Length, y=Petal.Width )) + ggtitle(i)
ggsave(temp_plot, file=paste0("plot_", i,".png"), width = 14, height = 10, units = "cm")
}
But would I would like to do is avoid the loop, as I have a list of plots.
Using lapply I have ( I presume) a list of plots:
y.plot = lapply(1:nrow(df), function(row)
{
...
}
my question is, is there a way to take y.plot from above, and shove all of the graphs in there onto one excel spreadsheet, without a loop?
something like: ggsave(pic_path,plot=y.plot,width = 20,height=20,units='cm')
but this doesn't work
Perhaps, you are looking for this
dfs <- c("cars","pressure","mtcars")
my_plots <- list()
y.plot <- list()
en <- length(dfs)
y.plot <- lapply(1:en, function(i){
df <- get(dfs[i])
varname <- colnames(df)
x=df[,1]
y=df[,2]
my_plots[[i]] <- ggplot(data=df,aes(x=x,y=y)) + geom_point() +
labs(x=varname[1], y=varname[2]) + theme_bw()
})
myplots <- do.call(grid.arrange, c(y.plot, ncol = en))
location <- "C:\\_My Work\\RStuff\\GWS\\"
ggsave(plot=myplots, file=paste0(location,"myplots.png"), width = 14, height = 10, units = "cm")
Please note that ggsave currently recognises the extensions eps/ps, tex (pictex), pdf, jpeg, tiff, png, bmp, svg and wmf (windows only).
If you wish to save it to a excel file, you need to save the image as a jpeg file and then use openxslx as shown below
ggsave(plot=myplots, file=paste0(location,"myplots.jpeg"), width = 14, height = 10, units = "cm")
pic_path <- paste0(location,"myplots.jpeg")
# Add to a new work book -------------
wb <- openxlsx::createWorkbook()
addWorksheet(wb, "Plots")
insertImage(wb, "Plots", pic_path)
openxlsx::saveWorkbook(wb, file=paste0(location,"myplots.xlsx"), overwrite = TRUE)
# Kill pic
unlink(pic_path)

Partial Row Labels Heatmap - R

I was wondering if anyone knows of a package that allows partial row labeling of heatmaps. I am currently using pheatmap() to construct my heatmaps, but I can use any package that has this functionality.
I have plots with many rows of differentially expressed genes and I would like to label a subset of them. There are two main things to consider (that I can think of):
The placement of the text annotation depends on the height of the row. If the rows are too narrow, then the text label will be ambiguous without some sort of pointer.
If multiple adjacent rows are significant (i.e. will be labelled), then these will need to be offset, and again, a pointer will be needed.
Below is an example of a partial solution that really only gets maybe halfway there, but I hope illustrates what I'd like to be able to do.
set.seed(1)
require(pheatmap)
require(RColorBrewer)
require(grid)
### Data to plot
data_mat <- matrix(sample(1:10000, 300), nrow = 50, ncol = 6)
rownames(data_mat) <- paste0("Gene", 1:50)
colnames(data_mat) <- c(paste0("A", 1:3), paste0("B", 1:3))
### Set how many genes to annotate
### TRUE - make enough labels that some overlap
### FALSE - no overlap
tooMany <- T
### Select a few genes to annotate
if (tooMany) {
sigGenes_v <- paste0("Gene", c(5,20,26,42,47,16,28))
newMain_v <- "Too Many Labels"
} else {
sigGenes_v <- paste0("Gene", c(5,20,26,42))
newMain_v <- "OK Labels"
}
### Make color list
colors_v <- brewer.pal(8, "Dark2")
colors_v <- colors_v[c(1:length(sigGenes_v), 8)]
names(colors_v) <- c(sigGenes_v, "No")
annColors_lsv <- list("Sig" = colors_v)
### Column Metadata
colMeta_df <- data.frame(Treatment = c(rep("A", 3), rep("B", 3)),
Replicate = c(rep(1:3, 2)),
stringsAsFactors = F,
row.names = colnames(data_mat))
### Row metadata
rowMeta_df <- data.frame(Sig = rep("No", 50),
stringsAsFactors = F,
row.names = rownames(data_mat))
for (gene_v in sigGenes_v) rowMeta_df[rownames(rowMeta_df) == gene_v, "Sig"] <- gene_v
### Heatmap
heat <- pheatmap(data_mat,
annotation_row = rowMeta_df,
annotation_col = colMeta_df,
annotation_colors = annColors_lsv,
cellwidth = 10,
main = "Original Heat")
### Get order of genes after clustering
genesInHeatOrder_v <- heat$tree_row$labels[heat$tree_row$order]
whichSigInHeatOrder_v <- which(genesInHeatOrder_v %in% sigGenes_v)
whichSigInHeatOrderLabels_v <- genesInHeatOrder_v[whichSigInHeatOrder_v]
sigY <- 1 - (0.02 * whichSigInHeatOrder_v)
### Change title
whichMainGrob_v <- which(heat$gtable$layout$name == "main")
heat$gtable$grobs[[whichMainGrob_v]] <- textGrob(label = newMain_v,
gp = gpar(fontsize = 16))
### Remove rows
whichRowGrob_v <- which(heat$gtable$layout$name == "row_names")
heat$gtable$grobs[[whichRowGrob_v]] <- textGrob(label = whichSigInHeatOrderLabels_v,
y = sigY,
vjust = 1)
grid.newpage()
grid.draw(heat)
Here are a few outputs:
original heatmap:
ok labels:
ok labels, with flags:
too many labels
too many labels, with flags
The "with flags" outputs are the desired final results.
I just saved these as images from the Rstudio plot viewer. I recognize that I could save them as pdfs and provide a larger file size to get rid of the label overlap, but then the individual cells would be larger than I want.
Based on your code, you seem fairly comfortable with gtables & grobs. A (relatively) straightforward way to achieve the look you want is to zoom in on the row label grob, & make some changes there:
replace unwanted labels with "";
evenly spread out labels within the available space;
add line segments joining the old and new label positions.
I wrote a wrapper function for this, which works as follows:
# heat refers to the original heatmap produced from the pheatmap() function
# kept.labels should be a vector of labels you wish to show
# repel.degree is a number in the range [0, 1], controlling how much the
# labels are spread out from one another
add.flag(heat,
kept.labels = sigGenes_v,
repel.degree = 0)
add.flag(heat,
kept.labels = sigGenes_v,
repel.degree = 0.5)
add.flag(heat,
kept.labels = sigGenes_v,
repel.degree = 1)
Function (explanations in annotations):
add.flag <- function(pheatmap,
kept.labels,
repel.degree) {
# repel.degree = number within [0, 1], which controls how much
# space to allocate for repelling labels.
## repel.degree = 0: spread out labels over existing range of kept labels
## repel.degree = 1: spread out labels over the full y-axis
heatmap <- pheatmap$gtable
new.label <- heatmap$grobs[[which(heatmap$layout$name == "row_names")]]
# keep only labels in kept.labels, replace the rest with ""
new.label$label <- ifelse(new.label$label %in% kept.labels,
new.label$label, "")
# calculate evenly spaced out y-axis positions
repelled.y <- function(d, d.select, k = repel.degree){
# d = vector of distances for labels
# d.select = vector of T/F for which labels are significant
# recursive function to get current label positions
# (note the unit is "npc" for all components of each distance)
strip.npc <- function(dd){
if(!"unit.arithmetic" %in% class(dd)) {
return(as.numeric(dd))
}
d1 <- strip.npc(dd$arg1)
d2 <- strip.npc(dd$arg2)
fn <- dd$fname
return(lazyeval::lazy_eval(paste(d1, fn, d2)))
}
full.range <- sapply(seq_along(d), function(i) strip.npc(d[i]))
selected.range <- sapply(seq_along(d[d.select]), function(i) strip.npc(d[d.select][i]))
return(unit(seq(from = max(selected.range) + k*(max(full.range) - max(selected.range)),
to = min(selected.range) - k*(min(selected.range) - min(full.range)),
length.out = sum(d.select)),
"npc"))
}
new.y.positions <- repelled.y(new.label$y,
d.select = new.label$label != "")
new.flag <- segmentsGrob(x0 = new.label$x,
x1 = new.label$x + unit(0.15, "npc"),
y0 = new.label$y[new.label$label != ""],
y1 = new.y.positions)
# shift position for selected labels
new.label$x <- new.label$x + unit(0.2, "npc")
new.label$y[new.label$label != ""] <- new.y.positions
# add flag to heatmap
heatmap <- gtable::gtable_add_grob(x = heatmap,
grobs = new.flag,
t = 4,
l = 4
)
# replace label positions in heatmap
heatmap$grobs[[which(heatmap$layout$name == "row_names")]] <- new.label
# plot result
grid.newpage()
grid.draw(heatmap)
# return a copy of the heatmap invisibly
invisible(heatmap)
}

Add multi-line footnote to tableGrob, while using gridextra in R

I have recently started using tableGrob and gridextra to combine multiple plots and tables. i want mt tableGrob to have a footnote and title.
The following link answers that nicely:
Adding text to a grid.table plot
But in the above code the footnote gets truncated it its too long. Can someone please suggest an alternative so that the footnote automatically wraps to the next line once it had reached the end of the table? If it can wrap in the middle of the word that is fine as well.
test <- data.frame(boo = c(20,1), do = c(2,10), no = c(3,5),co = c('ed','jeff'))
t1 <- tableGrob(test)
tw <- convertWidth(unit(grobWidth(t1),'npc'),
"in", valueOnly = T)
title <- textGrob("Title is long too or is it??",gp=gpar(fontsize=15))
footnote <- textGrob("footnote is pretty longgg but not unusually longgggggggggkjwd jwkldn", x=0, hjust=0,
gp=gpar( fontface="italic"))
padding <- unit(0.5,"line")
t1 <- gtable_add_rows(t1,
heights = grobHeight(title) + padding,
pos = 0)
t1 <- gtable_add_rows(t1,
heights = grobHeight(footnote)+ padding)
t1 <- gtable_add_grob(t1, list(title, footnote),
t=c(1, nrow(t1)), l=c(1,1),
r=ncol(t1))
grid.arrange(t1)
I want this to work when I have a plot and a table in grid arrange as well. Please help.
I tried using strwrap and setting the width to grobWidth but it did not work for me.
the RGraphics book/package offers a possible solution,
splitString <- function (text, width) {
strings <- strsplit(text, " ")[[1]]
newstring <- strings[1]
linewidth <- stringWidth(newstring)
gapwidth <- stringWidth(" ")
availwidth <- convertWidth(width, "in", valueOnly = TRUE)
for (i in 2:length(strings)) {
width <- stringWidth(strings[i])
if (convertWidth(linewidth + gapwidth + width, "in",
valueOnly = TRUE) < availwidth) {
sep <- " "
linewidth <- linewidth + gapwidth + width
}
else {
sep <- "\n"
linewidth <- width
}
newstring <- paste(newstring, strings[i], sep = sep)
}
newstring
}
tit <- "Title is long too or is it??"
foot <- "footnote is pretty longgg but not unusually longgggggggggkjwd jwkldn"
footnote <- textGrob(splitString(foot, sum(t1$widths)))
title <- textGrob(splitString(tit, sum(t1$widths)))
t1 <- gtable_add_rows(t1, heights = grobHeight(footnote))
t1 <- gtable_add_rows(t1, heights = grobHeight(title), 0)
t1 <- gtable_add_grob(t1, list(title, footnote),
t=c(1, nrow(t1)), l=1, r=ncol(t1))
grid.draw(t1)

Title getting cut off using grid.arrange

I built a function for quickly plotting a table with a lot of help from this answer from #baptiste.
plotTable<-function(data, title=NULL, footnote=NULL, fontsize=9, plotIt=TRUE, show.rownames=TRUE){
# Generic method to plot tabular data
# Built the base table with/without row names
if(show.rownames){
table <- tableGrob(data, theme=ttheme_default(
core=list(fg_params=list(fontsize=fontsize)),
colhead=list(fg_params=list(fontsize=fontsize)),
rowhead=list(fg_params=list(fontsize=fontsize))))
} else{
table <- tableGrob(data, theme=ttheme_default(
core=list(fg_params=list(fontsize=fontsize)),
colhead=list(fg_params=list(fontsize=fontsize)),
rowhead=list(fg_params=list(fontsize=fontsize))), rows=NULL)
}
# Set the padding
padding <- unit(0.5,"line")
# Add the title if it's not NULL
if(!is.null(title)){
title.grob <- textGrob(title, gp=gpar(fontsize=fontsize+3))
table <- gtable_add_rows(table, heights = grobHeight(title.grob) + padding, pos = 0)
table <- gtable_add_grob(table, list(title.grob), t=1, l=1, r=ncol(table))
}
# Add the footnote if it's not NULL
if(!is.null(footnote)){
footnote.grob <- textGrob(footnote, x=0, hjust=0, gp=gpar(fontsize=fontsize, fontface="italic"))
table <- gtable_add_rows(table, heights = grobHeight(footnote.grob)+ padding)
table <- gtable_add_grob(table, list(footnote.grob), t=nrow(table), l=1, r=ncol(table))
}
# Either plot it or return the grob
if(plotIt) grid.arrange(table) else return(table)
}
But sometimes my title is longer than the actual table and it's getting cut off.
libs <- c("data.table", "grid", "gridExtra", "gtable")
lapply(libs, library, character.only = TRUE)
mytable <- data.table(x=c(1,2,3), y=c(3,2,1))
plotTable(mytable, title="Hello World")
How do I fix this?
You can set the table widths manually, but you'll need to decide which column(s) should be expanded and by how much. I guess a reasonable way to redistribute the widths is to add the same margin to each column, so that the total space gained accounts for the extra room needed for the title.
library(gridExtra)
d <- head(iris[,1:2])
table <- tableGrob(d, rows=NULL)
library(grid)
library(gtable)
title <- textGrob("my long title goes here",gp=gpar(fontsize=30))
padding <- unit(1,"line")
table <- gtable_add_rows(table,
heights = grobHeight(title) + padding,
pos = 0)
table <- gtable_add_grob(table, title,
t=1, l=1,
r=ncol(table))
# check whether the table width is smaller than the title width
missed <- convertWidth(sum(table$widths), "in", valueOnly = TRUE) -
convertWidth(grobWidth(title), "in", valueOnly = TRUE)
if(missed < 0 ) # need to do something about it
table$widths <- table$widths + unit(abs(missed)/ncol(table), "in")
grid.newpage()
grid.draw(table)
another option, if you don't want the cells to be resized, is to turn clipping off,
table$layout$clip <- "off"

Resources