rgraphicsfilllegend
Legend in Base R: Can fill refrain from drawing boxes on some lines? Can fill draw boxes that cover the whole symbol?
I have a plot with overlapping shaded confidence intervals that looks like this:
and I would like very much to annotate the legend with the color of the confidence interval. Something like:
except, I'd like two things:
- for the boxes not to show up on the first two entries.
- for the boxes to stretch across the dot and the rightmost portion of the line on the last three entries.
(And I'm using base R instead of ggplot2 for a couple of reasons specific to this application that aren't really relevant to explain.)
Here is a code example that reproduces the legend:
#Build a fake plot so that legend has somewhere to sit
xx <- seq(0,10,by=.1)
yy <- 2*xx + rnorm(length(xx),0,1)
plot(xx,yy)
#Build the legend
estNames <- c('est1','est2','est3')
legend('bottomright',
c("no box, no point","no box, no point",estNames) ,
lty=c(rep('dotted',2),rep('solid',3)),
col=c('black','red',1,2,4),
pch=c(-1,-1,rep(16,3)),
lwd=1,
fill=c( 0, 0,
rep( c( rgb(0.5,0.5,0.1,0.25),
rgb(0.5,0.1,0.1,0.25),
rgb(0.1,0.1,0.5,0.25)), 2)),
inset=0,bg='white')
Any help would be appreciated. Thanks!
Solution
Ugly ad hoc solution, but seems to work.
To remove the border around the symbols, use the border argument. Adjust colors according to your background.
legend.v2('bottomright',
c("no box, no point","no box, no point",estNames) ,
lty=c(rep('dotted',2),rep('solid',3)),
col=c('black','red',1,2,4),
pch=c(-1,-1,rep(16,3)),
lwd=1,
border = c("white", "white", "black", "black", "black"),
trace = TRUE,
fill=c( 0, 0,
rep( c( rgb(0.5,0.5,0.1,0.25),
rgb(0.5,0.1,0.1,0.25),
rgb(0.1,0.1,0.5,0.25)), 2)),
inset=0,bg='white')
The function that draws rectangles around the symbols is ?rect.
I've multiplied the xbox argument by 3 (scroll down to the if (mfill) line). The correct factor of multiplication is probably a bit less, experiment.
legend.v2 <- function (x, y = NULL, legend, fill = NULL, col = par("col"),
border = "black", lty, lwd, pch, angle = 45, density = NULL,
bty = "o", bg = par("bg"), box.lwd = par("lwd"), box.lty = par("lty"),
box.col = par("fg"), pt.bg = NA, cex = 1, pt.cex = cex, pt.lwd = lwd,
xjust = 0, yjust = 1, x.intersp = 1, y.intersp = 1, adj = c(0,
0.5), text.width = NULL, text.col = par("col"), merge = do.lines &&
has.pch, trace = FALSE, plot = TRUE, ncol = 1, horiz = FALSE,
title = NULL, inset = 0, xpd, title.col = text.col, title.adj = 0.5,
seg.len = 2)
{
if (missing(legend) && !missing(y) && (is.character(y) ||
is.expression(y))) {
legend <- y
y <- NULL
}
mfill <- !missing(fill) || !missing(density)
if (!missing(xpd)) {
op <- par("xpd")
on.exit(par(xpd = op))
par(xpd = xpd)
}
title <- as.graphicsAnnot(title)
if (length(title) > 1)
stop("invalid title")
legend <- as.graphicsAnnot(legend)
n.leg <- if (is.call(legend))
1
else length(legend)
if (n.leg == 0)
stop("'legend' is of length 0")
auto <- if (is.character(x))
match.arg(x, c("bottomright", "bottom", "bottomleft",
"left", "topleft", "top", "topright", "right", "center"))
else NA
if (is.na(auto)) {
xy <- xy.coords(x, y)
x <- xy$x
y <- xy$y
nx <- length(x)
if (nx < 1 || nx > 2)
stop("invalid coordinate lengths")
}
else nx <- 0
xlog <- par("xlog")
ylog <- par("ylog")
rect2 <- function(left, top, dx, dy, density = NULL, 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, ...) {
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")
if (is.null(text.width))
text.width <- max(abs(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[1L], warn.log = FALSE)
yc <- Cex * yinch(cin[2L], warn.log = FALSE)
if (xc < 0)
text.width <- -text.width
xchar <- xc
xextra <- 0
yextra <- yc * (y.intersp - 1)
ymax <- yc * max(1, strheight(legend, units = "user", cex = cex)/yc)
ychar <- yextra + ymax
if (trace)
catn(" xchar=", xchar, "; (yextra,ychar)=", c(yextra,
ychar))
if (mfill) {
xbox <- xc * 0.8
ybox <- yc * 0.5
dx.fill <- xbox
}
do.lines <- (!missing(lty) && (is.character(lty) || any(lty >
0))) || !missing(lwd)
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)
has.pch <- !missing(pch) && length(pch) > 0
if (do.lines) {
x.off <- if (merge)
-0.7
else 0
}
else if (merge)
warning("'merge = TRUE' has no effect when no line segments are drawn")
if (has.pch) {
if (is.character(pch) && !is.na(pch[1L]) && nchar(pch[1L],
type = "c") > 1) {
if (length(pch) > 1)
warning("not using pch[2..] since pch[1L] has multiple chars")
np <- nchar(pch[1L], type = "c")
pch <- substr(rep.int(pch[1L], np), 1L:np, 1L:np)
}
}
if (is.na(auto)) {
if (xlog)
x <- log10(x)
if (ylog)
y <- log10(y)
}
if (nx == 2) {
x <- sort(x)
y <- sort(y)
left <- x[1L]
top <- y[2L]
w <- diff(x)
h <- diff(y)
w0 <- w/ncol
x <- mean(x)
y <- mean(y)
if (missing(xjust))
xjust <- 0.5
if (missing(yjust))
yjust <- 0.5
}
else {
h <- (n.legpercol + (!is.null(title))) * ychar + yc
w0 <- text.width + (x.intersp + 1) * xchar
if (mfill)
w0 <- w0 + dx.fill
if (do.lines)
w0 <- w0 + (seg.len + +x.off) * xchar
w <- ncol * w0 + 0.5 * xchar
if (!is.null(title) && (abs(tw <- strwidth(title, units = "user",
cex = cex) + 0.5 * xchar)) > abs(w)) {
xextra <- (tw - w)/2
w <- tw
}
if (is.na(auto)) {
left <- x - xjust * w
top <- y + (1 - yjust) * h
}
else {
usr <- par("usr")
inset <- rep(inset, length.out = 2)
insetx <- inset[1L] * (usr[2L] - usr[1L])
left <- switch(auto, bottomright = , topright = ,
right = usr[2L] - w - insetx, bottomleft = ,
left = , topleft = usr[1L] + insetx, bottom = ,
top = , center = (usr[1L] + usr[2L] - w)/2)
insety <- inset[2L] * (usr[4L] - usr[3L])
top <- switch(auto, bottomright = , bottom = , bottomleft = usr[3L] +
h + insety, topleft = , top = , topright = usr[4L] -
insety, left = , right = , center = (usr[3L] +
usr[4L] + h)/2)
}
}
if (plot && bty != "n") {
if (trace)
catn(" rect2(", left, ",", top, ", w=", w, ", h=",
h, ", ...)", sep = "")
rect2(left, top, dx = w, dy = h, col = bg, density = NULL,
lwd = box.lwd, lty = box.lty, border = box.col)
}
xt <- left + xchar + xextra + (w0 * rep.int(0:(ncol - 1),
rep.int(n.legpercol, ncol)))[1L:n.leg]
yt <- top - 0.5 * yextra - ymax - (rep.int(1L:n.legpercol,
ncol)[1L:n.leg] - 1 + (!is.null(title))) * ychar
if (mfill) {
if (plot) {
fill <- rep(fill, length.out = n.leg)
rect2(left = xt, top = yt + ybox/2, dx = xbox * 3, dy = ybox,
col = fill, density = density, angle = angle,
border = border)
}
xt <- xt + dx.fill
}
if (plot && (has.pch || do.lines))
col <- rep(col, length.out = n.leg)
if (missing(lwd))
lwd <- par("lwd")
if (do.lines) {
if (missing(lty))
lty <- 1
lty <- rep(lty, length.out = n.leg)
lwd <- rep(lwd, length.out = n.leg)
ok.l <- !is.na(lty) & (is.character(lty) | lty > 0)
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])
xt <- xt + (seg.len + x.off) * xchar
}
if (has.pch) {
pch <- rep(pch, length.out = n.leg)
pt.bg <- rep(pt.bg, length.out = n.leg)
pt.cex <- rep(pt.cex, length.out = n.leg)
pt.lwd <- rep(pt.lwd, length.out = n.leg)
ok <- !is.na(pch) & (is.character(pch) | pch >= 0)
x1 <- (if (merge && do.lines)
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 = pt.cex[ok],
bg = pt.bg[ok], lwd = pt.lwd[ok])
}
xt <- xt + x.intersp * xchar
if (plot) {
if (!is.null(title))
text2(left + w * title.adj, top - ymax, labels = title,
adj = c(title.adj, 0), cex = cex, col = title.col)
text2(xt, yt, labels = legend, adj = adj, cex = cex,
col = text.col)
}
invisible(list(rect = list(w = w, h = h, left = left, top = top),
text = list(x = xt, y = yt)))
}
- Calculate average distance to coastline in R
- How to use purrr:map() and rlang to emulate a pipe chain
- magick annotate picture with arrows
- Import png files and convert to animation(.mp4) in R
- Convert a column with text files into separate images in R
- How to calculate RSE_Var from SE_var/mean_Var row-wise for many variables, Var, using pivot() in R?
- ggplot2 x-axis with many hours for each of many days. Is there a way to span the dates in the x-axis over the hours for that day?
- gtsummary - Wilcoxon on ordered factor
- R odbc::odbcListDrivers() does not list dirver in /opt/homebrew/etc/odbcinst.ini
- Change size and aspect ratio without distortion
- How can I get an R environment via Sys.getenv() with GitHub Actions using secrets?
- ggplot geom_point color based on both x and y axis values
- Perform a random binomial draw for each row in R without rowwise()
- Scrape the university name (in QS World University Rankings website) with R
- ggplot for linear-log regression model?
- How to join (merge) data frames (inner, outer, left, right)
- Avoid rescaling while binning using scale_*_steps
- How can I mock a function globally using testthat?
- R - could not find function "cld"
- Create multiple lagged variables with different offsets
- Expanding dataframe to include non existing values
- Split string to columns based on paragraph ending from ocr'd image
- from magick-image to rasterBrick
- How to remove repeated elements in a vector, similar to 'set' in Python
- Rename multiple variables at once using dplyr
- Reading large multi-part table from file and combing its parts into one tibble
- Processing multiple images with Magick (in R) with transformations
- R: Convert/Read 3D Matrix into a 'magick' object and vice versa
- Error using magick R to import PDF
- Method in R to crop whitespace on svg file