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