# R/lattice.R In directlabels: Direct Labels for Multicolor Plots

#### Documented in defaultpf.trellisdirect.label.trellisuselegend.trellis

```uselegend.trellis <- function
### Add a legend to a trellis plot, for comparison.
(p,
### The trellis object.
...
### Ignored.
){
if(is.null(p\$legend))update(p,auto.key=TRUE)
else p
}

### Some lattice plot functions do some magic in the background to
### translate the data you give them into the data points that are
### plotted onscreen. We have to replicate this magic in native
### coordinate space before applying the Positioning Method in cm
### space. These functions accomplish this translation.
lattice.translators <- list(qqmath=function(d,distribution,f.value,qtype=7,...){
## Transformation function for 1d qqmath plots. This is a copy-paste
## from panel.qqmath. (total hack)
gapply(d,function(d,...){
x <- as.numeric(d\$x)
distribution <- if (is.function(distribution))
distribution
else if (is.character(distribution))
get(distribution)
else eval(distribution)
nobs <- sum(!is.na(x))
if (is.null(f.value))
data.frame(x = distribution(ppoints(nobs)), y = sort(x))
else data.frame(x = distribution(
if (is.numeric(f.value))f.value
else f.value(nobs)),
y = quantile(x,
if (is.numeric(f.value))f.value
else f.value(nobs),
names = FALSE, type = qtype, na.rm = TRUE))
})
},densityplot=gapply.fun({
dens <- density(d\$x,na.rm=TRUE)
data.frame(x=dens\$x,y=dens\$y)
}))

direct.label.trellis <- function
### Add direct labels to a grouped lattice plot. This works by parsing
### the trellis object returned by the high level plot function, and
### returning it with a new panel function that will plot direct
### labels using the specified method.
(p,
### The lattice plot (result of a call to a high-level lattice
### function).
method=NULL,
### Method for direct labeling as described in
debug=FALSE
### Show debug output?
){
#print(p\$panel)
old.panel <- if(is.character(p\$panel))get(p\$panel) else p\$panel
#print(old.panel)
lattice.fun.name <- paste(p\$call[[1]])
p\$panel <-
function(panel.groups=paste("panel.",lattice.fun.name,sep=""),...){
## TODO: redo this interface... to fix (1) lattice problem with
## custom specified color labels and (2) name clash with method
## from xYplot which I suppose should work.
panel.superpose.dl(panel.groups=panel.groups,
.panel.superpose=old.panel,
method=method,
...)
}
p\$legend <- NULL
update(p,debug=debug)
### The lattice plot.
}

panel.superpose.dl <- structure(function
### Call panel.superpose for the data points and then for the direct
### labels. This is a proper lattice panel function that behaves much
### like panel.superpose.
(x,
### Vector of x values.
y=NULL,
### Vector of y values.
subscripts,
### Subscripts of x,y,groups.
groups,
### Vector of group ids.
panel.groups,
### To be parsed for default labeling method, and passed to
### panel.superpose.
method=NULL,
### Positioning Method for direct labeling. NULL indicates to choose a
### Positioning Method based on the panel.groups function.
.panel.superpose=lattice::panel.superpose,
### The panel function to use for drawing data points.
type="p",
### Plot type, used for default method dispatch.
debug=FALSE,
### passed to dlgrob.
...
### passed to real panel function, and to translator.
){
rgs <- list(x=x,subscripts=subscripts,groups=groups,type=type,`...`=...)
if(!missing(y))rgs\$y <- y
## FIXME: this is a total hack:
tryCatch(do.call(".panel.superpose",c(rgs,panel.groups=panel.groups))
,error=function(e)do.call(".panel.superpose",rgs))
if(missing(panel.groups))panel.groups <- "panel.xyplot" #lattice default
subs <-
if(is.character(panel.groups))panel.groups else substitute(panel.groups)
lattice.fun.name <-
if(is.character(subs))sub("panel.","",subs) else ""
if(is.null(type))type <- "NULL"
if(is.null(method))method <- default.picker("trellis")
groups <- as.factor(groups)
groups <- groups[subscripts]
d <- data.frame(x,groups)
d\$y <- if(missing(y))NA else y
type <- type[type!="g"] ## printing the grid twice looks bad.
col.text <-
switch(type,p="superpose.symbol",l="superpose.line","superpose.line")
tpar <- lattice::trellis.par.get()
col.values <- if("col" %in% names(rgs)){
rgs\$col
}else{
tpar[[col.text]]\$col
}
key <- rep(col.values, length.out=nlevels(d\$groups))
names(key) <- levels(d\$groups)
## maybe eventually allow these to be specified in options()??
translator <- lattice.translators[[lattice.fun.name]]
if(!is.null(translator)){
d <- apply.method(translator,d,...)
}
d\$colour <- key[as.character(d\$groups)]
g <- dlgrob(d,method,debug=debug)
grid.draw(g)
},ex=function(){
loci <- data.frame(ppp=c(rbeta(800,10,10),rbeta(100,0.15,1),rbeta(100,1,0.15)),
type=factor(c(rep("NEU",800),rep("POS",100),rep("BAL",100))))
## 3 equivalent ways to make the same plot:
library(lattice)
print(direct.label( ## most user-friendly
densityplot(~ppp,loci,groups=type,n=500)
))
print(direct.label( ## exactly the same as above but with specific panel fns
densityplot(~ppp,loci,groups=type,n=500,
panel=lattice::panel.superpose,
panel.groups="panel.densityplot")
))
## using panel.superpose.dl as the panel function automatically adds
## direct labels
print(densityplot(~ppp,loci,groups=type,n=500,
panel=panel.superpose.dl,panel.groups="panel.densityplot"))

## Exploring custom panel and panel.groups functions
library(nlme)
## Say we want to use a simple linear model to explain rat body weight:
fit <- lm(weight~Time+Diet+Rat,BodyWeight)
bw <- BodyWeight
bw\$.fitted <- predict(fit,BodyWeight)
## lots of examples to come, all with these arguments:
ratxy <- function(...){
xyplot(weight~Time|Diet,bw,groups=Rat,type="l",layout=c(3,1),...)
}
## No custom panel functions:
##regular <- ratxy(par.settings=simpleTheme(col=c("red","black")))
regular <- ratxy()
print(regular) ## normal lattice plot
print(direct.label(regular)) ## with direct labels

## The direct label panel function panel.superpose.dl can be used to
## display direct labels as well:
print(ratxy(panel=panel.superpose.dl,panel.groups="panel.xyplot"))
print(ratxy(panel=function(...)
panel.superpose.dl(panel.groups="panel.xyplot",...)))

## Not very user-friendly, since default label placement is
## impossible, but these should work:
print(ratxy(panel=panel.superpose.dl,panel.groups=panel.xyplot,
method=first.points))
print(ratxy(panel=function(...)
panel.superpose.dl(panel.groups=panel.xyplot,...),
method=first.points))

## Custom panel.groups functions:
## This panel.groups function will display the model fits:
panel.model <- function(x,subscripts,col.line,...){
panel.xyplot(x=x,subscripts=subscripts,col.line=col.line,...)
llines(x,bw[subscripts,".fitted"],col=col.line,lty=2)
}
pg <- ratxy(panel=lattice::panel.superpose,panel.groups=panel.model)
print(pg)
## If you use panel.superpose.dl with a custom panel.groups function,
## you need to manually specify the Positioning Method, since the
## name of panel.groups is used to infer a default:
print(direct.label(pg,method="first.qp"))
print(ratxy(panel=panel.superpose.dl,panel.groups="panel.model",
method="first.qp"))

## Custom panel function that draws a box around values:
panel.line1 <- function(ps=lattice::panel.superpose){
function(y,...){
panel.abline(h=range(y))
ps(y=y,...)
}
}
custom <- ratxy(panel=panel.line1())
print(custom)
print(direct.label(custom))
## Alternate method, producing the same results, but using
## panel.superpose.dl in the panel function. This is useful for direct
## label plots where you use several datasets.
print(ratxy(panel=panel.line1(panel.superpose.dl),panel.groups="panel.xyplot"))

## Lattice plot with custom panel and panel.groups functions:
both <- ratxy(panel=panel.line1(),panel.groups="panel.model")
print(both)
print(direct.label(both,method="first.qp"))
print(ratxy(panel=panel.line1(panel.superpose.dl),
panel.groups=panel.model,method="first.qp"))
})

defaultpf.trellis <- function
### If no Positioning Method specified, choose a default using this
### function. The idea is that this is called with all the variables
### in the environment of panel.superpose.dl, and this can be
### user-customizable by setting the directlabels.defaultpf.lattice
### option to a function like this.
(lattice.fun.name,groups,type,...){
ldefault <- function(){
if(nlevels(groups)==2)"lines2" else "maxvar.qp"
}
lattice.fun.name <-
switch(lattice.fun.name,
qqmath="xyplot",
lattice.fun.name)
switch(lattice.fun.name,
dotplot=ldefault(),
xyplot=if("p"%in%type)"smart.grid" else ldefault(),
densityplot="top.bumptwice",
rug="rug.mean",
xyplot.zoo=ldefault(),
stop("No default direct label placement method for '",