> -----Original Message-----
> From: r-help-boun...@r-project.org
> [mailto:r-help-boun...@r-project.org] On Behalf Of Susanne Meyfarth
> Thank you. I saw these postings, but I don't want to learn
> lattice for this reason (was afraid to have to change then
> everything else in my graph). Anyway, I now tried with
> different shades of greyscale (4 shades). I'm not fully
> satisfied with it, but it's ok. It's for a publication and
> depending on whether I have to change the graph, I decide to
> either put texture in some boxes manually or still look for a
> solution in R.
You could create your own boxplot functions from the existing code. In this
instance, you'd need a at least a modest modification to bxp()
I have included a shaded.bxp function that does the (basic) job below (see
between #=============). bxp is normally called by boxplot, so you'd need to
have a modified boxplot as werll if you wanted to work most simply. However,
bxp will plot a boxplot object produced with plot=FALSE, so a modified bxp does
the job for a one-off.
To use it, do something like this:
x<-rnorm(150)
g <- gl(5,30)
b.x <- boxplot(x~g, plot=FALSE) #creates the boxplot object bxp expects.
shaded.bxp(b.x, density=10, boxfill=1)
#For different shadings in the same set of boxes, this variant accepts vector
density and angle: use
shaded.bxp(b.x, density=5*1:5, boxfill=1 , angle=seq(45, 135, length=5))
#If you need to build a complicated boxplot as in the ?boxplot example, with
one fill for each set of boxes, you'll need to create the boxplot objects and
add them separately:
y<-rnorm(150)
b.y <- boxplot(y~g, plot=FALSE)
shaded.bxp(b.x, density=10, boxfill=1, at=1:5-0.2, boxwex=0.3, axes=FALSE,
ylim=range(pretty(c(x,y)))) #note the ylim allowance for all data
shaded.bxp(b.y, density=5, angle=135, boxfill=1, at=1:5+0.2, boxwex=0.3,
add=TRUE, axes=FALSE)
box()
axis(2)
axis(1, at=1:5, labels=paste("Group", 1:5))
Steve Ellison
#================================
#bxp including shading
shaded.bxp <- function (z, notch = FALSE, width = NULL, varwidth = FALSE,
outline = TRUE,
notch.frac = 0.5, log = "", border = par("fg"), pars = NULL,
frame.plot = axes, horizontal = FALSE, add = FALSE, at = NULL,
show.names = NULL, density=NULL, angle=45, ...)
{
pars <- c(list(...), pars)
pars <- pars[unique(names(pars))]
bplt <- function(x, wid, stats, out, conf, notch, xlog, i, density,
angle=45, boxfill) {
ok <- TRUE
if (!any(is.na(stats))) {
xP <- if (xlog)
function(x, w) x * exp(w)
else function(x, w) x + w
wid <- wid/2
if (notch) {
ok <- stats[2L] <= conf[1L] && conf[2L] <= stats[4L]
xx <- xP(x, wid * c(-1, 1, 1, notch.frac, 1,
1, -1, -1, -notch.frac, -1))
yy <- c(stats[c(2, 2)], conf[1L], stats[3L],
conf[2L], stats[c(4, 4)], conf[2L], stats[3L],
conf[1L])
}
else {
xx <- xP(x, wid * c(-1, 1, 1, -1))
yy <- stats[c(2, 2, 4, 4)]
}
if (!notch)
notch.frac <- 1
wntch <- notch.frac * wid
xypolygon(xx, yy, lty = "blank", col = boxfill[i],
density=density[i], angle=angle[i])
xysegments(xP(x, -wntch), stats[3L], xP(x, +wntch),
stats[3L], lty = medlty[i], lwd = medlwd[i],
col = medcol[i], lend = 1)
xypoints(x, stats[3L], pch = medpch[i], cex = medcex[i],
col = medcol[i], bg = medbg[i])
xysegments(rep.int(x, 2), stats[c(1, 5)], rep.int(x,
2), stats[c(2, 4)], lty = whisklty[i], lwd = whisklwd[i],
col = whiskcol[i])
xysegments(rep.int(xP(x, -wid * staplewex[i]), 2),
stats[c(1, 5)], rep.int(xP(x, +wid * staplewex[i]),
2), stats[c(1, 5)], lty = staplelty[i], lwd = staplelwd[i],
col = staplecol[i])
xypolygon(xx, yy, lty = boxlty[i], lwd = boxlwd[i],
border = boxcol[i], density=density[i], angle=angle[i],
col=boxfill[i])
if ((nout <- length(out))) {
xysegments(rep(x - wid * outwex, nout), out,
rep(x + wid * outwex, nout), out, lty = outlty[i],
lwd = outlwd[i], col = outcol[i])
xypoints(rep.int(x, nout), out, pch = outpch[i],
lwd = outlwd[i], cex = outcex[i], col = outcol[i],
bg = outbg[i])
}
if (any(inf <- !is.finite(out))) {
warning(sprintf(ngettext(length(unique(out[inf])),
"Outlier (%s) in boxplot %d is not drawn",
"Outliers (%s) in boxplot %d are not drawn"),
paste(unique(out[inf]), collapse = ", "), x),
domain = NA)
}
}
return(ok)
}
if (!is.list(z) || 0L == (n <- length(z$n)))
stop("invalid first argument")
if (is.null(at))
at <- 1L:n
else if (length(at) != n)
stop("'at' must have same length as 'z$n', i.e. ", n)
if (is.null(z$out))
z$out <- numeric()
if (is.null(z$group) || !outline)
z$group <- integer()
if (is.null(pars$ylim))
ylim <- range(z$stats[is.finite(z$stats)], if (outline)
z$out[is.finite(z$out)],
if (notch) z$conf[is.finite(z$conf)])
else {
ylim <- pars$ylim
pars$ylim <- NULL
}
if (is.null(pars$xlim))
xlim <- c(0.5, n + 0.5)
else {
xlim <- pars$xlim
pars$xlim <- NULL
}
if (length(border) == 0L)
border <- par("fg")
dev.hold()
on.exit(dev.flush())
if (!add) {
plot.new()
if (horizontal)
plot.window(ylim = xlim, xlim = ylim, log = log,
xaxs = pars$yaxs)
else plot.window(xlim = xlim, ylim = ylim, log = log,
yaxs = pars$yaxs)
}
xlog <- (par("ylog") && horizontal) || (par("xlog") && !horizontal)
pcycle <- function(p, def1, def2 = NULL) rep(if (length(p)) p else if
(length(def1)) def1 else def2,
length.out = n)
p <- function(sym) pars[[sym, exact = TRUE]]
boxlty <- pcycle(pars$boxlty, p("lty"), par("lty"))
boxlwd <- pcycle(pars$boxlwd, p("lwd"), par("lwd"))
boxcol <- pcycle(pars$boxcol, border)
boxfill <- pcycle(pars$boxfill, par("bg"))
density <- rep(density, length.out=n)
density <- rep(density, length.out=n)
angle <- rep(angle, length.out=n)
boxwex <- pcycle(pars$boxwex, 0.8 * {
if (n <= 1)
1
else stats::quantile(diff(sort(if (xlog)
log(at)
else at)), 0.1)
})
medlty <- pcycle(pars$medlty, p("lty"), par("lty"))
medlwd <- pcycle(pars$medlwd, 3 * p("lwd"), 3 * par("lwd"))
medpch <- pcycle(pars$medpch, NA_integer_)
medcex <- pcycle(pars$medcex, p("cex"), par("cex"))
medcol <- pcycle(pars$medcol, border)
medbg <- pcycle(pars$medbg, p("bg"), par("bg"))
whisklty <- pcycle(pars$whisklty, p("lty"), "dashed")
whisklwd <- pcycle(pars$whisklwd, p("lwd"), par("lwd"))
whiskcol <- pcycle(pars$whiskcol, border)
staplelty <- pcycle(pars$staplelty, p("lty"), par("lty"))
staplelwd <- pcycle(pars$staplelwd, p("lwd"), par("lwd"))
staplecol <- pcycle(pars$staplecol, border)
staplewex <- pcycle(pars$staplewex, 0.5)
outlty <- pcycle(pars$outlty, "blank")
outlwd <- pcycle(pars$outlwd, p("lwd"), par("lwd"))
outpch <- pcycle(pars$outpch, p("pch"), par("pch"))
outcex <- pcycle(pars$outcex, p("cex"), par("cex"))
outcol <- pcycle(pars$outcol, border)
outbg <- pcycle(pars$outbg, p("bg"), par("bg"))
outwex <- pcycle(pars$outwex, 0.5)
width <- if (!is.null(width)) {
if (length(width) != n | any(is.na(width)) | any(width <=
0))
stop("invalid boxplot widths")
boxwex * width/max(width)
}
else if (varwidth)
boxwex * sqrt(z$n/max(z$n))
else if (n == 1)
0.5 * boxwex
else rep.int(boxwex, n)
if (horizontal) {
xypoints <- function(x, y, ...) points(y, x, ...)
xypolygon <- function(x, y, ...) polygon(y, x, ...)
xysegments <- function(x0, y0, x1, y1, ...) segments(y0,
x0, y1, x1, ...)
}
else {
xypoints <- points
xypolygon <- polygon
xysegments <- segments
}
ok <- TRUE
for (i in 1L:n) ok <- ok & bplt(at[i], wid = width[i], stats = z$stats[,
i], out = z$out[z$group == i], conf = z$conf[, i], notch = notch,
xlog = xlog, i = i, density=density, angle=angle, boxfill=boxfill)
if (!ok)
warning("some notches went outside hinges ('box'): maybe set
notch=FALSE")
axes <- is.null(pars$axes)
if (!axes) {
axes <- pars$axes
pars$axes <- NULL
}
if (axes) {
ax.pars <- pars[names(pars) %in% c("xaxt", "yaxt", "xaxp",
"yaxp", "las", "cex.axis", "col.axis", "format")]
if (is.null(show.names))
show.names <- n > 1
if (show.names)
do.call("axis", c(list(side = 1 + horizontal, at = at,
labels = z$names), ax.pars))
do.call("Axis", c(list(x = z$stats, side = 2 - horizontal),
ax.pars))
}
do.call("title", pars[names(pars) %in% c("main", "cex.main",
"col.main", "sub", "cex.sub", "col.sub", "xlab", "ylab",
"cex.lab", "col.lab")])
if (frame.plot)
box()
invisible(at)
}
#================================
*******************************************************************
This email and any attachments are confidential. Any use...{{dropped:8}}
______________________________________________
R-help@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-help
PLEASE do read the posting guide http://www.R-project.org/posting-guide.html
and provide commented, minimal, self-contained, reproducible code.
