On Tuesday 21 January 2003 08:49 am, Wolfram Fischer - Z/I/M wrote:
> 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.
Cool.
> It could be used to display categorical data.
>
> I append the proposed code and two examples:
> - panel.catlevelplot()
> - example1.catlevelplot.esoph()
> - example2.catlevelplot.esoph()
The second example gives an error for me. Do you have the latest grid
installed ? I think changing fe.grid.rect below would solve it.
> 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 ){
if (any(sel)) ## ADDED
> 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
______________________________________________
[EMAIL PROTECTED] mailing list
http://www.stat.math.ethz.ch/mailman/listinfo/r-devel
