2d color gradient plot in R

Question

I want to produce a 2d color gradient rectangle like the ones in the picture below on the right hand side. How can I do this in R? Using colorRamp or RColorBrewer or other functions/packages I can produce nice 1D dolor ramps. But how do I do this for 2D including several colors in the corners, like eg the upper right rectangle?

What I want to get is eg the following two gradient types:

BTY: I completely forgot to mention that I found the above chart here (produced by Luca Fenu).

Answer 1

Try this:

 m = tcrossprod(sin(seq(0,pi,length=1e2)), cos(seq(0, 3*pi, length=1e2)))
 cols = matrix(hcl(h=scales::rescale(m, c(0, 360))), nrow(m))
 grid::grid.raster(cols)

You'll need to find which function describes the colour gradient that you want (I used sine waves for illustration).

Edit: linear interpolation between 4 corners

library(grid)
library(scales)

m = tcrossprod(seq(1,2,length=1e2), seq(2, 3, length=1e2))
pal <- gradient_n_pal(c("red","green","yellow","blue"), values = c(2, 3, 4, 6), space = "Lab")
cols = matrix(pal(m), nrow(m))
grid.raster(cols)

Edit 2: When the function is not separable, use outer,

fun_xy <- function(x, y){

  abs(y-x) * abs(y+x)

}

z <- outer(seq(-1,1,length=100), seq(-1,1,length=100), FUN = fun_xy)

cols = matrix(hcl(h=scales::rescale(z, c(0, 200))), nrow(z))
grid::grid.raster(cols)

You can also do the colour mixing directly inside the function instead of mapping values to a colour scale afterwards,

fun_xy <- function(x, y){

  R <- (x+1)/2
  G <- (1-x)/2
  B <- (y+1)/2
  A <- 1- 0.5*exp(-(x^2+y^2)/0.2)

  rgb(R, G, B, A)

}

z <- outer(seq(-1,1,length=100), seq(-1,1,length=100), FUN = fun_xy)

library(grid)
grid.newpage()
grid::grid.raster(z)

Answer 2

Thanks for commenting on my post - I'm glad it generated some discussion. Here's a minimal code to achieve the plots on the upper right - I'm sure there's other more efficient ways to do it... But this works without need for other libraries, and should be easy enough to follow... you can change saturation and alpha blending by playing with the max_sat and alpha_default variables...

#define extremes of the color ramps
rampk2r <- colorRampPalette(c(rgb(  0/255,   0/255,   0/255), rgb(218/255,   0/255,   0/255)))
rampk2g <- colorRampPalette(c(rgb(  0/255,   0/255,   0/255), rgb(  0/255, 218/255,   0/255)))

# stupid function to reduce every span of numbers to the 0,1 interval
prop <- function(x, lo=0, hi=100) {
    if (is.na(x)) {NA}
    else{
        min(lo,hi)+x*(max(lo,hi)-min(lo,hi))
    }
}

rangepropCA<-c(0,20)
rangepropCB<-c(0,20)

# define some default variables
if (!exists('alpha_default')) {alpha_default<-1} # opaque colors by default
if (!exists('palette_l')) {palette_l<-50} # how many steps in the palette
if (!exists('max_sat')) {max_sat<-200} # maximum saturation
colorpalette<-0:palette_l*(max_sat/255)/palette_l # her's finally the palette...

# first of all make an empy plot
plot(NULL, xlim=rangepropCA, ylim=rangepropCB, log='', xaxt='n', yaxt='n', xlab='prop A', ylab='prop B', bty='n', main='color field');
# then fill it up with rectangles each colored differently
for (m in 1:palette_l) {
    for (n in 1:palette_l) {
        rgbcol<-rgb(colorpalette[n],colorpalette[m],0, alpha_default);
        rect(xleft= prop(x=(n-1)/(palette_l),rangepropCA[1],rangepropCA[2]) 
            ,xright= prop(x=(n)/(palette_l),rangepropCA[1],rangepropCA[2])
            ,ytop= prop(x=(m-1)/(palette_l),rangepropCB[1],rangepropCB[2]) 
            ,ybottom= prop(x=(m)/(palette_l),rangepropCB[1],rangepropCB[2])
            ,col=rgbcol
            ,border="transparent"
        )
    }
}
# done!

Answer 3

I am certain there is a more elegant way to do this. Anyway, here you go: the last line is a pretty close recreation of your original image in the question.

library(scales)

four.color.matrix <-
    function( mycols ){

        m <- matrix( NA , 100 , 100 )

        m[ 1 , 1 ] <- mycols[ 1 ] 
        m[ 1 , 100 ] <- mycols[ 2 ]
        m[ 100 , 1 ] <- mycols[ 3 ]
        m[ 100 , 100 ] <- mycols[ 4 ]

        m[ 1 , 1:100 ] <- gradient_n_pal( c( mycols[ 1 ] , 'white' , mycols[ 2 ] ) , values = c( 1 , 50 , 100 ) )(1:100)
        m[ 1:100 , 1 ] <- gradient_n_pal( c( mycols[ 1 ] , 'white' , mycols[ 3 ] ) , values = c( 1 , 50 , 100 ) )(1:100)
        m[ 1:100 , 100 ] <- gradient_n_pal( c( mycols[ 2 ] , 'white' , mycols[ 4 ] ) , values = c( 1 , 50 , 100 ) )(1:100)
        m[ 100 , 1:100 ] <- gradient_n_pal( c( mycols[ 3 ] , 'white' , mycols[ 4 ] ) , values = c( 1 , 50 , 100 ) )(1:100)

        a <- gradient_n_pal( c( mycols[ 1 ] , 'white' , mycols[ 4 ] ) , values = c( 1 , 50 , 100 ) )
        diag(m)<-a(1:100)

        b <- gradient_n_pal( c( mycols[ 3 ] , 'white' , mycols[ 2 ] ) , values = c( 1 , 50 , 100 ) )
        for(i in 1:(nrow(m) - 1)){ 
          for (j in 1:nrow(m)) if (i + j == nrow( m )+1){
              m[i,j] <- b(j)
            }
        }

        for ( i in 2:50 ){

            m[ i , i:(101-i) ] <- 
                gradient_n_pal( c( mycols[ 1 ] , 'white' , mycols[ 2 ] ) , values = c( 0 , 50 , 100 ) )(  i:(101-i) )

            m[ i:(101-i) , i ] <- 
                gradient_n_pal( c( mycols[ 3 ] , 'white' , mycols[ 1 ] ) , values = c( 0 , 50 , 100 ) )( (101-i):i )

        }



        for ( i in 51:99 ){

            m[ i , i:(101-i) ] <- 
                gradient_n_pal( c( mycols[ 3 ] , 'white' , mycols[ 4 ] ) , values = c( 0 , 50 , 100 ) )(  i:(101-i) )

            m[ i:(101-i) , i ] <- 
                gradient_n_pal( c( mycols[ 4 ] , 'white' , mycols[ 2 ] ) , values = c( 0 , 50 , 100 ) )( (101-i):i )

        }

        m
    }


z <- four.color.matrix( c( 'red' , 'yellow' , 'green' , 'blue' ) )
library(grid)
grid.raster( z )

# original question asked for something like this
grid.raster( four.color.matrix( c( 'darkgreen' , 'darkgreen' , 'darkred' , 'darkgreen' ) ) )

Answer 4

you may try this and see result plot

rotate <- function(x) t(apply(x, 2, rev))
n <- 3
library(grid)
mm <- tcrossprod(seq(1,0,length.out = n))
tmp1 <- sapply(col2rgb("orange")/255, function(x) 1-mm*(1-x))
tmp2 <- sapply(col2rgb("cyan")/255, function(x) 1-rotate(mm)*(1-x))
tmp3 <- sapply(col2rgb("purple")/255, function(x) 1-rotate(rotate(mm))*(1-x))
tmp4 <- sapply(col2rgb("grey")/255, function(x) 1-rotate(rotate(rotate(mm)))*(1-x))

tmp <- (tmp1*tmp2*tmp3*tmp4)
grid.raster(matrix(rgb(tmp), nrow = n))

result plot < click it to see