contribution to package graphics::barplot

classic Classic list List threaded Threaded
2 messages Options
Reply | Threaded
Open this post in threaded view
|

contribution to package graphics::barplot

francois.rebaudo
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.
Thanks in advance,
Best regards

______________________________________________
[hidden email] mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
Reply | Threaded
Open this post in threaded view
|

Re: contribution to package graphics::barplot

Martin Maechler
>>>>>   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)

______________________________________________
[hidden email] mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel