legend <- function(x, y, legend, fill, col = "black", lty, lwd, pch, angle = NULL, density = NULL, 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, plot = TRUE, 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, angle, ...) { 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, angle = angle, density = density, ...) } 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, units="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, units="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) && (is.character(lty) || any(lty > 0)) ) || !missing(lwd) n.leg <- length(legend) ## legends per column: n.legpercol <- if(horiz) { if(ncol != 1) warning( "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) && !is.na(pch[1]) && 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 (plot && bty != "n") { ## The legend box : if(trace) catn(" rect2(",left,",",top,", w=",w,", h=",h,", ...)",sep="") rect2(left, top, dx = w, dy = h, col = bg, angle = NULL) } ## (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 ------------- if(plot) { fill <- rep(fill, length.out=n.leg) rect2(left=xt, top=yt+ybox/2, dx = xbox, dy = ybox, col = fill, angle = angle) } xt <- xt + dx.fill } if(plot && (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 if(missing(lty)) lty <- 1 ok.l <- !is.na(lty) & (is.character(lty) | 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, ...)") if(plot) 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.na(pch) & (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],", ...)") if(plot) 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 if(plot) 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))) }