[R] Using key.opts in Ecdf/labcurve (Hmisc package)

[Frank E Harrell Jr]

Richard.Cotton at hsl.gov.uk wrote:
> I'm presumably missing something very obvious, but how does one use the 
> key.opts argument in labcurve (via Ecdf)?
> 
> In this example, I want the key to be big and have a blue background, but 
> it isn't and doesn't.
> 
> ch <- rnorm(1000, 200, 40)
> sex <- factor(sample(c('female','male'), 1000, TRUE))
> Ecdf(~ch, group=sex, label.curves=list(keys=c("f", "m"), 
> key.opts=list(cex=3, background="blue")))
> 
> Regards,
> Richie.
> 
> Mathematical Sciences Unit
> HSL
> 
> 
> ------------------------------------------------------------------------
> ATTENTION:
> 
> This message contains privileged and confidential inform...{{dropped:20}}
> 
> ______________________________________________
> R-help at r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-help
> PLEASE do read the posting guide http://www.R-project.org/posting-guide.html
> and provide commented, minimal, self-contained, reproducible code.
> 

Sorry about the error.  Until the next release of Hmisc please source in 
the following function override.  -Frank

putKey <- function(z, labels, type=NULL,
                    pch=NULL, lty=NULL, lwd=NULL,
                    cex=par('cex'), col=rep(par('col'),nc),
                    transparent=TRUE, plot=TRUE, key.opts=NULL,
                    grid=FALSE)
{
   if(grid)
     {
       require('grid')
       require('lattice')  # use draw.key in lattice
     }

   if(!.R. && !existsFunction('key'))
     stop('must do library(trellis) to access key() function')

   nc <- length(labels)
   if(!length(pch)) pch <- rep(NA, nc)

   if(!length(lty)) lty <- rep(NA, nc)

   if(!length(lwd)) lwd <- rep(NA, nc)

   pp <- !is.na(pch)
   lp <- !is.na(lty) | !is.na(lwd)
   lwd <- ifelse(is.na(lwd), par('lwd'), lwd)

   if(!length(type)) type <- ifelse(!(pp | lp), 'n',
                                    ifelse(pp & lp, 'b',
                                           ifelse(pp, 'p', 'l')))

   pch <- ifelse(is.na(pch) & type!='p' & type!='b',
                 if(.R.) NA else 0,
                 pch)

   lty <- ifelse(is.na(lty) & type=='p',
                 if(.R.) NA else 1,
                 lty)

   lwd <- ifelse(is.na(lwd) & type=='p', 1, lwd)
   cex <- ifelse(is.na(cex) & type!='p' & type!='b', 1, cex)

   if(!.R. && any(is.na(pch)))
     stop("pch can not be NA for type='p' or 'b'")

   if(!.R. && any(is.na(lty)))
     stop("lty can not be NA for type='l' or 'b'")

   if(any(is.na(lwd)))
     stop("lwd can not be NA for type='l' or 'b'")

   if(any(is.na(cex)))
     stop("cex can not be NA for type='p' or 'b'")

   m <- list()
   m[[1]] <- as.name(if(grid) 'draw.key'
   else if(.R.) 'rlegend' else 'key')

   if(!grid)
     {
       m$x <- z[[1]]; m$y <- z[[2]]
     }

   if(.R.)
     {
       if(grid)
         {
           w <- list(text=list(labels, col=col))
           if(!(all(is.na(lty)) & all(is.na(lwd))))
             {
               lns <- list()
               if(!all(is.na(lty)))
                 lns$lty <- lty

               if(!all(is.na(lwd)))
                 lns$lwd <- lwd

               lns$col <- col
               w$lines <- lns
             }

           if(!all(is.na(pch)))
             w$points <- list(pch=pch, col=col)

           m$key <- c(w, key.opts)
           m$draw <- plot
           if(plot)
             m$vp <- viewport(x=unit(z[[1]], 'native'),
                              y=unit(z[[2]], 'native'))

           z <- eval(as.call(m))
           size <-
             if(plot) c(NA,NA)
         else
           c(convertUnit(grobWidth(z), 'native', 'x', 'location', 'x',
                         'dimension', valueOnly=TRUE)[1],
             convertUnit(grobHeight(z), 'native', 'y', 'location', 'y',
                         'dimension', valueOnly=TRUE)[1])

           return(invisible(size))
         }
       else
         {
           m$legend <- labels
           m$xjust <- m$yjust <- .5
           m$plot <- plot
           m$col <- col
           m$cex <- cex
           if(!all(is.na(lty))) m$lty <- lty

           if(!all(is.na(lwd))) m$lwd <- lwd

           if(!all(is.na(pch))) m$pch <- pch

           if(length(key.opts)) m[names(key.opts)] <- key.opts

           w <- eval(as.call(m))$rect
           return(invisible(c(w$w[1], w$h[1])))
         }
     }

   m$transparent <- transparent
   m$corner <- c(.5,.5)
   m$plot   <- plot
   m$type   <- type

   if(!plot) labels <- substring(labels, 1, 10)

   ## key gets length wrong for long labels
   m$text <- list(labels, col=col)
   if(all(type=='p'))
     m$points <- list(pch=pch, cex=cex, col=col)
   else
     m$lines <-
       if(any(type!='l'))
         list(lty=lty, col=col, lwd=lwd, pch=pch, cex=cex)
       else
         list(lty=lty, col=col, lwd=lwd)

   if(length(key.opts))
     m[names(key.opts)] <- key.opts

   invisible(eval(as.call(m)))  ## execute key(....)
}