| 1 : |
deepayan |
2 |
|
| 2 : |
|
|
## update elements of a list recursively.
|
| 3 : |
|
|
|
| 4 : |
|
|
updateList <-
|
| 5 : |
|
|
function (x, val)
|
| 6 : |
|
|
{
|
| 7 : |
|
|
if (is.null(x))
|
| 8 : |
|
|
x <- list()
|
| 9 : |
|
|
modifyList(x, val)
|
| 10 : |
|
|
}
|
| 11 : |
|
|
|
| 12 : |
|
|
|
| 13 : |
|
|
## common operations that only make sense in certain contexts
|
| 14 : |
|
|
|
| 15 : |
|
|
|
| 16 : |
|
|
useOuterStrips <-
|
| 17 : |
|
|
function(x,
|
| 18 : |
|
|
strip = strip.default,
|
| 19 : |
|
|
strip.left = strip.custom(horizontal = FALSE),
|
| 20 : |
|
|
strip.lines = 1,
|
| 21 : |
|
|
strip.left.lines = strip.lines)
|
| 22 : |
|
|
{
|
| 23 : |
|
|
dimx <- dim(x)
|
| 24 : |
|
|
stopifnot(inherits(x, "trellis"))
|
| 25 : |
|
|
stopifnot(length(dimx) == 2)
|
| 26 : |
deepayan |
188 |
as.table <- x$as.table
|
| 27 : |
|
|
|
| 28 : |
deepayan |
2 |
opar <- if (is.null(x$par.settings)) list() else x$par.settings
|
| 29 : |
|
|
par.settings <-
|
| 30 : |
|
|
modifyList(opar,
|
| 31 : |
|
|
list(layout.heights =
|
| 32 : |
deepayan |
188 |
if (as.table) list(strip = c(strip.lines, rep(0, dimx[2]-1)))
|
| 33 : |
deepayan |
47 |
else list(strip = c(rep(0, dimx[2]-1), strip.lines)),
|
| 34 : |
deepayan |
2 |
layout.widths =
|
| 35 : |
|
|
list(strip.left = c(strip.left.lines, rep(0, dimx[1]-1)))))
|
| 36 : |
|
|
if (is.character(strip))
|
| 37 : |
|
|
strip <- get(strip)
|
| 38 : |
|
|
if (is.logical(strip) && strip)
|
| 39 : |
|
|
strip <- strip.default
|
| 40 : |
|
|
new.strip <-
|
| 41 : |
|
|
if (is.function(strip))
|
| 42 : |
|
|
{
|
| 43 : |
|
|
function(which.given, which.panel, var.name, ...) {
|
| 44 : |
deepayan |
188 |
row.to.keep <- if (as.table) 1 else nrow(trellis.currentLayout())
|
| 45 : |
|
|
if (which.given == 1 && current.row() == row.to.keep)
|
| 46 : |
deepayan |
2 |
strip(which.given = 1,
|
| 47 : |
|
|
which.panel = which.panel[1],
|
| 48 : |
|
|
var.name = var.name[1],
|
| 49 : |
|
|
...)
|
| 50 : |
|
|
}
|
| 51 : |
|
|
}
|
| 52 : |
deepayan |
188 |
else strip # This could reasonable happen only if strip == FALSE
|
| 53 : |
deepayan |
2 |
if (is.character(strip.left))
|
| 54 : |
|
|
strip.left <- get(strip.left)
|
| 55 : |
|
|
if (is.logical(strip.left) && strip.left)
|
| 56 : |
|
|
strip.left <- strip.custom(horizontal = FALSE)
|
| 57 : |
|
|
new.strip.left <-
|
| 58 : |
|
|
if (is.function(strip.left))
|
| 59 : |
|
|
{
|
| 60 : |
|
|
function(which.given, which.panel, var.name, ...) {
|
| 61 : |
deepayan |
188 |
if (which.given == 2 && current.column() == 1)
|
| 62 : |
deepayan |
2 |
strip.left(which.given = 1,
|
| 63 : |
|
|
which.panel = which.panel[2],
|
| 64 : |
|
|
var.name = var.name[2],
|
| 65 : |
|
|
...)
|
| 66 : |
|
|
}
|
| 67 : |
|
|
}
|
| 68 : |
|
|
else strip.left
|
| 69 : |
|
|
update(x,
|
| 70 : |
|
|
par.settings = par.settings,
|
| 71 : |
|
|
strip = new.strip,
|
| 72 : |
|
|
strip.left = new.strip.left,
|
| 73 : |
|
|
par.strip.text = list(lines = 0.5),
|
| 74 : |
|
|
layout = dimx)
|
| 75 : |
|
|
}
|
| 76 : |
|
|
|
| 77 : |
|
|
|
| 78 : |
|
|
|
| 79 : |
|
|
|
| 80 : |
|
|
resizePanels <-
|
| 81 : |
|
|
function(x, h = 1, w = 1)
|
| 82 : |
|
|
{
|
| 83 : |
|
|
if (!missing(x))
|
| 84 : |
|
|
return(update(x,
|
| 85 : |
|
|
par.settings =
|
| 86 : |
|
|
list(layout.heights = list(panel = h),
|
| 87 : |
|
|
layout.widths = list(panel = w))))
|
| 88 : |
|
|
|
| 89 : |
|
|
cl <- trellis.currentLayout()
|
| 90 : |
|
|
if (all(dim(cl) > 1))
|
| 91 : |
|
|
stop("layout must have single column or single row.")
|
| 92 : |
|
|
if (all(dim(cl) == 1))
|
| 93 : |
|
|
{
|
| 94 : |
|
|
message("Nothing to be done.")
|
| 95 : |
|
|
return()
|
| 96 : |
|
|
}
|
| 97 : |
|
|
if (any(cl == 0)) stop("missing panels not allowed")
|
| 98 : |
|
|
if (dim(cl)[2] == 1) ## single column
|
| 99 : |
|
|
{
|
| 100 : |
|
|
pos <- seq(length = dim(cl)[1])
|
| 101 : |
|
|
heights <-
|
| 102 : |
|
|
sapply(pos,
|
| 103 : |
|
|
function(i) {
|
| 104 : |
|
|
trellis.focus("panel", 1, i, highlight = FALSE)
|
| 105 : |
|
|
ylim <- current.panel.limits()$ylim
|
| 106 : |
|
|
trellis.unfocus()
|
| 107 : |
|
|
diff(range(ylim))
|
| 108 : |
|
|
})
|
| 109 : |
|
|
return(trellis.last.object(par.settings =
|
| 110 : |
|
|
list(layout.heights = list(panel = heights))))
|
| 111 : |
|
|
}
|
| 112 : |
|
|
else if (dim(cl)[1] == 1) ## single row
|
| 113 : |
|
|
{
|
| 114 : |
|
|
pos <- seq(length = dim(cl)[2])
|
| 115 : |
|
|
widths <-
|
| 116 : |
|
|
sapply(pos,
|
| 117 : |
|
|
function(i) {
|
| 118 : |
|
|
trellis.focus("panel", i, 1, highlight = FALSE)
|
| 119 : |
|
|
xlim <- current.panel.limits()$xlim
|
| 120 : |
|
|
trellis.unfocus()
|
| 121 : |
|
|
diff(range(xlim))
|
| 122 : |
|
|
})
|
| 123 : |
|
|
return(trellis.last.object(par.settings =
|
| 124 : |
|
|
list(layout.widths = list(panel = widths))))
|
| 125 : |
|
|
}
|
| 126 : |
|
|
print(dim(cl))
|
| 127 : |
|
|
stop("shouldn't come here")
|
| 128 : |
|
|
}
|
| 129 : |
|
|
|
| 130 : |
|
|
|
| 131 : |
|
|
|
| 132 : |
|
|
|
| 133 : |
|
|
## utility functions to extract components of a formula. Don't work
|
| 134 : |
|
|
## reliably with unusual symbols
|
| 135 : |
|
|
|
| 136 : |
|
|
.responseName <- function(formula)
|
| 137 : |
|
|
{
|
| 138 : |
|
|
if (length(formula) == 3) as.character(formula[2])
|
| 139 : |
|
|
else stop("invalid formula")
|
| 140 : |
|
|
}
|
| 141 : |
|
|
|
| 142 : |
|
|
.covariateName <- function(formula)
|
| 143 : |
|
|
{
|
| 144 : |
|
|
RHS <-
|
| 145 : |
|
|
if (length(formula) == 3) as.character(formula[3])
|
| 146 : |
|
|
else if (length(formula) == 2) as.character(formula[2])
|
| 147 : |
|
|
else stop("invalid formula")
|
| 148 : |
|
|
RHS <- strsplit(RHS, " | ", fixed = TRUE)[[1]]
|
| 149 : |
|
|
RHS[1]
|
| 150 : |
|
|
}
|
| 151 : |
|
|
|
| 152 : |
|
|
.groupsName <- function(formula)
|
| 153 : |
|
|
{
|
| 154 : |
|
|
RHS <-
|
| 155 : |
|
|
if (length(formula) == 3) as.character(formula[3])
|
| 156 : |
|
|
else if (length(formula) == 2) as.character(formula[2])
|
| 157 : |
|
|
else stop("invalid formula")
|
| 158 : |
|
|
RHS <- strsplit(RHS, " | ", fixed = TRUE)[[1]]
|
| 159 : |
|
|
RHS[2]
|
| 160 : |
|
|
}
|
| 161 : |
|
|
|
| 162 : |
|
|
|
Parent Directory
| 
Revision Log
