[R] barplot: segment-wise shading
Martin Weiser
weiser2 at natur.cuni.cz
Fri Jan 17 04:09:37 CET 2014
Jim Lemon píše v Pá 17. 01. 2014 v 13:21 +1100:
> On 01/17/2014 10:59 AM, Marc Schwartz wrote:
> >
> > ...
> > Arggh.
> >
> > No, this is my error for not actually looking at the plot and presuming that it would work.
> >
> > Turns out that it does work for a non-stacked barplot:
> >
> > barplot(VADeaths, angle = 1:20 * 10, density = 10, beside = TRUE)
> >
> > However, internally within barplot(), actually barplot.default(), the manner in which the matrix is passed to an internal function called xyrect() to draw the segments, is that entire columns are passed, rather than the individual segments (counts), when the bars are stacked.
> >
> > As a result, due to the vector based approach used, only the first 5 values of 'angle' are actually used, since there are 5 columns, rather than all 20. The same impact will be observed when using the default legend that is created.
> >
> > Thus, I don't believe that there will be an easy (non kludgy) way to do what you want, at least with the default barplot() function.
> >
> > You could fairly easily create/build your own function using ?rect, which is what barplot() uses to draw the segments. I am not sure if lattice based graphics can do this or perhaps using Hadley's ggplot based approach would offer a possibility.
> >
> > Apologies for the confusion.
> >
> > Regards,
> >
> > Marc
> >
> Hi Marc and Martin,
> When I saw the original message I tried to look at the code for the
> barplot function to see if I could call the rectFill function from
> plotrix into it. Unfortunately barplot is one of those "internal"
> functions that are not at all easy to hack and I have never gotten
> around to adding stacked bars to the barp function. I thought that
> rectFill would allow you to use more easily discriminated fills than
> angles that only differed by 18 degrees.
>
> Jim
Hi,
after Marc pointed me out where to look for, I hacked barplot.default a
bit, so now it does what I want (I added "segmentwise" argument).
Unfortunately, it works well with segmentwise = TRUE, but not with
segmentwise = FALSE (default)
With segmentwise = FALSE, density argument works only in 1/n-th of the
segments, where n is the number of columns (it seems like it refuses to
auto-multiplicate, but I do not know why).
Any ideas?
Martin
Here is my hack of barplot:
my.barplot<-
function (height, width = 1, space = NULL, names.arg = NULL,
legend.text = NULL, beside = FALSE, horiz = FALSE, density = NULL,
angle = 45, col = NULL, border = par("fg"), main = NULL,
sub = NULL, xlab = NULL, ylab = NULL, xlim = NULL, ylim = NULL,
xpd = TRUE, log = "", axes = TRUE, axisnames = TRUE, cex.axis =
par("cex.axis"),
cex.names = par("cex.axis"), inside = TRUE, plot = TRUE,
axis.lty = 0, offset = 0, add = FALSE, args.legend = NULL,
segmentwise = FALSE,
...)
{
if (!missing(inside))
.NotYetUsed("inside", error = FALSE)
if (is.null(space))
space <- if (is.matrix(height) && beside)
c(0, 1)
else 0.2
space <- space * mean(width)
if (plot && axisnames && is.null(names.arg))
names.arg <- if (is.matrix(height))
colnames(height)
else names(height)
if (is.vector(height) || (is.array(height) && (length(dim(height))
==
1))) {
height <- cbind(height)
beside <- TRUE
if (is.null(col))
col <- "grey"
}
else if (is.matrix(height)) {
if (is.null(col))
col <- gray.colors(nrow(height))
}
else stop("'height' must be a vector or a matrix")
if (is.logical(legend.text))
legend.text <- if (legend.text && is.matrix(height))
rownames(height)
stopifnot(is.character(log))
logx <- logy <- FALSE
if (log != "") {
logx <- length(grep("x", log)) > 0L
logy <- length(grep("y", log)) > 0L
}
if ((logx || logy) && !is.null(density))
stop("Cannot use shading lines in bars when log scale is used")
NR <- nrow(height)
NC <- ncol(height)
if (beside) {
if (length(space) == 2)
space <- rep.int(c(space[2L], rep.int(space[1L],
NR - 1)), NC)
width <- rep(width, length.out = NR)
}
else {
width <- rep(width, length.out = NC)
}
offset <- rep(as.vector(offset), length.out = length(width))
delta <- width/2
w.r <- cumsum(space + width)
w.m <- w.r - delta
w.l <- w.m - delta
log.dat <- (logx && horiz) || (logy && !horiz)
if (log.dat) {
if (min(height + offset, na.rm = TRUE) <= 0)
stop("log scale error: at least one 'height + offset' value
<= 0")
if (logx && !is.null(xlim) && min(xlim) <= 0)
stop("log scale error: 'xlim' <= 0")
if (logy && !is.null(ylim) && min(ylim) <= 0)
stop("log scale error: 'ylim' <= 0")
rectbase <- if (logy && !horiz && !is.null(ylim))
ylim[1L]
else if (logx && horiz && !is.null(xlim))
xlim[1L]
else 0.9 * min(height, na.rm = TRUE)
}
else rectbase <- 0
if (!beside)
height <- rbind(rectbase, apply(height, 2L, cumsum))
rAdj <- offset + (if (log.dat)
0.9 * height
else -0.01 * height)
delta <- width/2
w.r <- cumsum(space + width)
w.m <- w.r - delta
w.l <- w.m - delta
if (horiz) {
if (is.null(xlim))
xlim <- range(rAdj, height + offset, na.rm = TRUE)
if (is.null(ylim))
ylim <- c(min(w.l), max(w.r))
}
else {
if (is.null(xlim))
xlim <- c(min(w.l), max(w.r))
if (is.null(ylim))
ylim <- range(rAdj, height + offset, na.rm = TRUE)
}
if (beside)
w.m <- matrix(w.m, ncol = NC)
if (plot) {
dev.hold()
opar <- if (horiz)
par(xaxs = "i", xpd = xpd)
else par(yaxs = "i", xpd = xpd)
on.exit({
dev.flush()
par(opar)
})
if (!add) {
plot.new()
plot.window(xlim, ylim, log = log, ...)
}
xyrect <- function(x1, y1, x2, y2, horizontal = TRUE,
...) {
if (horizontal)
rect(x1, y1, x2, y2, ...)
else rect(y1, x1, y2, x2, ...)
}
if(segmentwise){
arg.lengths <- c(length(angle), length(density),
length(col), length(border))
angle <- rep(angle, max(arg.lengths)/arg.lengths[1])
density <- rep(density, max(arg.lengths)/arg.lengths[2])
col <- rep(col, max(arg.lengths)/arg.lengths[3])
border <- rep(border, max(arg.lengths)/arg.lengths[4])
}
if (beside)
xyrect(rectbase + offset, w.l, c(height) + offset,
w.r, horizontal = horiz, angle = angle, density =
density,
col = col, border = border)
else {
for (i in 1L:NC) {
xyrect(height[1L:NR, i] + offset[i], w.l[i],
height[-1, i] + offset[i], w.r[i], horizontal =
horiz,
angle = angle[segmentwise * NR * (i-1)+(1L:NR)],
density = density[segmentwise * NR * (i-1)+(1L:NR)],
col = col[segmentwise * NR * (i-1)+(1L:NR)],
border = border[segmentwise * NR * (i-1)+(1L:NR)])
}
}
if (axisnames && !is.null(names.arg)) {
at.l <- if (length(names.arg) != length(w.m)) {
if (length(names.arg) == NC)
colMeans(w.m)
else stop("incorrect number of names")
}
else w.m
axis(if (horiz)
2
else 1, at = at.l, labels = names.arg, lty = axis.lty,
cex.axis = cex.names, ...)
}
if (!is.null(legend.text)) {
legend.col <- rep(col, length.out = length(legend.text))
if ((horiz & beside) || (!horiz & !beside)) {
legend.text <- rev(legend.text)
legend.col <- rev(legend.col)
density <- rev(density)
angle <- rev(angle)
}
xy <- par("usr")
if (is.null(args.legend)) {
legend(xy[2L] - xinch(0.1), xy[4L] - yinch(0.1),
legend = legend.text, angle = angle, density =
density,
fill = legend.col, xjust = 1, yjust = 1)
}
else {
args.legend1 <- list(x = xy[2L] - xinch(0.1),
y = xy[4L] - yinch(0.1), legend = legend.text,
angle = angle, density = density, fill = legend.col,
xjust = 1, yjust = 1)
args.legend1[names(args.legend)] <- args.legend
do.call("legend", args.legend1)
}
}
title(main = main, sub = sub, xlab = xlab, ylab = ylab,
...)
if (axes)
axis(if (horiz)
1
else 2, cex.axis = cex.axis, ...)
invisible(w.m)
}
else w.m
}
More information about the R-help
mailing list