## modified panel.pairs to allow different colours in different 
## subpanels. Doesn't work if data includes factors.
## overrides 'groups' colouring.

mypanel.pairs <-
function (z, 
    panel = lattice.getOption("panel.splom"), 
    lower.panel = panel, 
    upper.panel = panel, 
    diag.panel = "diag.panel.splom", 
    as.matrix = FALSE, 
    groups = NULL, 
    panel.subscripts, 
    subscripts, 
    pscales = 5, 
    clrmat, ## added argument: matrix of colours, one for each subpanel (matrix includes diags, but these colours are not used)
    prepanel.limits = function(x) if (is.factor(x)) levels(x) else range(as.numeric(x), finite = TRUE), 
    varname.col = add.text$col, 
    varname.cex = add.text$cex, 
    varname.font = add.text$font, 
    varname.fontfamily = add.text$fontfamily, 
    varname.fontface = add.text$fontface, 
    axis.text.col = axis.text$col, 
    axis.text.cex = axis.text$cex, 
    axis.text.font = axis.text$font, 
    axis.text.fontfamily = axis.text$fontfamily, 
    axis.text.fontface = axis.text$fontface, 
    axis.line.col = axis.line$col, 
    axis.line.lty = axis.line$lty, 
    axis.line.lwd = axis.line$lwd, 
    axis.line.alpha = axis.line$alpha, 
    axis.line.tck = 1, ...) 
{
    lower.panel <- if (is.function(lower.panel)) 
        lower.panel
    else if (is.character(lower.panel)) 
        get(lower.panel)
    else eval(lower.panel)
    upper.panel <- if (is.function(upper.panel)) 
        upper.panel
    else if (is.character(upper.panel)) 
        get(upper.panel)
    else eval(upper.panel)
    diag.panel <- if (is.function(diag.panel)) 
        diag.panel
    else if (is.character(diag.panel)) 
        get(diag.panel)
    else eval(diag.panel)
    add.text <- trellis.par.get("add.text")
    axis.line <- trellis.par.get("axis.line")
    axis.text <- trellis.par.get("axis.text")
    n.var <- ncol(z)
    if (n.var == 0) 
        return()
    lim <- vector("list", length = n.var)
    for (i in seq_len(n.var)) 
      lim[[i]] <- if (is.list(pscales) && !is.null(pscales[[i]]$lim)) 
                     pscales[[i]]$lim
                  else prepanel.limits(z[, i])
    if (length(subscripts)) {
        draw <- is.list(pscales) || (is.numeric(pscales) && pscales != 0)
        splom.layout <- grid.layout(nrow = n.var, ncol = n.var)
        pushViewport(viewport(layout = splom.layout, name = "pairs"))
        for (i in 1:n.var) for (j in 1:n.var) {
            if (as.matrix) 
                pushViewport(viewport(layout.pos.row = i, layout.pos.col = j, 
                  name = paste("subpanel", j, i, sep = "."), 
                  clip = trellis.par.get("clip")$panel, 
                  xscale = if (is.character(lim[[j]])) 
                              c(0, length(lim[[j]]) + 1)
                           else lim[[j]], 
                  yscale = if (is.character(lim[[i]])) 
                              c(0, length(lim[[i]]) + 1)
                           else lim[[i]]))
            else pushViewport(viewport(layout.pos.row = n.var - i + 1, layout.pos.col = j, 
                   name = paste("subpanel", j, i, sep = "."), 
                   clip = trellis.par.get("clip")$panel, 
                   xscale = if (is.character(lim[[j]])) 
                               c(0, length(lim[[j]]) + 1)
                            else lim[[j]], 
                   yscale = if (is.character(lim[[i]])) 
                               c(0, length(lim[[i]]) + 1)
                            else lim[[i]]))
            if (i == j) {
                axls <- if (is.list(pscales) && !is.null(pscales[[i]]$at)) 
                  pscales[[i]]$at
                else if (is.character(lim[[i]])) 
                  seq_along(lim[[i]])
                else pretty(lim[[i]], n = if (is.numeric(pscales)) 
                  pscales
                else 5)
                labels <- if (is.list(pscales) && !is.null(pscales[[i]]$lab)) 
                  pscales[[i]]$lab
                else if (is.character(lim[[i]])) 
                  lim[[i]]
                else NULL
                if (is.numeric(lim[[i]])) {
                  axlims <- range(lim[[i]])
                  axid <- axls > axlims[1] & axls < axlims[2]
                  axls <- axls[axid]
                  labels <- labels[axid]
                }
                diag.panel(x = z[subscripts, j], varname = colnames(z)[i], 
                  limits = lim[[i]], at = axls, lab = labels, 
                  draw = draw, varname.col = varname.col, varname.cex = varname.cex, 
                  varname.font = varname.font, varname.fontfamily = varname.fontfamily, 
                  varname.fontface = varname.fontface, axis.text.col = axis.text.col, 
                  axis.text.cex = axis.text.cex, axis.text.font = axis.text.font, 
                  axis.text.fontfamily = axis.text.fontfamily, 
                  axis.text.fontface = axis.text.fontface, axis.line.col = axis.line.col, 
                  axis.line.lty = axis.line.lty, axis.line.lwd = axis.line.lwd, 
                  axis.line.alpha = axis.line.alpha, axis.line.tck = axis.line.tck, 
                  ...)
                grid.rect(gp = gpar(col = axis.line.col, lty = axis.line.lty, 
                  lwd = axis.line.lwd, fill = "transparent"))
            }
            else {
                pargs <- if (!panel.subscripts) 
                            c(list(x = z[subscripts, j], 
                                   y = z[subscripts, i]), 
                                   list(col.symbol = clrmat[i, j]),  ## added line to display different colours in diff subpanels
                                   list(...))
                         else 
                            c(list(x = z[subscripts, j], 
                                   y = z[subscripts, i], 
                                   groups = groups, 
                                   subscripts = subscripts), 
                                   list(col.symbol = clrmat[i, j]),  ## added line to display different colours in diff subpanels
                                   list(...))
                if (!("..." %in% names(formals(panel)))) 
                  pargs <- pargs[intersect(names(pargs), names(formals(panel)))]
                if (as.matrix) 
                  do.call(if (i > j) "lower.panel" else "upper.panel", pargs)
                else do.call(if (i < j) "lower.panel" else "upper.panel", pargs)
                grid.rect(gp = gpar(col = axis.line.col, 
                                    lty = axis.line.lty, 
                                    lwd = axis.line.lwd, 
                                    fill = "transparent"))
            }
            upViewport()
        }
        upViewport()
    }
}
environment(mypanel.pairs)<-environment(panel.pairs)

#splom(~iris[1:3], superpanel=mypanel.pairs, clrmat=matrix(1:9,3,3))
#splom(~iris[1:3], superpanel=mypanel.pairs, clrmat=matrix(c(NA,1,1,2,NA,4,2,6,NA),3,3))
#theclrs <- matrix(c(NA,1,1,1,2,NA,3,3,2,4,NA,4,2,5,5,NA),4,4)
#splom(~iris[1:4], superpanel=mypanel.pairs, clrmat=theclrs)
