changing strip's color in lattice multipanel plot with 2 (or possibly more) factors

Question

I've checked quite extensively through the forum and on the web but I couldn't find anyone that already presented my case, so here you are the question:

my goal: how can I extend the example presented here in case I have more than one conditioning factor?

I've tried several ways to modify the which.panel variable of strip.default function, but I couldn't come out of my problem.

This is the code I'm using at the moment (with comments):

if (!require("plyr","lattice")) install.packages("plyr","lattice")
require("plyr")
require("lattice")

# dataframe structure (8 obs. of 6 variables)
data2 <- structure(list(
  COD = structure(c(1L, 1L, 1L, 1L, 2L, 2L,2L, 2L),  
                  .Label = c("A", "B"), class = "factor"),
  SPEC = structure(c(1L, 1L, 2L, 2L, 1L, 1L, 2L, 2L), 
                   .Label = c("15/25-(15/06)", "15/26-(22/06)"), class = "factor"), 
  DATE = structure(c(16589, 16590, 16589, 16590, 16589, 16590, 16589, 16590), class = "Date"), 
  PM.BDG = c(1111.25, 1111.25, 1141.29, 1141.29, 671.26, 671.26, 707.99, 707.99), 
  PM = c(1033.14, 1038.4, 1181.48, 1181.48, 616.39, 616.39, 641.55, 641.55), 
  DELTA.PM = c(-78.12, -72.85, 40.19, 40.19, -54.87, -54.87, -66.44, -66.44)), 
  .Names = c("COD", "SPEC", "DATE", "PM.BDG", "PM", "DELTA.PM"), 
  row.names = c(NA, 8L), class = "data.frame")

# create a dataframe with a vector of colors 
# based on the value of DELTA.PM for the last 
# date available for each combination of COD and SPEC.
# Each color will be used for a specific panel, and it will
# forestgreen if DELTA.PM is higher than zero, red otherwise.
listaPM <- ddply(data2, .(COD,SPEC), summarize, ifelse(DELTA.PM[DATE=="2015-06-04"]<0, "red", "forestgreen"))
names(listaPM) <- c("COD","SPEC","COLOR")

# set a personalized strip, with bg color based on listaPM$COLOR 
# and text based on listaPM$COD and listaPM$SPEC 
myStripStylePM <- function(which.panel, factor.levels, ...) {
  panel.rect(0, 0, 1, 1,
             col = listaPM[which.panel,3],
             border = 1)
  panel.text(x = 0.5, y = 0.5,
             font=2,
             lab = paste(listaPM[which.panel,1],listaPM[which.panel,2], sep=" - "),
             col = "white")}

# prepare a xyplot function to plot that will be used later with dlply.
# Here I want to plot the values of PM.BDG and PM over time (DATE), 
# conditioning them on the SPEC (week) and COD (code) factors.
graficoPM <- function(df) {
  xyplot (PM.BDG + PM ~ DATE | SPEC + COD,
          data=df,
          type=c("l","g"),
          col=c("black", "red"),
          abline=c(h=0,v=0),
          strip = myStripStylePM
  )}

# create a trellis object that has a list of plots, 
# based on different COD (codes)
grafico.PM  <- dlply(data2, .(data2$COD), graficoPM)

# graphic output, 1st row should be COD "A", 
# 2nd row should be COD "B", each panel is a different SPEC (week)
par(mfrow=c(2,1))
print(grafico.PM[[1]], position=c(0,0.5,1,1), more=TRUE)
print(grafico.PM[[2]], position=c(0,0,1,0.5))

As you can see, the first row of plots is correct: text of the first strip is "A" (1st COD), the weeks (SPEC) are shown and the color represents if PM is above or below PM.BDG on the last date of the plot

On the contrary, the 2nd row of plots just repeats the same scheme of the first row (as it can be seen by the fact that COD is Always "A" and 2nd strip's bg color in the 2nd row is green, when the line of PM in red is clearly well below the PM.BDG line in black).

Although I'd like to keep my code, I'm pretty sure my goal could be achieved with a different strategy. If you can find a better way to use my dataframe, I'll be happy to study the code and see if it works with my data.

Answer 1

The problem is match up the current panel data to the listaPM data. Because you are doing different sub-setting in each of the calls, it's difficult to use which.panel() to match up the data sets.

There is an undocumented feature which allows you to get the conditioning variable names to make the matching more robust. Here's how you would use it in your case.

myStripStylePM <- function(which.panel, factor.levels, ...) {
  cp <- dimnames(trellis.last.object())
  ci <- arrayInd(packet.number(), .dim=sapply(cp, length))
  cv <- mapply(function(a,b) a[b], cp, as.vector(ci))

  idx<-which(apply(mapply(function(n, v) listaPM[, n] == v, names(cv), cv),1,all))
  stopifnot(length(idx)==1)

  panel.rect(0, 0, 1, 1,
             col = listaPM[idx,3],
             border = 1)
  panel.text(x = 0.5, y = 0.5,
             font=2,
             lab = paste(listaPM[idx,1],listaPM[idx,2], sep=" - "),
             col = "white")
}

When run with the rest of your code, it produces this plot