Hi, are there any plans to add a colorbar legend to image()? Or such a possibility already implemented which I just haven't discovered yet. Anyway, I will be willing to spent some time on the implementation if there isn't anyone working on that already. Thanks Thomas -.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.- 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 _._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._
colorbar legend for image()
3 messages · thomas.baumann@ch.tum.de, Martin Maechler
--LSat2th5Z+ Content-Type: text/plain; charset=us-ascii Content-Description: message body text Content-Transfer-Encoding: 7bit
"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.
to the contrary: Martin Schlather wanted to use legend() on top of image()
and found a buglet in legend() which has been corrected for 1.3.1 which is
due coming weekend.
To illustrate the new possibility of legend, I had produced a function
image.legend() and he improved (?!) it to image.scale()
which isn't yet part of any official version of R.
Hence, feedback on the following is *very* welcome. Note that it would only work
correctly for R version >= 1.3.1. and hence I also attach the 1.3.1
version of legend() {at the end}.
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 <><
--LSat2th5Z+
Content-Type: text/plain
Content-Description: Help for image.scale()
Content-Disposition: inline;
filename="image.scale.Rd"
Content-Transfer-Encoding: 7bit
\name{image.scale}
\alias{image.scale}
\title{Provide scale to image plots}
\usage{
image.scale(z, col, x, y=NULL, size=NULL, digits=2, labels=c("breaks", "ranges"))
}
\arguments{
\item{z}{Data from image plot}
\item{col}{Colours from image plot}
\item{x}{Horizintal location of top-left corner of scale, or list with
\code{x} and \code{y} components}
\item{y}{Vertical location of top-left corner of scale}
\item{size}{1- or 2-vector of colour-box dimensions}
\item{digits}{Number of digits after the decimal point in labels}
\item{labels}{Type of labels}
}
\description{
Provides a vertical colour scale to accompany an image plot. The
location defaults to the right of the plot, the colour-boxes
default to square, and the style of the labels defaults to giving
the breaks to the right of the scale.}
\details{
Use \code{x=locator(1)} or give both \code{x} and \code{y}
arguments to specify the top-left corner of the scale. The
colour-boxes then default to squares, and the image is centred
around the vertical midpoint. Use \code{x=locator(2)} for
complete control of the scale size and location. The usual scale
(labels to the right) requires a top-left and bottom-right. To
reverse the scale, go bottom-top. To swith labels to the left,
go right-left.
The labels default to single values giving the breaks, centred
between colour-boxes. For ranges centred vertically on each
colour-box (wider), specify \code{labels="ranges"}.}
\author{Jonathan Rougier}
\seealso{\code{\link{image}}}
\examples{
# create an image plot
x <- seq(-0.5, 0.5, len = 31)
qform <- function(x, y) 3*x^2 + y^2 - 2*x*y
z <- outer(x, x, FUN = qform)
par("mar" = c(5, 4, 4, 10) + 0.1) # wide righthand margin
image(x, x, z, col=gray(6:12/15))
image.scale(z, gray(6:12/15)) # the default
image(x, x, z, col=gray(6:12/15))
image.scale(z, gray(6:12/15), labels="range") # with range labels
# play around with the following ...
image(x, x, z, col=gray(6:12/15))
image.scale(z, gray(6:12/15), x=locator(1)) # or locator(2)
}
\keyword{aplot,iplot,color}
--LSat2th5Z+
Content-Type: text/plain
Content-Description: image.scale() by two Martins
Content-Disposition: inline;
filename="image.scale.R"
Content-Transfer-Encoding: 7bit
"image.scale" <-
function (z, col, x, y = NULL, size = NULL, digits = 2, labels = c("breaks",
"ranges"))
{
# sort out the location
n <- length(col)
usr <- par("usr")
mx <- mean(usr[1:2]); my <- mean(usr[3:4])
dx <- diff(usr[1:2]); dy <- diff(usr[3:4])
if (missing(x))
x <- mx + 1.05*dx/2 # default x to right of image
else if (is.list(x)) {
if (length(x$x) == 2)
size <- c(diff(x$x), -diff(x$y)/n)
y <- x$y[1]
x <- x$x[1]
} else x <- x[1]
if (is.null(size))
if (is.null(y)) {
size <- 0.618*dy/n # default size, golden ratio
y <- my + 0.618*dy/2 # default y to give centred scale
} else size <- (y-my)*2/n
if (length(size)==1)
size <- rep(size, 2) # default square boxes
if (is.null(y))
y <- my + n*size[2]/2
# draw the image scale
i <- seq(along = col)
rect(x, y - i * size[2], x + size[1], y - (i - 1) * size[2],
col = rev(col), xpd = TRUE)
# sort out the labels
rng <- range(z, na.rm = TRUE)
bks <- seq(from = rng[2], to = rng[1], length = n + 1)
bks <- formatC(bks, format="f", digits=digits)
labels <- match.arg(labels)
if (labels == "breaks")
ypts <- y - c(0, i) * size[2]
else {
bks <- paste(bks[-1], bks[-(n+1)], sep = " - ")
ypts <- y - (i - 0.5) * size[2]
}
text(x = x + 1.2 * size[1], y = ypts, labels = bks, adj =
ifelse(size[1]>0, 0, 1), xpd = TRUE)
}
--LSat2th5Z+
Content-Type: text/plain
Content-Description: legend.R from "R-patched" aka "1.3.1 to be"
Content-Disposition: inline;
filename="legend.R"
Content-Transfer-Encoding: 7bit
legend <-
function(x, y, legend, fill, col = "black", lty, lwd, pch, bty = "o",
bg = par("bg"), pt.bg = NA, cex = 1,
xjust = 0, yjust = 1, x.intersp = 1, y.intersp = 1, adj = 0,
text.width = NULL, merge = do.lines && has.pch, trace = FALSE,
ncol = 1, horiz = FALSE)
{
if(is.list(x)) {
if(!missing(y)) { # the 2nd arg may really be `legend'
if(!missing(legend))
stop("`y' and `legend' when `x' is list (need no `y')")
legend <- y
}
y <- x$y; x <- x$x
} else if(missing(y)) stop("missing y")
if (!is.numeric(x) || !is.numeric(y))
stop("non-numeric coordinates")
if ((nx <- length(x)) <= 0 || nx != length(y) || nx > 2)
stop("invalid coordinate lengths")
xlog <- par("xlog")
ylog <- par("ylog")
rect2 <- function(left, top, dx, dy, ...) {
r <- left + dx; if(xlog) { left <- 10^left; r <- 10^r }
b <- top - dy; if(ylog) { top <- 10^top; b <- 10^b }
rect(left, top, r, b, ...)
}
segments2 <- function(x1, y1, dx, dy, ...) {
x2 <- x1 + dx; if(xlog) { x1 <- 10^x1; x2 <- 10^x2 }
y2 <- y1 + dy; if(ylog) { y1 <- 10^y1; y2 <- 10^y2 }
segments(x1, y1, x2, y2, ...)
}
points2 <- function(x, y, ...) {
if(xlog) x <- 10^x
if(ylog) y <- 10^y
points(x, y, ...)
}
text2 <- function(x, y, ...) {
##--- need to adjust adj == c(xadj, yadj) ?? --
if(xlog) x <- 10^x
if(ylog) y <- 10^y
text(x, y, ...)
}
if(trace)
catn <- function(...)
do.call("cat", c(lapply(list(...),formatC), list("\n")))
cin <- par("cin")
Cex <- cex * par("cex") # = the `effective' cex for text
if(is.null(text.width))
text.width <- max(strwidth(legend, u="user", cex=cex))
else if(!is.numeric(text.width) || text.width < 0)
stop("text.width must be numeric, >= 0")
xc <- Cex * xinch(cin[1], warn.log=FALSE)# [uses par("usr") and "pin"]
yc <- Cex * yinch(cin[2], warn.log=FALSE)
xchar <- xc
yextra <- yc * (y.intersp - 1)
ymax <- max(yc, strheight(legend, u="user", cex=cex))
ychar <- yextra + ymax
if(trace) catn(" xchar=", xchar, "; (yextra,ychar)=", c(yextra,ychar))
if(!missing(fill)) {
##= sizes of filled boxes.
xbox <- xc * 0.8
ybox <- yc * 0.5
dx.fill <- xbox ## + x.intersp*xchar
}
do.lines <- (!missing(lty) && any(lty > 0)) || !missing(lwd)
n.leg <- length(legend)
## legends per column:
n.legpercol <-
if(horiz) {
if(ncol != 1)
warning(paste(
"horizontal specification overrides: Number of columns :=",n.leg))
ncol <- n.leg
1
} else ceiling(n.leg / ncol)
if(has.pch <- !missing(pch)) {
if(is.character(pch) && nchar(pch[1]) > 1) {
if(length(pch) > 1)
warning("Not using pch[2..] since pch[1] has multiple chars")
np <- nchar(pch[1])
pch <- substr(rep(pch[1], np), 1:np, 1:np)
}
if(!merge) dx.pch <- x.intersp/2 * xchar
}
x.off <- if(merge) -0.7 else 0
##- Adjust (x,y) :
if (xlog) x <- log10(x)
if (ylog) y <- log10(y)
if(nx == 2) {
## (x,y) are specifiying OPPOSITE corners of the box
x <- sort(x)
y <- sort(y)
left <- x[1]
top <- y[2]
w <- diff(x)# width
h <- diff(y)# height
w0 <- w/ncol # column width
x <- mean(x)
y <- mean(y)
if(missing(xjust)) xjust <- 0.5
if(missing(yjust)) yjust <- 0.5
}
else {## nx == 1
## -- (w,h) := (width,height) of the box to draw -- computed in steps
h <- n.legpercol * ychar + yc
w0 <- text.width + (x.intersp + 1) * xchar
if(!missing(fill)) w0 <- w0 + dx.fill
if(has.pch && !merge) w0 <- w0 + dx.pch
if(do.lines) w0 <- w0 + (2+x.off) * xchar
w <- ncol*w0 + .5* xchar
##-- (w,h) are now the final box width/height.
left <- x - xjust * w
top <- y + (1 - yjust) * h
}
if (bty != "n") {
if(trace)
catn(" rect2(",left,",",top,", w=",w,", h=",h,"...)",sep="")
rect2(left, top, dx = w, dy = h, col = bg)
}
## (xt[],yt[]) := `current' vectors of (x/y) legend text
xt <- left + xchar + (w0 * rep(0:(ncol-1), rep(n.legpercol,ncol)))[1:n.leg]
yt <- top - (rep(1:n.legpercol,ncol)[1:n.leg]-1) * ychar - 0.5 * yextra - ymax
if (!missing(fill)) { #- draw filled boxes -------------
fill <- rep(fill, length.out=n.leg)
rect2(left=xt, top=yt+ybox/2, dx = xbox, dy = ybox, col = fill)
xt <- xt + dx.fill
}
if(has.pch || do.lines)
col <- rep(col,length.out=n.leg)
if (do.lines) { #- draw lines ---------------------
seg.len <- 2 # length of drawn segment, in xchar units
ok.l <- if(missing(lty)) { lty <- 1; TRUE } else lty > 0
if(missing(lwd)) lwd <- par("lwd")
lty <- rep(lty, length.out = n.leg)
lwd <- rep(lwd, length.out = n.leg)
if(trace)
catn(" segments2(",xt[ok.l] + x.off*xchar ,",", yt[ok.l],
", dx=",seg.len*xchar,", dy=0, ...)", sep="")
segments2(xt[ok.l] + x.off*xchar, yt[ok.l], dx= seg.len*xchar, dy=0,
lty = lty[ok.l], lwd = lwd[ok.l], col = col[ok.l])
# if (!merge)
xt <- xt + (seg.len+x.off) * xchar
}
if (has.pch) { #- draw points -------------------
pch <- rep(pch, length.out=n.leg)
pt.bg <- rep(pt.bg, length.out=n.leg)
ok <- is.character(pch) | pch >= 0
x1 <- (if(merge) xt-(seg.len/2)*xchar else xt)[ok]
y1 <- yt[ok]
if(trace)
catn(" points2(", x1,",", y1,", pch=", pch[ok],"...)")
points2(x1, y1, pch=pch[ok], col=col[ok], cex=cex, bg = pt.bg[ok])
if (!merge) xt <- xt + dx.pch
}
xt <- xt + x.intersp * xchar
text2(xt, yt, labels= legend, adj= adj, cex= cex)
invisible(list(rect = list(w=w, h=h, left=left, top=top),
text = list(x = xt, y = yt)))
}
--LSat2th5Z+--
-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-
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
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._
--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
_._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._._