R heatmap with circles

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))
}