[Rd] [R] proposal: lattice/levelplot: panel.catlevelplot

[Deepayan Sarkar]

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
>         , ...
>     ))
> }
>
> #------ -------------------------------------------------------------------
>
> ______________________________________________
> R-devel@stat.math.ethz.ch mailing list
> http://www.stat.math.ethz.ch/mailman/listinfo/r-devel