[R] How to get legend outside of plot?

Wed Jan 14 15:53:07 CET 2009

> How can I create a legend that is fully outside of the plot, similar to
> what excel does by default, for example?

The common solution with traditional plots (pre-modifying the margin) works well for a one-shot plot, where you calculate the legend size by trial-and-error.

The problem arises when you need to automate this process for different legend texts/sizes. The best solution in this case is to use lattice or ggplot, as others have pointed. If still you want to stick to traditional plots, I have developed the functions below that may help. The idea is to estimate the legend size in an absolute measure unit like inches prior to plotting.

This code is preliminary and not very well tested, so you may need to modify it. The legend size estimation algorithm is very simple, it can be improved by matching what the legend() function really works, but it works well with most of my plots. A basic drawback is that the legend is not redrawn correctly when the plot window is resized....

Run this example client code to see how it works:

	x <- 0:64/64;
	legendText <- paste("sin(", 1:5, "pi * x)");
	oldPar <- par(ask=FALSE, mai=c(1.02, 0.82, 0.82, 0.42));

	for (location in c("outright", "outbottom", "outleft", "outtop")) {
		if (!identical(location, "outright"))
			par(ask=TRUE, mai=c(1.02, 0.82, 0.82, 0.42));
		estimate.legend.size(location, legendText, col=1:5, lty=1:5, pch="*", cex=0.8);
		matplot(x, outer(x, 1:5, function(x, k) sin(k * pi * x)),
			type="o", col=1:5, ylim= c(-1, 1.5), pch="*", main="TITLE");
		legend(0, 1.5, legendText, col=1:5, lty=1:5, pch="*", ncol=3, cex=0.8);
		place.legend(location, legendText, col=1:5, lty=1:5, pch="*", cex=0.8);
	}

	par(oldPar);

Suggestions for improvement welcomed!

Best,

Enrique

# ----------------------------------------------------------------------------------------
#' Converts distances between margin units. Possible units are inches, columns of text, or user coordinates.
#'
#' @param width numeric with the distance width in the \code{input} units.
#' @param height numeric with the distance height in the \code{input} units.
#' @param input string with the input units. The valid values are \code{"inches"}, \code{"mlines"} (margin lines),
#'	and \code{"user"} (user plot coordinates).
#'
#' @returns A list with elements \code{"inches"}, \code{"mlines"}, and \code{"user"}, each of which is a list with
#'	elements \code{width} and \code{height}.
#'
#' @seealso \link{\codegrconvertX}}, \link{\codegrconvertY}}.

cnvrt.plot.distance <- function(width=NA, height=NA, input=c("inches", "mlines", "user")) {
	n <- max(length(width), length(height));
	width <- rep(as.numeric(width), length.out=n);
	height <- rep(as.numeric(height), length.out=n);
	input <- match.arg(input);

	cusr <- par('usr'); 	# Extremes c(x1, x2, y1, y2) of the user coordinates of the plotting region.
	cpin <- par('pin');	# The current plot dimensions (width, height), in inches.
	ccin <- par('cin'); 	# Character size (width, height) in inches.
	cmex <- par('mex');     # A character size expansion factor which is used to describe coordinates in the
					# margins of plots. Note that this does not change the font size, rather specifies
					# the size of font (as a multiple of csi) used to convert between mar and mai, and between oma and omi.

	if (input == "inches") {
		inches <- list(width = width , height = height);

		user <- list(width = width / cpin[1] * (cusr[2] - cusr[1]),
			height = height / cpin[2] * (cusr[4] - cusr[3]));

		mlines <- list(width = width / ccin[2] / cmex,
			height = height / ccin[2] / cmex );

	} else if (input == "mlines") {
		mlines <- list(width = width , height = height);

		inches <- list(width = width * ccin[2] * cmex,
			height = height * ccin[2] * cmex );

		user <- list(width = inches$width / cpin[1] * (cusr[2] - cusr[1]),
			height = inches$height / cpin[2] * (cusr[4] - cusr[3]));

	} else if (input == "user") {
		user <- list(width = width , height = height);

		inches <- list(width = width * cpin[1] / (cusr[2] - cusr[1]),
			height = height * cpin[2] / (cusr[4] - cusr[3]));

		mlines <- list(width = inches$width / ccin[2] / cmex,
			height = inches$height / ccin[2] / cmex );
	}
	list(inches=inches, mlines=mlines, user=user);
}

# ---------------------------------------------------------------------------------------- 
#' Modifies plot margins.
#'
#' @param side a number in 1:4 or a string specifying the margin side to modify. The allowed values for strings
#'		are \code{"bottom"} (the default), \code{"left"}, \code{"top"}, and \code{"right"}.
#' @param by the amount to add/substract to the current margin. It can be one of the following three types:
#'		1) a number; 2) a list at least two numeric items named \code{width} and \code{height} (only one of them will be
#'		used, depending on the margin side being set); or 3) a character vector, whose width as computed by
#'		\link{\code{strwidth}} will be \code{by}.
#' @param input string defining the unit of measure of the input (when \code{by} is numeric of a list with numeric elements).
#'		The allowed values are \code{"inches"} (the default), \code{"mlines"}, and \code{"user"}.
#' @param which string defining which plot margin should be set. The valid values are \code{"mai"} (the default), \code{"omi"},
#'		and \code{"mar"}.
#' @param current numeric vector of length 4 that defines the current value of the margins that should be modified.
#'		Defaults to the corresponding graphical parameter \code{par(which)}.
#' @param set.par logical. Whether the corresponding graphical parameter should be automatically modified using \code{par}.
#' @param ... additional arguments to be passed to function \code{strwidth} when \code{by} is a character vector.
#'
#' @returns A numeric vector of length 4 with the new margin values. Note that when \code{set.par} is \code{TRUE}, also
#'		modifies \code{par(which)} as a side effect.

modify.margin <- function(side=c("bottom", "left", "top", "right"), by, input=c("inches", "mlines", "user"),
		which=c("mai", "omi", "mar"), current=par(which), set.par=FALSE, ...) {
	defaultSides <- c("bottom", "left", "top", "right");
	if (is.numeric(side)) {
		nSide <- side;
		side <- defaultSides[nSide];
	} else {
		side <- match.arg(side, defaultSides);
		nSide <- match(side, defaultSides);
	}
	input <- match.arg(input);
	which <- match.arg(which);

	# Compute size if 'by' is a character vector
	targetUnit <- c("inches", "inches", "mlines")[match(which, c("mai", "omi", "mar"))];
	isVertical <- (side %in% c("bottom", "top"));
	if (is.character(by)) {
		by <- max(strwidth(by, units="inches", ...), na.rm=TRUE);
		input <- "inches";
	} else if (is.list(by) && all(c("width", "height") %in% names(by))) {
		by <- if (isVertical) by$height else by$width;
	} else if (!is.numeric(by) && length(by) == 1)
		stop(gettextf("'%s' must be either a number, a list with 'width' and 'height' components, or a character vector", "by"));

	# Convert input distance to target unit depending on which margin we're setting.
	if (input != targetUnit) {
		by <- if (isVertical) {
			cnvrt.plot.distance(width=by, input=input)[[targetUnit]]$width;
		} else cnvrt.plot.distance(height=by, input=input)[[targetUnit]]$height;
	}

	# Modify the margin value
	result <- current;
	result[nSide] <- result[nSide] + by;

	# Set the plot parameter
	if (set.par) {
		parValue <- list(result);
		names(parValue) <- which;
		do.call("par", parValue);
	}

	result;
}

# ---------------------------------------------------------------------------------------- 
#' A wrapper for \link{\code{legend}} that provides new location options for positioning the legend outside the plot area.
#'
#' @param location where the legend will be located. This can be a numeric vector of length 2 defining the \code{x} and
#'		\code{y} user coordinates, or a string with allowed values \code{"outtop"}, \code{"outbottom"}, \code{"outleft"},
#'		\code{"outright"}, \code{"bottomright"}, \code{"bottom"}, \code{"bottomleft"}, \code{"left"}, \code{"topleft"},
#'		\code{"top"}, \code{"topright"}, \code{"right"}, and \code{"center"}.
#' @param ... further parameters passed to the \link{\code{legend}} function.
#'
#' @returns The same list as \code{legend} (invisibly).
#'
#' @details For positioning outside the plot area, client code should ensure that enough space is available on the corresponding
#'	margin, which can be done using \code{estimate.legend.size(..., adjust.margin="mai")} before the actual plotting is done.
#'
#'  Note that some aesthetic defaults have been changed to adapt to corporate guidelines, e.g. not drawing the box around the legend,
#'	or outtop/outbottom legend positioning close to the edge.
#'
#' @seealso \link{\code{legend}}, \link{\code{estimate.legend.size}}.
#' @notes ToDo: Add also positioning options for smart inside, and interactive.
#'	For smart inside positioning see \code{plotrix::emptyspace(x.index, x, bar=TRUE)}.

place.legend <- function(location, ...) {
	dots <- list(...);
	if (is.null(dots$bty)) dots$bty <- "n";

	if (is.numeric(location))
		if (length(location) == 2)
			return(do.call("legend", c(list(x=location[1], y=location[2]), dots)))
		else stop(gettextf("Format of '%s' not recognized", "location"));

	location <- match.arg(location, c("outtop", "outbottom", "outleft", "outright",
		"bottomright", "bottom", "bottomleft", "left", "topleft", "top", "topright", "right", "center"));

	if (substr(location, 1, 3) == "out") {
		if (is.null(dots$horiz)) dots$horiz <- (location %in% c("outtop", "outbottom"));
		dots$xjust <- switch(location, outleft=0, outright=1, outtop=, outbottom=0.5);
		dots$yjust <- switch(location, outleft=, outright=0.5, outtop=1, outbottom=0);
        dots$x <- switch(location,
			outtop = , outbottom = grconvertX(0.5, from="ndc", to="user"),
			outleft = grconvertX(0, from="ndc", to="user"),
			outright = grconvertX(1, from="ndc", to="user") )
        dots$y <- switch(location,
			outleft = , outright = grconvertY(0.5, from="ndc", to="user"),
			outtop = grconvertY(1, from="ndc", to="user"),
			outbottom = grconvertY(0, from="ndc", to="user") )

		oxpd <- par(xpd=NA);
		on.exit(par(oxpd));
		do.call("legend", dots);
	} else do.call("legend", c(list(x=location, y=NULL), dots));
}

# ---------------------------------------------------------------------------------------- 
#' Legend Size
#'
#' Estimates the plot space required for the specified legend, in inches.
#'
#' @param location a string defining where the legend will be located
#' @param legend a character or expression vector of length >= 1 to appear in the legend. See \link{legend}.
#' @param cex character expansion factor \bold{relative} to current \code{par("cex")}. See \link{legend}.
#' @param x.intersp character interspacing factor for horizontal (x) spacing. See \link{legend}.
#' @param y.intersp character interspacing factor for vertical (y) spacing. See \link{legend}.
#' @param ncol the number of columns in which to set the legend items (default is 1, a vertical legend). See \link{legend}.
#' @param horiz logical; if \code{TRUE}, set the legend horizontally rather than vertically. Specifying \code{horiz} overrides
#'		the \code{ncol} specification. If \code{location} is defined, \code{horiz} defaults to \code{TRUE} for legends on the
#'		left or right margins, and to \code{FALSE} for legends on the top or bottom margins.
#' @param title a character string or length-one expression giving a title to be placed at the top of the legend. See \link{legend}.
#' @param direct logical; If \code{TRUE}, the estimation is done directly using the \code{legend} function with \code{plot=FALSE}
#'		argument, otherwise using an approximation. \code{TRUE} produces an exact measure but can only be computed
#'		if the graphics device is open and user coordinates have been set. Otherwise, use indirect estimation.
#' @param adjust.margin a string defining which margin should be automatically resized, if any. Use \code{NULL} for no
#'		adjustment. The allowed values are \code{"mar"}, \code{"mai"}, and \code{"omi"}.
#'
#' @return A list with components \code{width} and \code{height} giving the legend estimated size in inches.
#'
#' @details This is to be used by traditional plots functions with legends outside the plot area to leave enough space in the
#'	corresponding margin before plotting the data.
#'
#' 	ToDo: Not all possible legend cases have been handled in indirect estimation, just some basic ones. This needs
#' 	further development and testing.
#'
#' @seealso \link{\code{place.legend}}, \link{\code{legend}}.

estimate.legend.size <- function(location=c("outright", "outleft", "outtop", "outbottom"), legend=NULL, cex=1, x.intersp=1, y.intersp=1,
		ncol=1, horiz=(location %in% c("outtop", "outbottom")), title=NULL, direct=FALSE, adjust.margin=c("mai", "omi", "mar"), ...) {
	location <- match.arg(location);
	result <- list(width=0, height=0);
	if (is.null(legend)) return(result) else legend <- as.character(legend);
	if (direct) {
		# Note: Can this really be done? If then we use this measures to modify 'mai', won't the new user coordinates change
		#	their mapping to inches?
		legendSize <- legend(x=par("usr")[1], y=par("usr")[4], legend=legend, cex=cex, x.intersp=x.intersp, y.intersp=y.intersp,
			ncol=ncol, horiz=horiz, title=title, plot=FALSE, ...);
		result <- cnvrt.plot.distance(legendSize$rect$w, legendSize$rect$h, input="user")$inches;
	} else {
		labelWidth <- max(strwidth(legend, units="inches", cex=cex), na.rm=TRUE);
		labelHeight <- max(strheight(legend, units="inches", cex=cex), na.rm=TRUE);
		interspWidth <- strwidth(paste(rep(" ", times=x.intersp), collapse=""), units="inches", cex=cex);
		interspHeight <- strheight(paste(rep(" ", times=y.intersp), collapse=""), units="inches", cex=cex);
		symbolWidth <- strwidth("         ", units="inches", cex=cex);
		titleHeight <- if (is.null(title)) 0 else strheight(title, units="inches", cex=cex);
		if (horiz) {
			if (ncol == 1) {
				ncol <- length(legend);
				nrow <- 1;
			} else nrow <- ceiling(length(legend) / ncol);
		} else {
			if (ncol == 1) {
				nrow <- length(legend);
			} else nrow <- ceiling(length(legend) / ncol);
		}

		result$width <- ncol * (labelWidth + symbolWidth) + (ncol - 1) * interspWidth;
		result$height <- nrow * labelHeight + (nrow - 1) * interspHeight + titleHeight;
	}

	if (!is.null(adjust.margin))
		modify.margin(match(location, c("outbottom", "outleft", "outtop", "outright")), by=result, input="inches",
			which=adjust.margin, set.par=TRUE);

	result;
}