[Rd] colorbar legend for image()

Martin Maechler Martin Maechler <maechler@stat.math.ethz.ch>
Tue, 28 Aug 2001 10:45:23 +0200


--GtXdrZquwx
Content-Type: text/plain; charset=us-ascii
Content-Description: message body text
Content-Transfer-Encoding: 7bit

>>>>> "MM" == Martin Maechler <maechler@stat.math.ethz.ch> writes:

>>>>> "thomas" == thomas baumann <thomas.baumann@ch.tum.de> writes:
    thomas> Hi, are there any plans to add a colorbar legend to image()?

    thomas> Or such a possibility already implemented which I just haven't
    thomas> discovered yet. Anyway, I will be willing to spent some time on
    thomas> the implementation if there isn't anyone working on that
    thomas> already.

    MM> to the contrary: Martin Schlather wanted to use legend() on top of
    MM> image() and found a buglet in legend() which has been corrected for
    MM> 1.3.1 which is due coming weekend.  To illustrate the new
    MM> possibility of legend, I had produced a function image.legend() and
    MM> he improved (?!) it to image.scale() which isn't yet part of any
    MM> official version of R.  Hence, feedback on the following is *very*
    MM> welcome. Note that it would only work correctly for R version >=
    MM> 1.3.1.  and hence I also attach the 1.3.1 version of legend() {at
    MM> the end}.

(and then I've included the three files
  image.scale.Rd,  image.scale.R  and legend.R )

My error was to confuse Jonathan Rougier's  image.scale()  
  {from a post to R-help, on 21 Sep 1999}
with Martin and Martin's  image.legend() ...

So here is our unfinished stuff with some examples appended.
The code still has a few comments in German (which won't be a problem for
Thomas ..).

Feedback *still* very welcome to both image.annotation versions..

Martin Maechler <maechler@stat.math.ethz.ch>	http://stat.ethz.ch/~maechler/
Seminar fuer Statistik, ETH-Zentrum  LEO D10	Leonhardstr. 27
ETH (Federal Inst. Technology)	8092 Zurich	SWITZERLAND
phone: x-41-1-632-3408		fax: ...-1228			<><


--GtXdrZquwx
Content-Type: text/plain; charset=iso-8859-1
Content-Description: image.legend() by Martin&Martin
Content-Disposition: inline;
	filename="image-legend.R"
Content-Transfer-Encoding: 7bit


image.legend <-
    function(x,y, zlim, at.z = NULL, col = heat.colors(12), legnd=NULL,
             lwd = max(3,32/length(col)), bg = NA, bty = "", ...)
  ## * kein y.i -- Benutzer soll rein ueber lwd steuern; sollte reichen.
  ## * legnd koennte interessant sein, falls Text geschrieben werden soll
  ##   (weiss mal wieder nicht, wie man aus legnd legend als option
  ##     macht)
  ## * lwd wird per default in Abh. von col gewaehlt.
{
    ## Purpose:
    ## Authors: Martin Maechler,   9 Jul 2001
    ##          Martin Schlather, 24 Jul 2001

  if (!is.null(legnd) && is.null(at.z))
      stop("at.z must be given if legnd is") ## falls legnd darf at.z
    ##                                nicht automatisch gewaehlt werden

    if(!is.numeric(zlim) || zlim[1] > zlim[2])
        stop("`zlim' must be numeric; zlim[1] <= zlim[2]")
    if(is.null(at.z)) {
        ## hier ein Versuch in Abhaengigkeit von n
        ## die Anzahl der labels zu bestimmen:
        n <- min(5, max(1,length(col)/10))
        at.z <- pretty(zlim,n=n,min.n=max(n %/% 3,1))

        ## es sieht nicht schoen aus, wenn pretty die letzte oder
        ## erste zahl weit ausserhalb des zlim legt.
        ## heuristisch nur 25%  (oder so) ueberschreitung bzgl
        ## intervalllaenge zulassen:
        tol <- diff(at.z)[1] / 4
        at.z <- at.z[(at.z>=zlim[1]-tol) & (at.z<=zlim[2]+tol)]
      }
    if(!is.numeric(at.z) || is.unsorted(at.z))
        stop("`at.z' must be numeric non-decreasing")
    n.at <- length(at.z)
    nc   <- length(col)
    if(n.at >= nc)
        stop("length(at.z) must be (much) smaller than length(col)")
    dz <- diff(zlim)
    ## The colors must run equidistantly from zlim[1] to zlim[2];
    ## col[i] is for z-interval zlim[1] + [i-1, i) * dz/nc  ; i = 1:nc
    ## i.e., an at.z[] value z0 is color i0 = floor(nc * (z0 - zlim[1])/dz)
    at.i <- floor(nc * (at.z - zlim[1])/dz )
    ## Possibly extend colors by `background' to the left and right
    bgC <- if(is.null(bg)) NA else bg
    if((xtra.l <- 1 - at.i[1]) > 0) {
        at.i <- at.i + xtra.l
        col <- c(rep(bgC, xtra.l), col)
    }
    if((xtra.r <- at.i[n.at] - nc) > 0)
        col <- c(col, rep(bgC, xtra.r))
    lgd <- character(length(col))

    ## folgende if-Anweisung ist neu:
    if (is.null(legnd)) lgd[at.i] <-format(at.z, dig = 3)
    else {
      if (length(legnd)!=length(at.z))
        stop("at.z and legnd must have the same length")
      lgd[at.i] <- legnd
    }
    if((V <- R.version)$major <= 1 && V$minor <= 3.0 && V$status == "")
{
        ## stop-gap fix around the bug that "NA" is not a valid color:
        if(is.na(bgC)) {
            lgd <- lgd[!is.na(col)]
            col <- col[!is.na(col)]
        }
    }
    legend(x,y, legend = rev(lgd), col = rev(col),
           y.i = lwd/16, bty = bty, lwd = lwd, bg = bg, ...)
}



## From  example(image):
data(volcano)
x <- 10*(1:nrow(volcano))
y <- 10*(1:ncol(volcano))

cols <- terrain.colors(100)

op <- par(mar = par("mar")+c(0,0,0,3), xpd = NA)
image(x, y, volcano, col = cols)
## Look :
image.legend(800, 600, zlim= range(volcano), col = cols, trace=TRUE)
image.legend(730, 600, zlim= range(volcano), col = cols, bg = "thistle")
image.legend(730,  15, zlim= range(volcano), col = cols, bg = "light
blue",
             at.z = range(volcano), yjust = 0, lwd = 2, y.interspace = 0.12)
## to check the legend:
contour(x, y, volcano, levels = seq(90, 200, by=5), add = TRUE, col = "peru")


#########################
## ein paar mehr Beispiele
image(x, y, volcano, col = cols)
n <- c(5,10,20,30,40,100)
for (i in 1:length(n))
  image.legend( (i-1)*140,  15, zlim= range(volcano),bg=0,yju=0,
               col=heat.colors(n[i]))

image(x, y, volcano, col = cols)
image.legend( 700,  15, zlim= range(volcano),bg=0,yju=0,
               col=heat.colors(30),
             at.z = range(volcano), legnd=c("low","high"))


--GtXdrZquwx--
-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
r-devel mailing list -- Read http://www.ci.tuwien.ac.at/~hornik/R/R-FAQ.html
Send "info", "help", or "[un]subscribe"
(in the "body", not the subject !)  To: r-devel-request@stat.math.ethz.ch
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._