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

Wolfram Fischer - Z/I/M wolfram@fischer-zim.ch
Thu Jan 23 13:33:03 2003


Thanks for your comments/corrections.

An addition:

If levelplot is called with panel=panel.catlevelplot
the labels of the scales should be set to the names of
the categories by default, so that it is not necessary
any more to set (in the example of my proposal):

    scales=list(
          x = list( labels = levels( esoph$agegp ) )
        , y = list( labels = levels( esoph$alcgp ) )
        )

I do not yet have a code for that.

Wolfram

--- In reply to: ---
>Date:    21.01.03 21:27 (-0600)
>From:    Deepayan Sarkar <deepayan@stat.wisc.edu>
>To:      To Wolfram Fischer - Z/I/M
>Subject: Re: [Rd] [R] proposal: lattice/levelplot: panel.catlevelplot
>
> 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