[Rd] colorbar legend for image()

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


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