[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
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._