Bill Pikounis provided a clever and elegant solution: in the program barplot.default, replace the statement
width <- rep(width, NR) that occours around line 51 ( NR = nrow(height) ) with the statement width <- width. I renamed the program barplotX.fn and attached it to this email. The attachment also includes a function called mulbarX.fn that mimics the behavior of the original SPlus function mulbar. The call mulbarX.fn(yy[,2*1:5],yy[,2*1:5-1],xlab="Baseline Category",ylab="Incidence",main="Main Title",sub="Low Volume",legendtxt=c("P","F"),ylim=c(0,0.15), + categlabs=c("Stratum 1","Stratum 2","Stratum 3","Stratum 4","Stratum 5"),legendinset=0.1,labcex=1.2) produces a result that is very close to what the SPlus function produces. This approach uses only basic R graphics. I imagine that it could be extended/incorporated into lattice or ggplot2 graphics. Larry Gould ______________________________________________ From: Gould, A. Lawrence Sent: Tuesday, January 25, 2011 10:48 AM To: 'r-help@r-project.org' Subject: barplot with varaible-width bars I would like to produce a bar plot with varying-width bars. Here is an example to illustrate: ww <- c(417,153,0.0216,0.0065,556,256,0.0162,0.0117, + 726,379,0.0358,0.0501,786,502,0.0496,0.0837, + 892,591,0.0785,0.0795) yy<-t(t(array(ww,c(2,10)))) barplot(yy[,2*1:5],las=1,space=c(.1,.5),beside=T) produces a barplot of 5 pairs of bars that are of equal width barplot(yy[,2*1:5],las=1,width=c(yy[,(2*1:5)-1]),space=c(.1,.5),beside=T) makes the bars in each pair of unequal width, but the two widths do not vary from pair to pair I would like the width of each bar to be proportional to its corresponding value in the width statement of this last call of barplot, like what I think could be done with the mulbar function of SPlus. Can I do this with barplot itself, or is this something for which lattice or ggplot 2 is needed? And, if so, what would typical code look like? Thanks for your help. Larry Gould Notice: This e-mail message, together with any attachments, contains information of Merck & Co., Inc. (One Merck Drive, Whitehouse Station, New Jersey, USA 08889), and/or its affiliates Direct contact information for affiliates is available at http://www.merck.com/contact/contacts.html) that may be confidential, proprietary copyrighted and/or legally privileged. It is intended solely for the use of the individual or entity named on this message. If you are not the intended recipient, and have received this message in error, please notify us immediately by reply e-mail and then delete it from your system.
barplotX.fn <- 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, ...) { 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 <- grey.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) width <- width } 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) { opar <- if (horiz) par(xaxs = "i", xpd = xpd) else par(yaxs = "i", xpd = xpd) on.exit(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 (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, density = density, col = col, border = border) } } 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 } mulbarX.fn <- function(height, width, xlab=NULL, ylab=NULL,legendtxt=NULL, legendpos="topleft", colors=c(0,1), ylim=c(0,1), categlabs=1:dim(height)[2], space=c(.2,.8), main=NULL,sub=NULL, legendinset=0.05, labcex=1.1) { ww <- c(width) hh <- c(height) htxt <- round(height*width,0) argnames <- array(" ",length(ww)) z <- barplotX.fn(height, width, axis.lty=1, las=1, xlab=xlab, ylab=ylab, col=colors, axisnames=T, space=space, beside=T, main=main, ylim=ylim, names.arg=argnames,tcl=0, cex.lab=labcex) zz <- c(z) if (length(legendtxt)>0) legend(legendpos,legendtxt,fill=colors,inset=legendinset) mtext(sub,side=3,line=0,outer=F,cex=labcex) for (i in 1:dim(height)[2]) mtext(categlabs[i],side=1,at=(zz[2*i-1]+zz[2*i])/2,line=1.5,outer=F,cex=labcex) for (i in 1:length(htxt)) text(zz[i],hh[i],htxt[i],pos=3) for (i in 1:length(htxt)) mtext(ww[i],side=1,at=zz[i],line=0.25,outer=F) }
______________________________________________ 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.