>>>>> Francois Rebaudo >>>>> on Wed, 25 Mar 2020 15:47:45 +0100 writes:
> Dear R-devel members, > I made a small modification in the graphics::barplot function when used with a matrix and beside argument set to false in order to be able to order each bar according to its value (from smaller to bigger or bigger to smaller), while keeping the colors. It may be of general interest (for example to be able to visualize the occurrences of letters from different texts, or the rank of a condition...). I used it in Figure 3 of one of my article here (http://dx.doi.org/10.1111/eea.12693). > I would like to ask you if it's worth proposing the modification to the barplot function (and how to do so ?) or if I should consider building a separate R package ? The modified function is attached with modifications from lines 119 and 170, and examples from lines 230. Because you did *not* attach the R script as a text file (well from one of the 99% of mail programs which do *not* allow you to set the MIME-type of an attachment) it was attached as MIME type "application/octet-stream" which translates to basically "unspecified/binary" and such unknown attachments are not allowed (for virus and spam protection). But then, because I'm one of the moderators of the R-devel list who had to approve your message, I got an e-mail from which I can extract the attachment, and as I'm using e-mail software from the rare group where you *can* specify the MIME type, I attach it here, for you and all readers. Best regards, Martin Maechler > Thanks in advance, > Best regards
# File src/library/graphics/R/barplot.R # Part of the R package, https://www.R-project.org # # Copyright (C) 1995-2019 The R Core Team # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # A copy of the GNU General Public License is available at # https://www.R-project.org/Licenses/ # modified by F. Rebaudo to be able to order bar according to its value # while keeping the color. barplot <- function(height, ...) UseMethod("barplot") barplot2 <- 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, ann = !add && par("ann"), args.legend = NULL, order = FALSE, decr = TRUE, ...) { if (!missing(inside)) .NotYetUsed("inside", error = FALSE)# -> help(.) 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) vectorInput <- (is.vector(height) || (is.array(height) && (length(dim(height)) == 1))) ## Treat vectors and 1-d arrays the same. if(vectorInput){ height <- cbind(height) beside <- TRUE ## The above may look strange, but in particular makes color ## specs work as most likely expected by the users. if(is.null(col)) col <- "grey" } else if (is.matrix(height)) { ## In the matrix case, we use "colors" by default. 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 } ## Cannot use rect(*, density=.) when log scales used 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 && !vectorInput) space <- rep.int(c(space[2L], rep.int(space[1L], NR - 1)), NC) width <- rep_len(width, NR) } else { width <- rep_len(width, NC) } offset <- rep_len(as.vector(offset), 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)# log scale in data direction ## check height + offset if using log scale to prevent log(<=0) error 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") ## if axis limit is set to < above, adjust bar base value ## to draw a full bar 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 stacked bar, set up base/cumsum levels, adjusting for log scale if (!beside) ### fr if(order){ orderHeight <- apply(height, 2L, order, decreasing = decr) height <- rbind( rectbase, apply(apply(height, 2L, sort, decreasing = decr), 2L, cumsum)) }else{ 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) { ##-------- Plotting : 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 (beside){ xyrect(rectbase + offset, w.l, c(height) + offset, w.r, horizontal = horiz, angle = angle, density = density, col = col, border = border) }else{ if(!order){ ## noInside <- NC > 1 && !inside # outside border, but not inside ## bordr <- if(noInside) 0 else border 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)# = bordr ## if(noInside) ## xyrect(min(height[, i]), w.l[i], max(height[, i]), w.r[i], ## horizontal = horiz, 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[orderHeight[,i]], border = border) } } } if (axisnames && !is.null(names.arg)) { # specified or from {col}names at.l <- if (length(names.arg) != length(w.m)) { if (length(names.arg) == NC) # i.e. beside (!) 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_len(col, 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) } } if(ann) 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 } # Here is an example: set.seed(1234) dataset <- matrix(sample(1:20, 104/2, replace = TRUE), ncol = 13) myCol <- c("#1B9E77", "#D95F02", "#7570B3", "#E7298A") graphics::barplot(height = dataset, col = myCol, names.arg = LETTERS[1:13]) barplot2(height = dataset, col = myCol, names.arg = LETTERS[1:13], order = TRUE, decr = TRUE) barplot2(height = dataset, col = myCol, names.arg = LETTERS[1:13], order = TRUE, decr = FALSE)
______________________________________________ R-devel@r-project.org mailing list https://stat.ethz.ch/mailman/listinfo/r-devel