Oops, forgot the attachment.
On Friday 05 September 2003 12:45 pm, Deepayan Sarkar wrote:
> The prepanel function returns separate limits for x and y axes. This does
> not translate to splom, since each limit is used on both the x and y axes.
> However, it is natural to add a new optional argument, which would be a
> function that would decide on the limits for each variable in the data
> frame, to be used as both x and y limits. This feature was missing till
> now, but I have added something for the next release (source() the attached
> file to use it), which will allow you to do:
>
> splom(log(1+DF),
> prepanel.limits = function(x) c(0, 15),
> panel = function(x, y, ... ) {
> panel.xyplot(x, y, ...)
> })
-------------- next part --------------
panel.pairs <-
function(z, panel = "panel.splom", groups = NULL,
panel.subscripts,
subscripts,
pscales = 5,
panel.number = 0, ## should always be supplied
prepanel.limits = function(x) extend.limits(range(as.numeric(x), na.rm = TRUE)),
...)
{
panel <-
if (is.function(panel)) panel
else if (is.character(panel)) get(panel)
else eval(panel)
axis.line <- trellis.par.get("axis.line")
axis.text <- trellis.par.get("axis.text")
n.var <- ncol(z)
if(n.var>0) {
## there must be a better way to do the foll:
lim <- list(1:n.var)
for(i in 1:n.var) {
lim[[i]] <- prepanel.limits(z[,i])
}
## should be further complicated by allowing for customization by
## prepanel functions --- prepanel(z[i], z[j]) etc
}
## maybe (ideally) this should be affected by scales
draw <- is.list(pscales) || (is.numeric(pscales) && pscales!=0) # whether axes to be drawn
splom.layout <- grid.layout(nrow=n.var, ncol=n.var)
if (n.var > 0 && any(subscripts)) {
push.viewport(viewport(layout=splom.layout))
for(i in 1:n.var)
for(j in 1:n.var)
{
push.viewport(viewport(layout.pos.row = n.var-i+1,
layout.pos.col = j,
clip = TRUE,
##gp = gpar(fontsize = fontsize.small),
xscale = lim[[j]],
yscale = lim[[i]]))
if(i == j)
{
if (!is.null(colnames(z)))
grid.text(colnames(z)[i])
##gp = gpar(fontsize = 10))
if (draw) {
## plot axes
if (is.factor(z[,i])) {
axls <- 1:nlevels(z[,i])
nal <- length(axls)/2+.5
for(tt in seq(along=axls)) {
if(tt <= nal) {
grid.lines(y = unit(rep(axls[tt],2), "native"),
x = unit(c(1,1),"npc") - unit(c(0,.25), "lines"),
gp = gpar(col = axis.line$col))
grid.text(label = levels(z[,i])[tt],
x = unit(1,"npc") - unit(.5, "lines"),
y = unit(axls[tt], "native"),
just = c("right", "centre"))
grid.lines(x = unit(rep(axls[tt],2), "native"),
y = unit(c(0,.25), "lines"),
gp = gpar(col = axis.line$col))
grid.text(label = levels(z[,i])[tt],
rot = 90,
y = unit(0.5, "lines"),
x = unit(axls[tt], "native"),
just = c("left", "centre"))
}
if(tt >=nal) {
grid.lines(y = unit(rep(axls[tt],2), "native"),
x = unit(c(0,0.25), "lines"),
gp = gpar(col = axis.line$col))
grid.text(label = levels(z[,i])[tt],
x = unit(0.5, "lines"),
y = unit(axls[tt], "native"),
just = c("left", "centre"))
grid.lines(x = unit(rep(axls[tt],2), "native"),
y = unit(c(1,1),"npc") - unit(c(0,.25), "lines"),
gp = gpar(col = axis.line$col))
grid.text(label = levels(z[,i])[tt], rot = 90,
y = unit(1,"npc") - unit(.5, "lines"),
x = unit(axls[tt], "native"),
just = c("right", "centre"))
}
}
}
else {
axls <-
if (is.list(pscales) && !is.null(pscales[[i]]$at))
pscales[[i]]$at
else
lpretty(lim[[i]], n = pscales)
labels <-
if (is.list(pscales) && !is.null(pscales[[i]]$lab))
pscales[[i]]$lab
## should be rendered like factors ?
else
as.character(axls)
axid <- axls>lim[[i]][1] & axls <lim[[i]][2]
axls <- axls[axid]
labels <- labels[axid]
nal <- length(axls)/2+.5
for(tt in seq(along=axls)) {
if(tt <= nal) {
grid.lines(y = unit(rep(axls[tt],2), "native"),
x = unit(c(1,1),"npc") - unit(c(0,.25), "lines"),
gp = gpar(col = axis.line$col))
grid.text(label = labels[tt],
x = unit(1,"npc") - unit(.5, "lines"),
y = unit(axls[tt], "native"),
just = c("right", "centre"))
grid.lines(x = unit(rep(axls[tt],2), "native"),
y = unit(c(0,.25), "lines"),
gp = gpar(col = axis.line$col))
grid.text(label = labels[tt],
y = unit(0.5, "lines"),
x = unit(axls[tt], "native"),
just = c("centre", "bottom"))
}
if(tt >=nal) {
grid.lines(y = unit(rep(axls[tt],2), "native"),
x = unit(c(0,0.25), "lines"),
gp = gpar(col = axis.line$col))
grid.text(label = labels[tt],
x = unit(0.5, "lines"),
y = unit(axls[tt], "native"),
just = c("left", "centre"))
grid.lines(x = unit(rep(axls[tt],2), "native"),
y = unit(c(1,1),"npc") - unit(c(0,.25), "lines"),
gp = gpar(col = axis.line$col))
grid.text(label = labels[tt],
y = unit(1,"npc") - unit(.5, "lines"),
x = unit(axls[tt], "native"),
just = c("centre", "top"))
}
}
}
}
grid.rect()
}
else
{
pargs <-
if (!panel.subscripts)
c(list(x = as.numeric(z[subscripts, j]),
y = as.numeric(z[subscripts, i]),
panel.number = panel.number),
list(...))
else
c(list(x = as.numeric(z[subscripts, j]),
y = as.numeric(z[subscripts, i]),
groups = groups,
subscripts = subscripts,
panel.number = panel.number),
list(...))
if (!("..." %in% names(formals(panel))))
pargs <- pargs[names(formals(panel))]
do.call("panel", pargs)
grid.rect()
}
pop.viewport()
}
pop.viewport()
}
}