R/dplot3_bar.R

In egenn/rtemis: Machine Learning and Visualization

# dplot3_bar.R
# ::rtemis::
# 2019-22 E.D. Gennatas www.lambdamd.org

#' Interactive Barplots
#'
#' Draw interactive barplots using `plotly`
#'
#' @param x vector (possibly named), matrix, or data.frame: If matrix or 
#' data.frame, rows are groups (can be 1 row), columns are features
#' @param main Character: Main plot title.
#' @param xlab Character: x-axis label.
#' @param ylab  Character: y-axis label.
#' @param col Color, vector: Color for bars. Default NULL, which will draw 
#' colors from `palette`
#' @param alpha Float (0, 1]: Transparency for bar colors. Default = .8
#' @param theme Character: Theme to use: Use `themes()` to get available 
#' themes
#' @param palette Character: Name of \pkg{rtemis} palette to use.
#'  Default = "rtCol1". Only used if `col = NULL`
#' @param barmode Character: Type of bar plot to make: "group", "relative", 
#' "stack", "overlay". Default = "group". Use
#' "relative" for stacked bars, wich handles negative values correctly, 
#' unlike "stack", as of writing.
#' @param group.names Character, vector, length = NROW(x): Group names. 
#' Default = NULL, which uses `rownames(x)`
#' @param order.by.val Logical: If TRUE, order bars by increasing value.
#' Only use for single group data. Default = NULL
#' @param ylim Float, vector, length 2: y-axis limits.
#' @param hovernames Character, vector: Optional character vector to show on 
#' hover over each bar.
#' @param feature.names Character, vector, length = NCOL(x): Feature names. 
#' Default = NULL, which uses `colnames(x)`
#' @param font.size  Float: Font size for all labels. Default = 16
#' @param legend Logical: If TRUE, draw legend. Default = NULL, and will be 
#' turned on if there is more than one feature present
#' @param legend.col Color: Legend text color. Default = NULL, determined by 
#' theme
#' @param hline Float: If defined, draw a horizontal line at this y value. 
#' @param hline.col Color for `hline`. Default = "#ff0000" (red)
#' @param hline.width Float: Width for `hline`. Default = 1
#' @param hline.dash Character: Type of line to draw: "solid", "dot", "dash", 
#' "longdash", "dashdot",
#' or "longdashdot"
#' @param hline.annotate Character: Text of horizontal line annotation if
#' `hline` is set
#' @param hline.annotation.x Numeric: x position to place annotation with paper
#' as reference. 0: to the left of the plot area; 1: to the right of the plot area
#' @param margin Named list: plot margins.
#' @param padding Integer: N pixels to pad plot. Default = 0
#' @param filename Character: Path to file to save static plot. Default = NULL
#' @param file.width Integer: File width in pixels for when `filename` is 
#' set.
#' @param file.height Integer: File height in pixels for when `filename` 
#' is set.
#' @param file.scale Numeric: If saving to file, scale plot by this number
#' @param horizontal Logical: If TRUE, plot bars horizontally
#' @param annotate Logical: If TRUE, annotate stacked bars
#' @param annotate.col Color for annotations
#' @param legend.xy Numeric, vector, length 2: x and y for plotly's legend
#' @param legend.orientation "v" or "h" for vertical or horizontal
#' @param legend.xanchor Character: Legend's x anchor: "left", "center", 
#' "right", "auto"
#' @param legend.yanchor Character: Legend's y anchor: "top", "middle", 
#' "bottom", "auto"
#' @param automargin.x Logical: If TRUE, automatically set x-axis amrgins
#' @param automargin.y Logical: If TRUE, automatically set y-axis amrgins
#' @param displayModeBar Logical: If TRUE, show plotly's modebar
#' @param modeBar.file.format Character: "svg", "png", "jpeg", "pdf" / any 
#' output file type supported by plotly and your system
# @param print.plot Logical: If TRUE, print plot, otherwise return it invisibly
#' @param trace Integer: The height the number the more diagnostic info is 
#' printed to the console
#' @param ... Additional arguments passed to theme
#'
#' @author E.D. Gennatas
#' @export
#' @examples
#' \dontrun{
#' dplot3_bar(VADeaths, legend.xy = c(0, 1))
#' dplot3_bar(VADeaths, legend.xy = c(1, 1), legend.xanchor = "left")
#' # simple individual bars
#' a <- c(4, 7, 2)
#' dplot3_bar(a)
#' # if input is a data.frame, each row is a group and each column is a feature
#' b <- data.frame(x = c(3, 5, 7), y = c(2, 1, 8), z = c(4, 5, 2))
#' rownames(b) <- c("Jen", "Ben", "Ren")
#' dplot3_bar(b)
#' # stacked
#' dplot3_bar(b, barmode = "stack")
#' }

dplot3_bar <-  function(x,
                        main = NULL,
                        xlab = NULL,
                        ylab = NULL,
                        col = NULL,
                        alpha = 1,
                        horizontal = FALSE,
                        theme = rtTheme,
                        palette = rtPalette,
                        barmode = c("group", "relative", "stack", "overlay"),
                        group.names = NULL,
                        order.by.val = FALSE,
                        ylim = NULL,
                        hovernames = NULL,
                        feature.names = NULL,
                        font.size = 16,
                        annotate = FALSE,
                        annotate.col = theme$labs.col,
                        legend = NULL,
                        legend.col = NULL,
                        legend.xy = c(1, 1),
                        legend.orientation = "v",
                        legend.xanchor = "left",
                        legend.yanchor = "auto",
                        hline = NULL,
                        hline.col = NULL,
                        hline.width = 1,
                        hline.dash = "solid",
                        hline.annotate = NULL,
                        hline.annotation.x = 1,
                        margin = list(b = 65, l = 65, t = 50, r = 10, pad = 0),
                        automargin.x = TRUE,
                        automargin.y = TRUE,
                        padding = 0,
                        displayModeBar = TRUE,
                        modeBar.file.format = "svg",
                        filename = NULL,
                        file.width = 500,
                        file.height = 500,
                        file.scale = 1,
                        trace = 0, ...) {
  
  # Dependencies ----
  dependency_check("plotly")
  
  # Arguments ----
  barmode <- match.arg(barmode)
  if (!is.null(main)) main <- paste0("<b>", main, "</b>")
  
  dat <- as.data.frame(x)
  if (NROW(dat) == 1 && barmode != "stack") dat <- as.data.frame(t(dat))
  
  # Order by val ----
  if (order.by.val) {
    if (NCOL(dat) > 1) {
      .order <- order(sapply(dat, mean, na.rm = TRUE))
      dat <- dat[, .order]
    } else {
      .order <- order(dat[[1]])
      dat <- dat[.order, , drop = FALSE]
    }
    if (!is.null(group.names)) group.names <- group.names[.order]
    if (!is.null(hovernames)) hovernames <- hovernames[.order]
  }
  
  # Group names ----
  .group.names <- group.names
  if (is.null(group.names)) {
    if (!is.null(rownames(dat))) .group.names <- rownames(dat)
  } else if (is.numeric(group.names)) {
    .group.names <- dat[, group.names]
    rownames(dat) <- .group.names
    dat <- dat[, .group.names]
  }
  
  if (trace > 0) cat(".group.names:", .group.names, "\n")
  
  # Feature names ----
  .feature.names <- feature.names
  if (is.null(.feature.names)) {
    if (!is.null(colnames(dat))) {
      .feature.names <- labelify(colnames(dat))
    } else {
      .feature.names <- paste0("Feature", seq_len(NCOL(dat)))
    }
  }
  
  if (trace > 0) cat(".feature.names:", .feature.names, "\n")
  if (is.null(legend)) legend <- length(.feature.names) > 1
  
  # Colors ----
  if (is.character(palette)) palette <- rtpalette(palette)
  p <- NCOL(dat)
  if (is.null(col)) col <- recycle(palette, seq(p))[seq(p)]
  
  # Theme ----
  extraargs <- list(...)
  if (is.character(theme)) {
    theme <- do.call(paste0("theme_", theme), extraargs)
  } else {
    for (i in seq(extraargs)) {
      theme[[names(extraargs)[i]]] <- extraargs[[i]]
    }
  }
  
  bg <- plotly::toRGB(theme$bg)
  plot.bg <- plotly::toRGB(theme$plot.bg)
  grid.col <- plotly::toRGB(theme$grid.col)
  tick.col <- plotly::toRGB(theme$tick.col)
  labs.col <- plotly::toRGB(theme$labs.col)
  main.col <- plotly::toRGB(theme$main.col)
  axes.col <- plotly::toRGB(theme$axes.col)
  
  # Derived
  if (is.null(legend.col)) legend.col <- labs.col
  
  if (!is.null(hovernames)) {
    hovernames <- matrix(hovernames)
    if (NCOL(hovernames) == 1 && p > 1) {
      hovernames <- matrix(rep(hovernames, p), ncol = p)
    }
  }
  
  # plot_ly ----
  .group.names <- factor(.group.names, levels = .group.names)
  plt <- plotly::plot_ly(x = if (horizontal) dat[[1]] else .group.names,
                         y = if (horizontal) .group.names else dat[[1]],
                         type = "bar",
                         name = .feature.names[1],
                         text = hovernames[, 1],
                         marker = list(color = plotly::toRGB(if (p > 1) col[1] else col, alpha)),
                         showlegend = legend)
  if (p > 1) {
    for (i in seq_len(p)[-1]) plt <- plotly::add_trace(plt,
                                                       x = if (horizontal) dat[[i]] else .group.names,
                                                       y = if (horizontal) .group.names else dat[[i]],
                                                       name = .feature.names[i],
                                                       text = hovernames[, i],
                                                       marker = list(color = plotly::toRGB(col[i], alpha)))
  }
  
  if (annotate) {
    if (barmode != "stack") {
      warning("Set barmode to 'stack' to allow annotation")
    } else {
      if (horizontal) {
        for (i in seq_len(ncol(dat))) {
          plt <- plt |> plotly::add_annotations(xref = "x", yref = "y",
                                         x = rowSums(dat[, seq_len(i - 1), drop = F]) + dat[, i]/2,
                                         y = seq_len(nrow(dat)) - 1,
                                         text = paste(dat[, i]),
                                         font = list(family = theme$font.family,
                                                     size = font.size,
                                                     color = annotate.col),
                                         showarrow = FALSE)
        }
      } else {
        for (i in seq_len(ncol(dat))) {
          plt <- plt |> plotly::add_annotations(xref = "x", yref = "y",
                                         x = seq_len(nrow(dat)) - 1,
                                         y = rowSums(dat[, seq_len(i - 1), drop = F]) + dat[, i]/2,
                                         text = paste(signif(dat[, i], 2)),
                                         font = list(family = theme$font.family,
                                                     size = font.size,
                                                     color = annotate.col),
                                         showarrow = FALSE)
        }
      }
    }
    
  }
  
  # Layout ----
  f <- list(family = theme$font.family,
            size = font.size,
            color = labs.col)
  tickfont <- list(family = theme$font.family,
                   size = font.size,
                   color = theme$tick.labels.col)
  .legend <- list(x = legend.xy[1],
                  y = legend.xy[2],
                  xanchor = legend.xanchor,
                  yanchor = legend.yanchor,
                  bgcolor = "#ffffff00",
                  font = list(family = theme$font.family,
                              size = font.size,
                              color = legend.col),
                  orientation = legend.orientation)
  
  plt <- plotly::layout(plt,
                        yaxis = list(title = ylab,
                                     # showline = axes.visible,
                                     # mirror = axes.mirrored,
                                     range = ylim,
                                     titlefont = f,
                                     showgrid = theme$grid,
                                     gridcolor = grid.col,
                                     gridwidth = theme$grid.lwd,
                                     tickcolor = tick.col,
                                     tickfont = tickfont,
                                     zeroline = FALSE,
                                     automargin = automargin.y),
                        xaxis = list(title = xlab,
                                     # showline = axes.visible,
                                     # mirror = axes.mirrored,
                                     titlefont = f,
                                     showgrid = FALSE,
                                     gridcolor = grid.col,
                                     gridwidth = theme$grid.lwd,
                                     tickcolor = tick.col,
                                     tickfont = tickfont,
                                     automargin = automargin.x),
                        barmode = barmode,  # group works without actual groups too
                        title = list(text = main,
                                     font = list(family = theme$font.family,
                                                 size = font.size,
                                                 color = main.col),
                                     xref = "paper",
                                     x = theme$main.adj),
                        paper_bgcolor = bg,
                        plot_bgcolor = plot.bg,
                        margin = margin,
                        # showlegend = legend,
                        legend = .legend)
  
  # hline ----
  if (!is.null(hline)) {
    if (is.null(hline.col)) hline.col <- theme$fg
    hline.col <- recycle(hline.col, hline)
    hline.width <- recycle(hline.width, hline)
    hline.dash <- recycle(hline.dash, hline)
    hlinel <- lapply(seq_along(hline), function(i) {
      list(type = "line",
           x0 = 0, x1 = 1, xref = "paper",
           y0 = hline[i], y1 = hline[i],
           line = list(color = hline.col[i],
                       width = hline.width[i],
                       dash = hline.dash[i]))
    })
    plt <- plotly::layout(plt, shapes = hlinel)
    
    # Annotate horizontal lines on the right border of the plot
    if (!is.null(hline.annotate)) {
      plt <- plt |> plotly::add_annotations(xref = "paper", 
                                     yref = "y",
                                     xanchor = "right",
                                     yanchor = "bottom",
                                     x = hline.annotation.x,
                                     y = hline,
                                     text = hline.annotate,
                                     font = list(family = theme$font.family,
                                                 size = font.size,
                                                 color = annotate.col),
                                     showarrow = FALSE)
    }
  }
  
  # Padding
  plt$sizingPolicy$padding <- padding
  
  # Config
  plt <- plotly::config(plt,
    displaylogo = FALSE,
    displayModeBar = displayModeBar,
    toImageButtonOptions = list(
      format = modeBar.file.format,
      width = file.width,
      height = file.height
    )
  )
  
  # Write to file ----
  if (!is.null(filename)) {
      plotly::save_image(
          plt,
          file = file.path(filename),
          width = file.width, 
          height = file.height,
          scale = file.scale
      )
  }
  
  plt
  
} # rtemis::dplot3_bar.R