R devel - Jan 2003 - [R] proposal: lattice/levelplot: panel.catlevelplot

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

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

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