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
}
______________________________________________
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.
