以R为底的图例:在某些行上可以填满副标题吗?可以填满覆盖整个符号的绘图框吗?

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:

除了，我想要两样东西:

1. for the boxes not to show up on the first two entries.
2. 对于不显示在前两个条目的框。
3. for the boxes to stretch across the dot and the rightmost portion of the line on the last three entries.
4. 为了使方框在最后三个条目上横跨点和线的最右部分。

(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.)

(我用的是base R，而不是ggplot2，这是一些与这个应用程序无关的原因。)

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!

如有任何帮助，我们将不胜感激。谢谢!

1 个解决方案

#1

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.

要删除符号周围的边框，请使用border参数。根据你的背景调整颜色。

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.

围绕符号绘制矩形的函数是?rect。我将xbox的参数乘以3(向下滚动到if (mfill)行)。乘法的正确因数可能要少一点，实验。

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)))
}