I suggest to add a panel function to levelplot (or perhaps
to an other 3d lattice function) which is able to translate
the z values into the size of the rectangles.
It could be used to display categorical data.
I append the proposed code and two examples:
- panel.catlevelplot()
- example1.catlevelplot.esoph()
- example2.catlevelplot.esoph()
Wolfram Fischer
#------ CODE --------------------------------------------------------------
panel.catlevelplot <- function (x, y, z, wx, wy, zcol, col.regions, subscripts
, ...
, z.factor.min = 0.02 # factor for z range expansion
# -> little cells become visible
, col.x = NULL # colors for categories in x direction
, col.y = NULL # colors for categories in y direction
, prop.width= TRUE # calculate width of cells proportionally to z position
, prop.height= TRUE # calculate height of cells proportionally to z position
, col.border.cells = NULL # color of borders of levelplot cells
, lwd.border.cells = NULL # linewidth of borders of levelplot cells
){
axis.line <- trellis.par.get('axis.line')
if( is.null( col.border.cells ) ) col.border.cells = axis.line$col
if( is.null( lwd.border.cells ) ) lwd.border.cells = axis.line$lwd
x <- as.numeric( x )
y <- as.numeric( y )
z <- as.numeric( z )
# <--- It would be better to do the following calculations
# of z.x.factor and z.y.factor in the main function (levelplot).
z.min <- min( z, na.rm=TRUE )
z.range <- max( z, na.rm=TRUE ) - z.min
z.factor <- ( z - z.min + z.range * z.factor.min ) /
( z.range * ( 1 + z.factor.min ) )
z.x.factor <- if( prop.width ) z.factor else rep( 1, length(z) )
z.y.factor <- if( prop.height ) z.factor else rep( 1, length(z) )
# --->
fe.grid.rect <- function( sel, fill ){
grid.rect(
x = x[subscripts][sel]
, y = y[subscripts][sel]
, width = wx[subscripts][sel] *
z.x.factor[subscripts][sel]
, height = wy[subscripts][sel] *
z.y.factor[subscripts][sel]
, default.units = "native"
, gp = gpar(
fill = fill
, col = col.border.cells
, lwd = lwd.border.cells
)
)
}
if( any(subscripts) ){
if( ! is.null( col.x ) ){
x.levels <- unique( x )
col.x <- rep( col.x, length = length(x.levels) )
for( i.col in seq( along = x.levels ) ){
fe.grid.rect(
sel = ( x[subscripts] == viq.x.levels[i.col] )
, fill = col.x[i.col]
)
}
}else if( ! is.null( col.y ) ){
y.levels <- unique( y )
col.y <- rep( col.y, length = length(y.levels) )
for( i.col in seq( along = y.levels ) ){
fe.grid.rect(
sel = ( y[subscripts] == y.levels[i.col] )
, fill = col.y[i.col]
)
}
}else{
for( i.col in seq( along = col.regions ) ){
fe.grid.rect(
sel = ( zcol[subscripts] == i.col )
, fill = col.regions[i.col]
)
}
}
}
}
#------ EXAMPLE -----------------------------------------------------------
data(esoph)
library(lattice)
example1.catlevelplot.esoph <- function( ... ){
ncolors <- nlevels( esoph$alcgp )
print( levelplot( ncases ~ agegp * alcgp | tobgp, data=esoph
, main = 'esoph data set'
, sub = 'tobgp'
, cuts = ncolors
, layout = c( 4, 4 )
, scales=list(
x = list( labels = levels( esoph$agegp ), rot=90, alternating=F )
, y = list( labels = levels( esoph$alcgp ) )
)
, panel = panel.catlevelplot
, colorkey = NULL
, col.y = rainbow(ncolors)
# , prop.height = F
, ...
))
}
example2.catlevelplot.esoph <- function( ... ){
cuts <- 15
print( levelplot( ncases ~ agegp * alcgp | tobgp, data=esoph
, main = 'esoph data set'
, sub = 'tobgp'
, cuts = cuts
, layout = c( 4, 4 )
, scales=list(
x = list( labels = levels( esoph$agegp ), rot=90, alternating=F )
, y = list( labels = levels( esoph$alcgp ) )
)
, panel = panel.catlevelplot
, col.regions = rev( heat.colors(cuts+1) )
, col.border.cells = trellis.par.get('background')$col
, lwd.border.cells = 3
, prop.height = F
, prop.width = F
, ...
))
}
#------ -------------------------------------------------------------------
______________________________________________
[EMAIL PROTECTED] mailing list
http://www.stat.math.ethz.ch/mailman/listinfo/r-devel
