1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
# do.par.R: functions setting par() and for setting the overall caption
# main1 is not called main else would clash with main passed in dots (which
# we ignore but cause an error message). Likewise for xlab1 and ylab1.
do.par <- function(..., nfigs, caption, main1, xlab1, ylab1, trace,
nlines.in.main=if(is.specified(main1)) nlines(main1) else 1,
def.cex.main=1,
def.font.main=2, # use 1 for compat with plot.lm
def.right.mar=.8)
{
nrows <- ceiling(sqrt(nfigs))
# Note that the plain old cex argument is used in plotmo only in par()
# (but we also query it later using par("cex")).
# We use plain old cex relative to the cex calculated by nrows (so passing
# cex=1 to plotmo causes no changes, and cex=.8 always makes things smaller).
# TODO cex.axis etc. should be treated in the same way
# TODO consider moving this into the dotargs functions, also extend for cex.axis, cex.main
plain.old.cex <- dota("cex", DEF=1, ...)
check.numeric.scalar(plain.old.cex)
cex <- if(nrows == 1) 1
else if(nrows == 2) .83
else if(nrows >= 3) .66
cex <- plain.old.cex * cex
# set oma to make space for caption if necessary
stopifnot.string(caption, allow.empty=TRUE, null.ok=TRUE)
def.oma <- dota("oma", ...)
if(!is.specified(def.oma)) {
def.oma <- par("oma")
def.oma[3] <- max(def.oma[3], # .333 to limit cex adjustmment
2 + (plain.old.cex^.333 * nlines(caption)))
}
cex.lab <- dota("cex.lab",
# make the labels small if multiple figures
DEF=if(def.cex.main < 1) .8 * def.cex.main else 1, ...)
mgp <- # compact title and axis annotations
if(cex.lab < .6) c(1, 0.2, 0)
else if(cex.lab < .8) c(1, 0.25, 0)
else c(1.5, 0.4, 0)
# margins are small to pack plots in, but make bigger if xlab
# or ylab specified (note that xlab or ylab equal to NULL means
# that we will later auto generate them)
mar <- c(
if(is.null(xlab1) || (is.specified(xlab1) && any(nzchar(xlab1))))
4 else 3, # bottom
if(is.null(ylab1) || (is.specified(ylab1) && any(nzchar(ylab1))))
3 else 2, # left
1.2 * nlines.in.main, # top
def.right.mar) # right
if(nrows >= 5) # small margins if lots of figures
mar <- cex * mar
trace2(trace, "\n")
call.dots(graphics::par,
DROP="*", # drop everything
KEEP="PREFIX,PAR.ARGS", # except args matching PREFIX and PAR.ARGS
TRACE=if(trace >= 2) trace-1 else 0,
SCALAR=TRUE,
def.mfrow = c(nrows, nrows),
def.mgp = mgp, # compact title and axis annotations
def.tcl = -.3, # shorten tick length
def.font.main = def.font.main,
def.mar = mar,
def.oma = def.oma,
def.cex.main = def.cex.main, # ignored by most plot funcs so do it here
def.cex.lab = cex.lab,
def.cex.axis = cex.lab,
force.cex = cex, # last, overrides any cex set by any arg above
...) # any remaining graphic dot args are also processed
}
# call do.par on any graphics args in dots, and return a list of their
# old values so the caller can use on.exit to restore them
do.par.dots <- function(..., trace=0)
{
dots <- match.call(expand.dots=FALSE)$...
if(length(dots) == 0)
return(NULL)
oldpar <- args <- list()
env <- parent.frame()
for(dotname in PAR.ARGS) if(is.dot(dotname, ...)) {
arg <- list(par(dotname))
names(arg) <- dotname
oldpar <- append(oldpar, arg)
dot.org <- dota(dotname, ...)
dot <- try(eval(dot.org, envir=env, enclos=env), silent=TRUE)
if(is.try.err(dot))
dot <- dot.org
# TODO consider moving this into the dotargs functions, also extend for cex.axis, cex.main
# special handling for cex args: we want cex to be relative
# to the current setting, so e.g cex=1 causes no change
if(substr(dotname, 1, 3) == "cex") {
olddot <- par(dotname)
dot <- dot[[1]] * olddot
} else if(!(dotname %in% PAR.VEC) && length(dot) != 1)
dot <- dot[[1]] # similar to handling of argument "scalar" in eval.dotlist
arg <- list(dot)
names(arg) <- dotname
args <- append(args, arg)
}
if(length(args)) {
if(trace >= 2)
printf.wrap("\npar(%s)\n", list.as.char(args))
do.call(par, args)
}
oldpar # a list of old values of args that were changed, empty if none
}
check.do.par <- function(do.par, nfigs) # auto do.par if null, check is 0,1, or 2
{
if(is.null(do.par))
do.par <- nfigs > 1
if(is.logical(do.par))
do.par <- as.numeric(do.par)
stopifnot(length(do.par) == 1)
if(!is.numeric(do.par) || (do.par != 0 && do.par != 1 &&do.par != 2))
stop0("do.par must be 0, 1, or 2")
do.par
}
auto.caption <- function(caption, resp.name, type,
model.call, object.name, my.call)
{
sresponse <- stype <- smodel <- scaption <- smy.call <- ""
if(!is.null(caption))
scaption <- sprint("%s ", caption)
# the test against "y" is because "y" may just be a fabricated
# name created because the actual name was not available
if(!is.null(resp.name) && resp.name != "y")
sresponse <- paste0(resp.name, " ")
if(type != "response")
stype <- paste0("type=", type, " ")
if(!is.null(model.call)) {
smodel <- strip.deparse(model.call)
smodel <- sub("\\(formula=", "(", smodel) # delete formula=
} else
smodel <- paste0("model: ", object.name)
s <- paste0(scaption, sresponse, stype, smodel)
smy.call <- process.my.call.for.caption(my.call)
if(nzchar(smy.call))
s <- paste0(s, if(nzchar(s)) "\n" else "", smy.call)
s
}
# Call this only after a plot is on the screen to avoid
# an error message "plot.new has not been called yet"
draw.caption <- function(caption, ...)
{
if(!is.null(caption) && any(nzchar(caption))) {
# allow use of dot args for caption specs
cex <- dota("caption.cex cex.caption", DEF=1, NEW=1, ...)
font <- dota("caption.font font.caption", DEF=1, NEW=1, ...)
col <- dota("caption.col col.caption", DEF=1, NEW=1, ...)
line <- dota("caption.line", DEF=1, ...)
# trim so caption fits
# strwidth doesn't have units of device coords so work with usr coords
# TODO the algorithm below is not quite correct
caption <- strsplit(caption, "\n")[[1]]
usr <- par("usr") # xmin, xmax, ymin, ymax
n <- par("mfrow")[2] # number of figures horizontally across page
avail <- .7 * n * (usr[2] - usr[1])
strwidth <- max(strwidth(caption))
if(strwidth > avail) {
which <- strwidth(caption) > avail
max <- max(nchar(caption))
max.nchar <- max * avail / strwidth
if(max.nchar < max) { # TODO should always be FALSE but actually isn't
caption <- substr(caption, 1, max.nchar)
caption[which] <- paste0(caption[which], "...")
}
}
caption <- paste(caption, collapse="\n")
mtext(text=caption, line=line, outer=TRUE,
cex=cex * par("cex")^.333, col=col, font=font)
}
caption
}
get.caption <- function(nfigs, do.par, caption, resp.name, type,
model.call, object.name, my.call)
{
stopifnot.string(caption, null.ok=TRUE, allow.empty=TRUE)
if(nfigs > 1 && do.par && (is.null(caption) || !is.null(my.call)))
auto.caption(caption, resp.name, type,
model.call, object.name, my.call)
else
paste0(if(is.null(caption)) "" else caption,
if(!is.null(caption) && !is.null(my.call)) "\n" else "",
if(!is.null(my.call)) "" else process.my.call.for.caption(my.call))
}
process.my.call.for.caption <- function(my.call)
{
s <- ""
if(!is.null(my.call)) {
s <- sub("\\(object=", "(", my.call) # delete object=
s <- sub(", trace=[-._$[:alnum:]]+", "", s) # delete trace=xxx
s <- sub(", SHOWCALL=[-._$[:alnum:]]+", "", s) # delete SHOWCALL=xxx
}
s # a string, may be ""
}
|
