Improves bs4ProgressBar & bs4MultiProgressBar

DESCRIPTION

@@ -19,6 +19,7 @@ Imports:
     htmltools (>= 0.5.1.1),
     jsonlite (>= 0.9.16),
     fresh,
+    grDevices,
     waiter (>= 0.2.3),
     httpuv (>= 1.5.2),
     lifecycle,

NAMESPACE

@@ -82,6 +82,7 @@ export(cardSidebar)
 export(carousel)
 export(carouselItem)
 export(closeAlert)
+export(col2css)
 export(column)
 export(controlbarItem)
 export(controlbarMenu)
@@ -176,6 +177,7 @@ export(userPost)
 export(userPostMedia)
 export(userPostTagItem)
 export(userPostTagItems)
+export(validateColors)
 export(valueBox)
 export(valueBoxOutput)
 importFrom(jsonlite,toJSON)

R/useful-items.R

@@ -467,14 +467,18 @@ bs4CarouselItem <- function(..., caption = NULL, active = FALSE) {
 #' 
 #' @param size Progress bar size. NULL, "sm", "xs" or "xxs".
 #' @param label Progress label. NULL by default.
-#' 
+#' @param id HTML ID. NULL by default
+#' @param values_cumulative \code{multiProgressBar} only. Whether \code{value} is comprised of cumulative  \code{TRUE} values or actual \code{FALSE} values. See details for examples.
 #' @md
 #' @details For `multiProgressBar()`, `value` can be a vector which
 #'   corresponds to the progress for each segment within the progress bar.
 #'   If supplied, `striped`, `animated`, `status`, and `label` must be the
 #'   same length as `value` or length 1, in which case vector recycling is
-#'   used.
-#' 
+#'   used. The `values_cumulative` argument is described below:
+#'   \itemize{
+#'   \item{cumulative}{ values = c(10, 20, 30) is interpreted as a 10% width bar, a 20% width bar, and a 30% width bar for a total of 60%}
+#'   \item{actual}{ values = c(10, 20, 30) is interpreted as a 10% width bar, a 10% width bar, and a 10% width bar for a total of 30%. These values are scaled by \code{min} & \code{max} arguments.} 
+#' }
 #' @examples
 #' if(interactive()){
 #'  library(shiny)
@@ -549,9 +553,9 @@ bs4CarouselItem <- function(..., caption = NULL, active = FALSE) {
 #' @export
 bs4ProgressBar <- function (value, min = 0, max = 100, vertical = FALSE, striped = FALSE, 
                             animated = FALSE, status = "primary", size = NULL, 
-                            label = NULL) {
+                            label = NULL, id = NULL) {
 
-  if (!is.null(status)) validateStatusPlus(status)
+  if (!is.null(status)) validateColors(status)
   stopifnot(value >= min)
   stopifnot(value <= max)
 
@@ -561,30 +565,41 @@ bs4ProgressBar <- function (value, min = 0, max = 100, vertical = FALSE, striped
 
   # bar class
   barCl <- "progress-bar"
-  if (!is.null(status)) barCl <- paste0(barCl, " bg-", status)
+  style <- NULL
+  if (!is.null(status) && status %in% validStatusesPlus) barCl <- paste0(barCl, " bg-", status)
+  else if (status %in% validColorsPlus || is_hex_color(status))
+    style <- paste0(style, "background-color: ", col2css(status), ";")
   if (striped) barCl <- paste0(barCl, " progress-bar-striped")
   if (animated) barCl <- paste0(barCl, " progress-bar-animated")
 
   # wrapper
   barTag <- shiny::tags$div(
+    id = id,
     class = barCl, 
     role = "progressbar", 
     `aria-valuenow` = value, 
     `aria-valuemin` = min, 
     `aria-valuemax` = max, 
-    style = if (vertical) {
-      paste0("height: ", paste0(value, "%"))
-    }
-    else {
-      paste0("width: ", paste0(value, "%"))
-    }, 
+    style = paste0(style, ifelse(vertical, "height: ", "width: "), ((value - min) / (max - min) * 100), "%"), 
     if(!is.null(label)) label
   )
 
   progressTag <- shiny::tags$div(class = progressCl)
   progressTag <- shiny::tagAppendChild(progressTag, barTag)
   progressTag
 }
+# Scale values to a percentage/decimal by min & max
+val2pct <- function(val, min = 0, max = 100, include_min = TRUE, include_max = FALSE, as_percent = TRUE) {
+  .val <- sort(val)
+  if (include_min)
+    .val <- c(min, .val)
+  if (include_max)
+    .val <- c(.val, max)
+  out <- diff((.val - min) / (max - min))
+  if (as_percent)
+    out <- out * 100
+  out
+}
 
 #' @rdname progress
 #' @export
@@ -598,22 +613,36 @@ bs4MultiProgressBar <-
     animated = FALSE,
     status = "primary",
     size = NULL,
-    label = NULL
+    label = NULL,
+    id = NULL,
+    values_cumulative = TRUE
   ) {
     status <- verify_compatible_lengths(value, status)
     striped <- verify_compatible_lengths(value, striped)
     animated <- verify_compatible_lengths(value, animated)
     if (!is.null(label)) label <- verify_compatible_lengths(value, label)
 
-    if (!is.null(status)) lapply(status, function(x) validateStatusPlus(x))
+    if (!is.null(status)) lapply(status, function(x) validateColors(x))
     stopifnot(all(value >= min))
     stopifnot(all(value <= max))
-    stopifnot(sum(value) <= max)
+    if (!values_cumulative) {
+      .value <- val2pct(value, min = min, max = max)
+      stopifnot(sum(.value) <= 100)
+    } else {
+      .value <- value
+      stopifnot(sum(value) <= max)
+    }
+
 
     bar_segment <- function(value, striped, animated, status, label) {
       # bar class
       barCl <- "progress-bar"
-      if (!is.null(status)) barCl <- paste0(barCl, " bg-", status)
+      style <- NULL
+      if (!is.null(status) && status %in% validStatusesPlus) barCl <- paste0(barCl, " bg-", status)
+      else if (status %in% validColorsPlus || is_hex_color(status))
+        style <- paste0(style, "background-color: ", col2css(status), ";")
+
+
       if (striped) barCl <- paste0(barCl, " progress-bar-striped")
       if (animated) barCl <- paste0(barCl, " progress-bar-animated")
 
@@ -623,22 +652,25 @@ bs4MultiProgressBar <-
         `aria-valuenow` = value, 
         `aria-valuemin` = min, 
         `aria-valuemax` = max, 
-        style = if (vertical) {
-          paste0("height: ", paste0(value, "%"))
-        }
-        else {
-          paste0("width: ", paste0(value, "%"))
-        }, 
+        style = paste0(style, ifelse(vertical, "height: ", "width: "), value, "%;", ifelse(vertical && values_cumulative, "position:relative;", "")), 
         if(!is.null(label)) label
       )
     }
 
+    if (vertical && values_cumulative) {
+      # the vertical bar has the divs rendered in order so it appears top down. This reverses the order so it appears bottom up as is more intuitive.
+      .value <- rev(.value)
+      status <- rev(status)
+      striped <- rev(striped)
+      animated <- rev(animated)
+      label <- rev(label)
+    }
     barSegs <- list()
     # progress bar segments
     for (i in seq_along(value)) {
       barSegs[[i]] <- 
         bar_segment(
-          value[[i]],
+          .value[[i]],
           striped[[i]],
           animated[[i]],
           status[[i]],
@@ -649,7 +681,7 @@ bs4MultiProgressBar <-
     # wrapper class
     progressCl <- if (isTRUE(vertical)) "progress vertical" else "progress mb-3"
     if (!is.null(size)) progressCl <- paste0(progressCl, " progress-", size)
-    progressTag <- shiny::tags$div(class = progressCl)
+    progressTag <- shiny::tags$div(class = progressCl, id = id)
     progressTag <- shiny::tagAppendChild(progressTag, barSegs)
     progressTag
   }

R/utils.R

@@ -212,6 +212,52 @@ validateStatusPlus <- function(status) {
 #' @keywords internal
 validStatusesPlus <- c(validStatuses, validNuances, validColors)
 
+#' All valid colors
+#' @usage NULL
+#' @format NULL
+#'
+#' @keywords internal
+validColorsPlus <- c(grDevices::colours(), validStatusesPlus)
+
+# is string a hex formatted color
+is_hex_color <- function(color) {
+  grepl("^\\#[a-fA-F0-9]{3,6}", color)
+}
+# is string an rgba formatted color
+is_rgba_color <- function(color) {
+  grepl("^rgba\\(", color)
+}
+
+#' Validate all colors & Bootstrap statuses
+#'
+#' @param color \code{chr} string with status name or color name
+#'
+#' @return \code{lgl}
+#' @export
+#' @seealso grDevices::color
+validateColors <- function(color) {
+  if (color %in% validColorsPlus || is_hex_color(color) || is_rgba_color(color))
+    TRUE
+  else
+    stop("Invalid color: ", color, ". Valid colors are hex or rgba formatted or one of the following: ",
+         paste(validColorsPlus, collapse = ", "), ".")
+}
+
+
+#' Create a CSS rgba declaration for a color name
+#'
+#' @param color \code{chr} Color name, see \link[grDevices]{colors}
+#' @param alpha \code{num} alpha value
+#'
+#' @return \code{chr} css `rgba()` formatted color
+#' @export
+
+col2css <- function(color, alpha = NULL) {
+  if (!is_hex_color(color) && !is_rgba_color(color))
+    paste0("rgba(", paste0(c(grDevices::col2rgb(color), alpha), collapse = ", "), ")")
+  else
+    color
+}