Plot a raster, modified by a second raster indicating transparency

add_transparency.R

add_transparency <- function(x, alpha_raster, ramp, ...) {
  # x: The raster to plot, to which transparency will be added.
  # alpha_raster: A raster with the same extent, resolution and CRS as `x`, with
  #    values indicating relative opacity. The maximum value of alpha_raster is
  #    assigned full opacity; lower values scale linearly to zero.
  # ramp: A function (like that returned by colorRampPalette) that returns a 
  #    vector of hexadecimal colour values.
  # ...: additional arguments passed to rasterVis::levelplot.
  require(raster)
  require(rasterVis)
  compareRaster(x, alpha_raster, stopiffalse=TRUE, res=TRUE, orig=TRUE, crs=FALSE)
  r <- raster(x)
  colr <- ramp(100)
  if(nchar(colr)[1]==9) colr <- substr(colr, 1, 7)
  trans <- floor(alpha_raster[]/max(alpha_raster[], na.rm=TRUE)*255)
  trans[is.na(trans)] <- 0
  trans <- sprintf('%x', trans)
  trans <- ifelse(nchar(trans)==1, paste0('0', trans), trans)
  cols <- paste0(colr[as.numeric(cut(x[], seq(0, 1, length=101)))], trans)
  cols[cols=='NA00'] <- '#00000000'
  cols <- as.factor(cols)
  r[] <- cols
  p <- levelplot(r, col.regions=as.character(levels(cols)), ...)
  if('legend' %in% names(p)) {
    p2 <- levelplot(x, col.regions=ramp(100), ...)
    p$legend[[1]]$args$key$at <- p2$legend[[1]]$args$key$at
    p[[grep('^legend', names(p))]][[1]]$args$key$col <- p2[[grep('^legend', names(p2))]][[1]]$args$key$col
    p[[grep('^legend', names(p))]][[1]]$args$key$labels <- NULL 
  }
  p
}

Example

library(RColorBrewer)
library(raster)
library(rasterVis)

r1 <- raster(matrix(runif(100), 10))
r2 <- raster(matrix(1:100, 10))
colr <- colorRampPalette(rev(brewer.pal(11, 'Spectral')))

add_transparency(x=r1, alpha_raster=r2, ramp=colr, at=seq(0, 1, length.out=100), 
                 colorkey=list(height=0.5), scales=list(draw=FALSE))