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

[Wolfram Fischer - Z/I/M]

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
        , ...
    ))
}

#------ -------------------------------------------------------------------