R: legenda con punti e linee di colori diversi (per lo stesso oggetto legenda)

Question

Utilizzando la funzione legend() è possibile avere il punto e la linea di colori diversi? Mi sento come se mi mancasse qualcosa di abbastanza ovvio. L'opzione pt.bg può cambiare il colore di sfondo, ma non vedo un'opzione

L'errore si verifica nel caso in cui si utilizzano i comandi lines() e points() separatamente con colori diversi e si desidera che la legenda rappresenti ciò che è tracciato.

Ho pensato che potrebbe essere possibile con le opzioni merge, ma chiaramente non capisco a cosa serve.

Esempio:

plot(0, type="n", xlim=c(0,5), ylim=c(0,5)) 
A <- matrix(c(c(1,2,3,4), c(2,1,2,4)), ncol=2) 
B <- matrix(c(c(1,2,3,4), c(1,3,3,2)), ncol=2) 
lines(A, col="red") 
points(A, col="blue", pch=15) 
lines(B, col="green") 
points(B, col="purple", pch=17) 

legend(x="topleft", 
     legend=c("Red line, blue points","Green line, purple points"), 
     col=c("red","green"), lwd=1, lty=c(1,2), 
     pch=c(15,17)) 

legend(x="bottomleft", 
     legend=c("Red line","blue points","Green line","purple points"), 
     col=c("red","blue","green","purple"), lwd=1, lty=c(1,NA,2,NA), 
     pch=c(NA,15,NA,17)) 

legend(x="left", 
     legend=c("Red line, blue points","Green line, purple points"), 
     col=c("red","green"), lwd=1, lty=c(1,2), pch=c(15,17), merge=FALSE) 

legend(x="bottomright", 
     legend=c("Red line","blue points","Green line","purple points"), 
     col=c("red","blue","green","purple"), lwd=1, lty=c(1,NA,2,NA), 
     pch=c(NA,15,NA,17), merge=FALSE) 

legend(x="topright", 
     legend=c("Red line, blue points","Green line, purple points"), 
     col=c("red","blue","green","purple"), lwd=1, lty=c(1,2), 
     pch=c(15,17), merge=FALSE) 

IMG http://i43.tinypic.com/vo4kmt.png

Soluzione

ho inciso la funzione legenda() per utilizzare due differenti vettori di colore:

LEGEND <- function (x, y = NULL, legend, fill = NULL, 
    col = par("col"), pt.col=col, line.col=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"), text.font = NULL, 
    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, font = text.font))) 
    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(gettextf("horizontal specification overrides: Number of columns := %d", 
       n.leg), domain = NA) 
     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.character(pch)) 
      pch <- as.integer(pch) 
    } 
    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_len(inset, 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) { 
      if (!is.null(fill)) 
       fill <- rep_len(fill, n.leg) 
      rect2(left = xt, top = yt + ybox/2, dx = xbox, dy = ybox, 
       col = fill, density = density, angle = angle, 
       border = border) 
     } 
     xt <- xt + dx.fill 
    } 
    if (plot && (has.pch || do.lines)) { 
     pt.COL <- rep_len(pt.col, n.leg) 
     line.COL <- rep_len(line.col, n.leg) 
    } 
    if (missing(lwd) || is.null(lwd)) 
     lwd <- par("lwd") 
    if (do.lines) { 
     if (missing(lty) || is.null(lty)) 
      lty <- 1 
     lty <- rep_len(lty, n.leg) 
     lwd <- rep_len(lwd, n.leg) 
     ok.l <- !is.na(lty) & (is.character(lty) | lty > 0) & 
      !is.na(lwd) 
     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 = line.COL[ok.l]) 
     xt <- xt + (seg.len + x.off) * xchar 
    } 
    if (has.pch) { 
     pch <- rep_len(pch, n.leg) 
     pt.bg <- rep_len(pt.bg, n.leg) 
     pt.cex <- rep_len(pt.cex, n.leg) 
     pt.lwd <- rep_len(pt.lwd, n.leg) 
     ok <- !is.na(pch) 
     if (!is.character(pch)) { 
      ok <- ok & (pch >= 0 | pch <= -32) 
     } 
     else { 
      ok <- ok & nzchar(pch) 
     } 
     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 = pt.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, font = text.font) 
    } 
    invisible(list(rect = list(w = w, h = h, left = left, top = top), 
     text = list(x = xt, y = yt))) 
} 

ed utilizzato nel seguente :

LEGEND(x="bottomleft", 
     legend=c("Red line, blue points","Green line, purple points"), 
     col=c("red","green"), 
     lwd=1, lty=c(1,2), pch=c(15,17)) 

LEGEND(x="bottomright", 
     legend=c("Red line, blue points","Green line, purple points"), 
     pt.col=c("blue","purple"), line.col=c("red","green"), 
     lwd=1, lty=c(1,2), pch=c(15,17)) 

Answer 1

Si può fare questo con 2 chiamate al legend, la 1a volta traccia le linee, poi il secondo trame di chiamata sopra la parte superiore con le linee invisibili, ma rappresenta i punti nei colori desiderati:

plot(0, type="n", xlim=c(0,5), ylim=c(0,5)) 
A <- matrix(c(c(1,2,3,4), c(2,1,2,4)), ncol=2) 
B <- matrix(c(c(1,2,3,4), c(1,3,3,2)), ncol=2) 
lines(A, col="red") 
points(A, col="blue", pch=15) 
lines(B, col="green") 
points(B, col="purple", pch=17) 

legend(x="topleft", 
     legend=c("Red line, blue points","Green line, purple points"), 
     col=c("red","green"), lwd=1, lty=c(1,2), 
     pch=c(NA,NA)) 

legend(x="topleft", 
     legend=c("Red line, blue points","Green line, purple points"), 
     col=c("blue","purple"), lwd=1, lty=c(0,0), 
     pch=c(15,17)) 

o per la seconda chiamata a legend si può fare qualcosa di simile (in modo da non avere 2 copie del testo su uno sopra l'altro):

legend(x="topleft", 
     legend=c("",""), 
     col=c("blue","purple"), lwd=1, lty=c(0,0), 
     pch=c(15,17), bty='n') 

Naturalmente questo solo allinea correttamente lavorando da sinistra. Se si desidera la trama in una delle curve adatte, salvare il valore restituito dalla prima chiamata a legend e utilizzarlo per il posizionamento nella seconda chiamata.