>>>>> 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
