R heatmap with circles - r

Question

I would like to generate, in R, a heatmap visualization of a matrix using circles, in order to have both the color and diameter of the circles be informative. Something looking like this:
This sort of plotting is called "bubblegum plot" in certain computational biology labs, but I could not find an R function/package to do it.
Any ideas? Thanks!

Answer 1

Not sure whether there is a package which offers this out-of-the-box but using just ggplot2 this could be achieved like so:
library(ggplot2)
set.seed(42)
d <- data.frame(
x = rep(paste("Team", LETTERS[1:8]), 4),
y = rep(paste("Task", 1:4), each = 8),
value = runif(32)
)
ggplot(d, aes(x, forcats::fct_rev(y), fill = value, size = value)) +
geom_point(shape = 21, stroke = 0) +
geom_hline(yintercept = seq(.5, 4.5, 1), size = .2) +
scale_x_discrete(position = "top") +
scale_radius(range = c(1, 15)) +
scale_fill_gradient(low = "orange", high = "blue", breaks = c(0, .5, 1), labels = c("Great", "OK", "Bad"), limits = c(0, 1)) +
theme_minimal() +
theme(legend.position = "bottom",
panel.grid.major = element_blank(),
legend.text = element_text(size = 8),
legend.title = element_text(size = 8)) +
guides(size = guide_legend(override.aes = list(fill = NA, color = "black", stroke = .25),
label.position = "bottom",
title.position = "right",
order = 1),
fill = guide_colorbar(ticks.colour = NA, title.position = "top", order = 2)) +
labs(size = "Area = Time Spent", fill = "Score:", x = NULL, y = NULL)

Answer 2

I wrote an alternative function to perform the plotting, without ggplot and tidyverse. I will soon upload it to the CRAN corto package. Enjoy!
Usage
inputp<-matrix(runif(1000),nrow=50)
inputn<-matrix(rnorm(1000),nrow=50)
colnames(inputp)<-colnames(inputn)<-paste0("Score",1:ncol(inputp))
rownames(inputp)<-rownames(inputn)<-paste0("Car",1:nrow(inputp))
par(las=2,mar=c(0,6,6,10))
bubblegum(inputp,inputn)
BUBBLEGUM function
require(gplots)
require(plotrix)
bubblegum<-function(
inputp,
inputn,
pcr=0.1,
grid=FALSE,
reorder=FALSE,
legend=TRUE,
matrix2col=TRUE
) {
if(nrow(inputp)!=nrow(inputn)|ncol(inputp)!=ncol(inputn)){
warning("inputp and inpute have different sizes!")
}
### Initialize
rownumber<-nrow(inputp)
colnumber<-ncol(inputp)
### Trasform the NESs into colors
if(matrix2col){
colconversion<-matrix2col(inputn,nbreaks=20)
nescolors<-colconversion$colormatrix
} else {
nescolors<-inputn
}
#pradii<-0.3*(-log(inputp)/max(-log(inputp)))
pradii<-inputp
pradii[inputp>0.1]<-pcr*0
pradii[inputp<=0.1]<-pcr*1
pradii[inputp<0.05]<-pcr*2
pradii[inputp<1E-5]<-pcr*3
pradii[inputp<1E-10]<-pcr*4
pradii[inputp<1E-20]<-pcr*5
### Order by sum NES
sumnes<-apply(inputn,1,function(x){sum(abs(x))})
if(reorder){
neworder<-order(sumnes)
pradii<-pradii[neworder,]
nescolors<-nescolors[neworder,]
} else {
pradii<-pradii[nrow(pradii):1,]
nescolors<-nescolors[nrow(nescolors):1,]
}
### Plot
#par(las=2,mar=c(0,20,6,0))
plot(0,ylim=c(0,rownumber+1),xlim=c(0,colnumber+1),xaxt="n",yaxt="n",type="n",frame.plot=FALSE,xlab="",ylab="")#,xaxs="i",yaxs="i")
if(grid){
abline(h=1:rownumber,lty=2)
abline(v=1:colnumber,lty=2)
}
for (i in (1:rownumber)) {
for(j in 1:colnumber) {
radius<-pradii[i,j]
color<-nescolors[i,j]
draw.circle(j,i,radius=radius,col=color,lwd=0.2)
}
}
axis(3,at=1:colnumber,labels=colnames(pradii))
axis(2,at=1:rownumber,labels=rownames(pradii),cex.axis=0.7)
### Enable things to be drawn outside the plot region
par(xpd=TRUE)
### Title
### Legend
if(legend){
#legend(-colnumber,rownumber,c("group A", "group B"), pch = c(1,2), lty = c(1,2))
legend("topright",inset=c(-0.1,0),legend=c(
"<0.1","0.05","<1e-5","<1e-10","<1e-20"
), pch=c(21), title="FDR",pt.bg="white",horiz=FALSE,pt.cex=c(1,1.5,2,2.5,3))
}
if(matrix2col){
extreme<-round(max(abs(inputn)),1)
legend("bottomright", inset=c(-0.1,0),legend=c(
-extreme,-extreme/2,0,extreme/2,extreme
), pch=c(21), title="Score",
pt.bg=colconversion$col[c(1,5,10,15,19)],
horiz=FALSE,pt.cex=3)
}
}
###########################
matrix2col<-function(z,col1="navy",col2="white",col3="red3",nbreaks=100,center=TRUE){
if(center){
extreme=max(abs(z))+0.001
breaks <- seq(-extreme, extreme, length = nbreaks)
}else {
breaks <- seq(min(z), max(z), length = nbreaks)
}
ncol <- length(breaks) - 1
col <- colorpanel(ncol,col1,col2,col3)
CUT <- cut(z, breaks=breaks)
colorlevels <- col[match(CUT, levels(CUT))] # assign colors to heights for each point
names(colorlevels)<-rownames(z)
colormatrix<-matrix(colorlevels,ncol=ncol(z),nrow=nrow(z))
dimnames(colormatrix)<-dimnames(z)
return(list(colormatrix=colormatrix,col=col))
}