colorbar in grid

colorbar.r

require(scales)
require(RColorBrewer)
require(grid)

##' greyscale palette function 
##'
##' returns a palette function that maps values to grey
##' @title greyscale_palette
##' @export
##' @param d data giving the range of the palette
##' @param ... ignored
##' @return a function
##' @author baptiste Auguie
##' @examples
##' grid.raster(greyscale_palette(1:10)(1:10))
greyscale_palette <- function(d = NULL, ...){

  scales::grey_pal(min(d), max(d))
  
}

##' diverging colour palette function with set midpoint
##'
##' returns a palette function that maps values to colours, with
##' a midpoint (defaulting to 0) corresponding to the central colour
##' @title diverging_palette
##' @export
##' @param d data giving the range of the palette
##' @param centered logical, whether to use both sides from the midpoint symmetrically
##' @param midpoint numeric value corresponding to the central colour
##' @param colors vector of colors, length must be odd
##' @return a function
##' @author baptiste Auguie
##' @examples
##' grid.raster(diverging_palette(1:10, T, mid=2, col=c("blue", "white", "red"))(1:10))
diverging_palette <- function(d = NULL, centered = FALSE, midpoint = 0,
                              colors = RColorBrewer::brewer.pal(7,"PRGn")){

  half <- length(colors)/2

  if(!length(colors)%%2) stop("requires odd number of colors")
  
  values <-  if(centered) {
    low <- seq(min(d), midpoint, length=half)
    high <- seq(midpoint, max(d), length=half)
    c(low[-length(low)], midpoint, high[-1])
  } else {
    mabs <- max(abs(d - midpoint))
    seq(midpoint-mabs, midpoint + mabs, length=length(colors))
  }
  
  scales::gradient_n_pal(colors, values = values)
  
}

gradient_palette <- function(d = NULL, colors = RColorBrewer::brewer.pal(7,"Set1"), ...){
  
  values <-  seq(min(d), max(d), length=length(colors))
  
  scales::gradient_n_pal(colors, values = values)
  
}



##' draw a colorscale with tick marks
##'
##' draw a colorscale with tick marks
##' @title colorbarGrob
##' @export
##' @aliases grid.colorbar
##' @param d data to map
##' @param x x
##' @param y y
##' @param width width
##' @param height height
##' @param margin space before text
##' @param tick.length tick length
##' @param pretty.breaks pretty breaks
##' @param digits precision of labels
##' @param show.extrema logical, show extreme values
##' @param palet colour palette function
##' @param n resolution of colors
##' @param interpolate logical, passed to grid.raster
##' @param ... additional params for the gTree
##' @return a gTree
##' @author baptiste Auguie
##' @examples
##' set.seed(1234)
##' m <- rnorm(100, 4, 3)
##' library(RColorBrewer)
##' pal1 = brewer.pal(3,"PRGn")
##' grid.newpage()
##' grid.colorbar(m, x=unit(0.3, "npc"), palet = diverging_palette(m, center=TRUE))
##' grid.colorbar(m)
##' grid.colorbar(m, x=unit(0.7, "npc"), show.extrema=FALSE,
##'               n=30, interpolate=FALSE,
##'               width=unit(1,"in"),tick.length = unit(1,"lines"),
##'               gp=gpar(lwd=2, col="grey50"))
colorbarGrob <- function(d, x = unit(0.5, "npc"), 
                         y = unit(0.1,"npc"),
                         height=unit(0.8,"npc"),
                         width=unit(0.5, "cm"),
                         margin=unit(1,"mm"), tick.length=0.2*width,
                         pretty.breaks = grid.pretty(range(d)),
                         digits = 2, show.extrema=TRUE,
                         palet = diverging_palette(d), n = 1e2,
                         interpolate=TRUE,
                         ...){

  ## includes extreme limits of the data
  legend.vals <- unique(round(sort(c(pretty.breaks, min(d), max(d))), digits)) 

  legend.labs <- if(show.extrema)
    legend.vals else pretty.breaks

  ## interpolate the colors
  colors <- palet(seq(min(d), max(d), length=n))
  ## 1D strip of colors, from bottom <-> min(d) to top <-> max(d)
  lg <- rasterGrob(rev(colors), # rasterGrob draws from top to bottom
                   y=y, interpolate=interpolate,
                   x=x, just=c("left", "bottom"),
                   width=width, height=height)

  ## box around color strip
  bg <- rectGrob(x=x, y=y, just=c("left", "bottom"),
                 width=width, height=height, gp=gpar(fill="transparent"))

  ## positions of the tick marks
  pos.y <- y + height * rescale(legend.vals)
  if(!show.extrema) pos.y <-  pos.y[-c(1, length(pos.y))]

  ## tick labels
  ltg <- textGrob(legend.labs, x = x + width + margin, y=pos.y,
                          just=c("left", "center"))
  ## right tick marks
  rticks <- segmentsGrob(y0=pos.y, y1=pos.y,
                         x0 = x + width,
                         x1 = x + width - tick.length,
                         gp=gpar())
  ## left tick marks
 lticks <- segmentsGrob(y0=pos.y, y1=pos.y,
                        x0 = x ,
                        x1 = x + tick.length,
                        gp=gpar())
  
  gTree(children=gList(lg,  lticks, rticks, ltg, bg), cl="colorbar",
        width = width + margin + max(stringWidth(legend.vals)), ... )
}

##' @export
grid.colorbar <- function(...){
  g <- colorbarGrob(...)
  grid.draw(g)
  invisible(g)
}

# grid.colorbar(rnorm(100, 10, 5))