[R] Multiple symbols per single line in a legend

[Jim Lemon]

On 01/13/2010 01:50 AM, Primoz PETERLIN wrote:
> Hello everybody,
>
> Is it possible to coax legend() into displaying more than one simbol per
> line in legend? I have a graph like the one attached to this mail; I would
> like to reorganize the legend in such a way that the duplicate text would be
> omitted, i.e., the first line would read<square>  <triangledown>  "increasing
> frequency" and the second one would read<circle>  <triangleup>  "decreasing
> frequency". Before resorting to box() and text() I would like to check
> whether some clever method already exists that would solve my problem. :)
>
Hi Primoz,
This request has been made before on the list, so I suppose it's time to 
get something together. Below is a first cut on a function to do this. 
If the user sends a list as the fill= argument, each one of the legend 
commands can have a few rectangles before it in different colors. The 
length of the fill= argument should be the same as the length of the 
legend= argument. If a list is passed as the pch= argument, the same 
thing happens with points. It is probably best to pass a corresponding 
list to the col= argument if the user wants different colored points. 
"legendg" stands for legend(grouped).

legendg<-function(x,y=NULL,legend,fill=NULL,col=par("col"),
  border="black",lty,lwd,pch=NULL,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=FALSE,
  trace=FALSE,plot=TRUE,ncol=1,horiz=FALSE,title=NULL,
  inset=0,xpd,title.col=text.col) {

  if(missing(legend) && !is.null(y)) {
   legend<-y
   y<-NULL
  }
  if(is.list(x)) {
   y<-x$y
   x<-x$x
  }
  if(!missing(xpd)) {
   oldxpd<-par("xpd")
   par(xpd=xpd)
  }
  legend.info<-legend(x=x,y=y,legend=legend,col=par("bg"),lty=1,
   bty=bty,bg=bg,box.lwd=box.lwd,box.lty=box.lty,
   box.col=par("fg"),pt.bg=NA,cex=1,pt.cex=pt.cex,pt.lwd=pt.lwd,
   xjust=xjust,yjust=yjust,x.intersp=x.intersp,y.intersp=y.intersp,
   adj=adj,text.width=text.width,text.col=text.col,merge=merge,
   trace=trace,plot=plot,ncol=ncol,horiz=horiz,title=title,
   inset=inset,title.col=title.col)
  if(!is.null(fill)) {
   rectheight<-strheight("Q")
   if(length(adj) > 1) yadj<-adj[2] else yadj<-0.5
   for(nel in 1:length(fill)) {
    nrect<-length(fill[[nel]])
    rectspace<-(legend.info$text$x[nel]-legend.info$rect$left)
    lefts<-cumsum(c(legend.info$rect$left+rectspace*0.1,
     rep(0.8*rectspace/nrect,nrect-1)))
    rights<-lefts+0.7*rectspace/nrect
    bottoms<-rep(legend.info$text$y[nel]-yadj*rectheight,nrect)
    rect(lefts,bottoms,rights,bottoms+rectheight,col=fill[[nel]])
   }
  }
  if(!is.null(pch)) {
   if(!is.list(col)) {
    mycol<-pch
    if(length(col) < length(mycol[[1]])) 
col<-rep(col,length.out=length(mycol[[1]]))
    for(nel in 1:length(col))
     mycol[[nel]]<-rep(col,length.out=length(mycol[[nel]]))
   }
   else mycol<-col
   for(nel in 1:length(pch)) {
    midspace<-(legend.info$rect$left+legend.info$text$x[nel])/2
    npch<-length(pch[[nel]])
    pchwidth<-strwidth("O")
    xpos<-cumsum(c(midspace-npch*0.5*pchwidth,rep(pchwidth,npch-1)))
    ypos<-rep(legend.info$text$y[nel],npch)
    points(xpos,ypos,pch=pch[[nel]],col=mycol[[nel]])
   }
  }
  if(!missing(xpd)) par(xpd=oldxpd)
  invisible(legend.info)
}

legendg(locator(1),c("one","two","three"),fill=list(2:3,3:5,6:7))
legendg(locator(1),c("one","two","three"),pch=list(1:2,3:5,6:7),
  col=list(2:3,3:5,6:7))

Give it a whacking folks and I'll put the function into the next version 
of plotrix if it survives. Also send any requests for features that I 
have neglected.

Jim