[R] Adding textbox to multiple panels in lattice

[Paul Murrell]

Hi

Here's a panel function that does what I think you want (NOTE that you 
need to load 'grid' for this to work) ...

library(grid)

panel.tpop <- function(x,y,...){
     panel.grid(h=length(agegrs),v=5,col="lightgrey",lty=1)
     ls1 <<- list(...)
     y <<- y
     iFrame <- iEduDat[ls1$subscripts,]
     iSex <- with(iFrame,unique(sex))
     if (iSex=="Female"){
         panel.pyramid(x,y,...)
         iCc <- with(iFrame,unique(cc))
         iYr <- with(iFrame,unique(yr))
         totpop <- round(sum(abs(subset(iEduDat,cc==iCc &
                                        yr==iYr,
                                        select=value)))/
                         1000,2)
         LAB <- paste("Pop = ",totpop," Mio",sep="")
         xr <- max(abs(subset(iEduDat,cc==iCc,
                              select=value)))
         xr <- xr - xr * 0.005

         # Make the text label
         tg <- textGrob(LAB, x=unit(xr, "native") - unit(1, "mm"),
                        just="right",
                        y=unit(max(y) - 2, "native"),
                        gp=gpar(cex=0.7))
         # Draw box big enough to fit the text
         grid.rect(x=unit(xr, "native"), just="right",
                   y=unit(max(y) - 2, "native"),
                   width=grobWidth(tg) + unit(2, "mm"),
                   height=unit(1, "lines"),
                   gp=gpar(fill="white"))
         # Draw the text
         grid.draw(tg)
     } else {panel.pyramid(x,y,...)}
}

Paul

On 24/09/12 21:35, Erich Strießnig wrote:
> Dear R-users,
>
> I am trying to add some text in a textbox to all panels in the following
> example file. Using the panel-function, I can add a white rectangle with
> panel.rect but then I have to fit in the text into the box by hand and it
> will not automatically be centered. Does anyone know how to add the text
> centered with a white box around it automatically? Is there something like
> panel.textbox for lattice?
>
> Thanks in advance and here is the example
> Erich
>
>
> install.packages("Giza")
> library(Giza)
>
> panel.tpop <- function(x,y,...){
>                        panel.grid(h=length(agegrs),v=5,col="lightgrey",lty=1)
>                        ls1 <<- list(...)
>                        y <<- y
>                        iFrame <- iEduDat[ls1$subscripts,]
>                          iSex <- with(iFrame,unique(sex))
>                          if (iSex=="Female"){
>                              panel.pyramid(x,y,...)
>                              iCc <- with(iFrame,unique(cc))
>                              iYr <- with(iFrame,unique(yr))
>                              totpop <- round(sum(abs(subset(iEduDat,cc==iCc
> & yr==iYr,select=value)))/1000,2)
>                              LAB <- paste("Pop = ",totpop," Mio",sep="")
>                              xr <-
> max(abs(subset(iEduDat,cc==iCc,select=value)))
>                              xr <- xr - xr * 0.005
>
> panel.text(x=xr,y=max(y)-2,lab=LAB,cex=0.7,pos=2)
>                            } else {panel.pyramid(x,y,...)}
>                       }
>
> data(EduDat)
> data(dictionary)
>
> # select the desired year, country, and education-scenario from EduDat
> Years <- c(2010,2030,2050)
> Countries <- c("Pakistan","Bangladesh","Indonesia")
> Scenarios <- c("GET")
> # the male-column needs to be flipped
> iEduDat <- subset(EduDat,match(cc,getcode(Countries,dictionary)) &
> match(yr,Years) & match(scen2,Scenarios))
> iEduDat$value[iEduDat$sex == "Male"] <- (-1) * iEduDat$value[iEduDat$sex ==
> "Male"]
>
> agegrs <- paste(seq(15,100,5),seq(19,104,5),sep="-")
> agegrs[length(agegrs)] <- "100+"
>
> lattice.options(axis.padding = list(numeric=0))
> x <- pyramidlattice(agegr ~ value| factor(sex,levels=c("Male","Female")) *
>
>   factor(cc,levels=getcode(Countries,dictionary),labels=Countries) *
>                                     factor(yr,levels=Years,labels=Years),
>
>   groups=variable,data=iEduDat,layout=c(length(Countries)*2,length(Years)),
>             type="l",lwd=1,xlab="Population",ylab="Age",main="Population by
> Highest Level of Education",
>             strip=TRUE,par.settings =
> simpleTheme(lwd=3,col=colors()[c(35,76,613,28)]),box.width=1,
>
>   scales=list(alternating=3,tick.number=5,relation="same",y=list(at=1:length(4:21),labels=agegrs)),
>
>   auto.key=list(text=c("No-edu","Primary","Secondary","Tertiary"),reverse.row=TRUE,
>
>   points=FALSE,rectangles=TRUE,space="right",columns=1,border=FALSE,
>
>   title="ED-Level",cex.title=1.1,lines.title=2.5,padding.text=1,background="white"),
>             prepanel=prepanel.default.bwplot2,panel=panel.tpop)
> useOuterStrips2(x)
>
> 	[[alternative HTML version deleted]]
>
> ______________________________________________
> R-help at r-project.org mailing list
> https://stat.ethz.ch/mailman/listinfo/r-help
> PLEASE do read the posting guide http://www.R-project.org/posting-guide.html
> and provide commented, minimal, self-contained, reproducible code.
>

-- 
Dr Paul Murrell
Department of Statistics
The University of Auckland
Private Bag 92019
Auckland
New Zealand
64 9 3737599 x85392
paul at stat.auckland.ac.nz
http://www.stat.auckland.ac.nz/~paul/