Изменение цвета полосы в решетчатом многоканальном графике с 2 (или, возможно, более) факторами

Question

Я проверил довольно подробно через форум и в Интернете, но я не мог найти никого, кто уже представил мое дело, так что вот вам вопрос :

моя цель: Как я могу расширить представленный пример here в случае, если у меня есть несколько факторов кондиционирования?

Я пробовал несколько способов изменить переменную which.panel функции strip.default, но я не мог выйти из своей проблемы.

Это код, я использую в данный момент (с комментариями):

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)) 

Как вы можете видеть, первый ряд участков правильно: текст первой полосы является « «(1-й ХПК), показываются недели (SPEC), а цвет соответствует, если PM находится выше или ниже PM.BDG на последнюю дату графика

Напротив, 2-я строка участков просто повторяет то же самое схема первого ряда (как видно из того факта, что ХПК всегда «А», а второй цвет bg во второй строке является зеленым, когда линия PM в красном цвете явно значительно ниже линии PM.BDG в черном цвете).

Хотя я хотел бы сохранить свой код, я уверен, что моя цель может быть достигнута с другой стратегией. Если вы сможете найти лучший способ использования моего фреймворка данных, я буду рад изучить этот код и посмотреть, работает ли он с моими данными.

Answer 1

Проблема заключается в совпадении данных текущей панели с данными listaPM. Поскольку вы выполняете разные настройки в каждом из вызовов, трудно использовать which.panel() для соответствия наборам данных.

Существует undocumented feature, который позволяет получить имена переменных условных обозначений, чтобы сделать их более надежными. Вот как вы могли бы использовать его в своем случае.

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") 
} 

При запуске с остальной частью кода, он производит этот участок