Refresh and refactor value boxes

[gadenbuie]

For #625

New features

• Many new themes, powered by utility classes added to the Bootstrap bundle. We already have bg-{name} and text-{name} classes from $theme-colors (the semantic color names, like primary), to which we're adding bg-{color} and text-{color} (the main colors from the $colors map), as well as gradient background classes with bg-gradient-{from}-{to} where from and to are drawn from the main colors map as well. Both can be user-customized via the $bslib-gradient-colors map.

• The theme_color argument is replaced with theme. For now theme_color is passed to theme if only one is provided, with a deprecation warning thanks to lifecycle. As a result, I'm also adding lifecycle as a new dependency so that we can start using it in more places.

• Themes are now fully customizable via value_box_theme(), which takes name, bg, and fg. I've also added a helper function pair_colors_bg_fg() that we can use to perform our typical foreground color picking based on contrast with the background color. The value_box_theme() creates a new bslib_value_box_theme classed list that contains the theme class and styles to be applied inline to the value box card.

• Similarly we now have a bslib_showcase_layout class to organize the user options for the showcase layout. The showcase_layout argument of value_box() now accepts primarily character strings, to use the default settings of the named showcase layout, or the result from the showcase_layout_{layout}() functions where the user can customize the layout settings.

• I added a new showcase layout, called showcase_bottom() featuring a full-bleed plot along the bottom edge of the value box. There are now three layouts, "left center", "top right", and "bottom".

• The layout_showcase() function now creates consistent value_box() markup that carries the user preference forward. All of the layout logic was moved into the value box CSS, so we only do basic validation of units on the R side. As a part of this, I also removed the internal use of layout_column_wrap(), opting instead for a custom grid implementation. The lets us simplify the value box markup considerably, in particular to be able to coordinate the .value-box-showcase and .value-box-area (contents) entirely around those classes.

• The CSS was refactored considerably. In particular, we now use named grid areas and assign the showcase and contents to those areas based on the .showcase-{layout} classes.

• I moved the .showcase-{layout} class to the top level of the value box. This lets us approach the showcase layout styles more holistically. Also, all of the custom CSS properties used to communicate the user's preferences from R are now consolidated on the .value-box-grid item. They also start with ---bslib- (rather than --bslib) to indicate they are private CSS properties. (In the future, we'd rather --_bslib but can't currently due to limitations with `htmltools::css().)

• When no specific theme is requested by the user, we add a .default class to the .bslib-value-box container. This class can be used to style the default value box appearance. It defaults to the colors used by cards in the current theme, but can also be customized via CSS variables from anywhere higher up in the DOM tree (likely on :root). These variables are --bslib-value-box-color, --bslib-value-box-bg, --bslib-value-box-border-color, and --bslib-value-box-border-width.

• Box shadows can be turned on for value boxes via the $enable-shadows flag, or specifically through $bslib-value-box-enable-shadow.

• We also added $bslib-value-box-enable-border that can be one of "auto", "always" or "never". When "never", we remove all borders from value boxes. "always" is an implicit state, and technically means that we follow the .card styles. When "auto", the default, borders are enabled for cards that 1) don't set a background color and 2) that don't have shadows.

• There are also a few shiny preset style changes in here. In particular, we're adding a gradient to icons used in the default-themed value boxes. To get the gradient on the SVG icons, we have to get an <svg> element onto the page, so we're doing a bit of an unusual round trip by adding a script to the value box dependency that contains the full svg (it's small) and writes it into the document so we can use it.

Preview

Kitchen Sink App

library(shiny)
library(plotly)
pkgload::load_all()

# a set of random values for value boxes, with things like percents, dollars, money, counts, etc.
random_values <- tibble::tribble(
  ~label, ~value,
  "Sales revenue", "$22,456.78",
  "Customer satisfaction", "94.5%",
  "Inventory turnover", "8/month",
  "Number of employees", "75",
  "Website traffic", "12,345 visits/day",
  "Customer retention", "87%",
  "Average transaction", "$56.73",
  "Followers", "10,234",
  "Open rate", "22.6%",
  "Production efficiency", "92%",
  "Project completion", "17 days",
  "Employee turnover", "10%",
  "Market share", "15.2%",
  "ROI", "8.3%",
  "Average response time", "3.2 seconds",
  "Energy consumption", "345 kwh/month",
  "Customer churn", "5%",
  "Production defect rate", "0.6%",
  "Engagement rate", "3.8%",
  "Average wait", "4 minutes",
  "Project budget variance", "$2,345.67",
  "Employee productivity", "95%",
  "Conversion rate", "2.5%",
  "Website bounce rate", "42%",
  "Revenue growth", "+15.2%",
  "Customer loyalty", "4.5 out of 5",
  "Product quality", "8.9/10",
  "Social media followers", "50,000+",
  "Market reach", "10.5 million",
  "Employee satisfaction", "92.3%",
  "Average order value", "$123.45",
  "Website conversion rate", "3.6%",
  "Customer support", "9.8/10",
  "Productivity index", "120%",
  "Customer lifetime value", "$5,000",
  "Brand awareness", "85%",
  "Time to market", "4 weeks",
  "Return on investment", "18.5%",
  "Net promoter score", "8.2 out of 10",
  "Email click-through rate", "12.7%",
  "Supply chain efficiency", "92%",
  "Website loading time", "2.3 seconds",
  "Cost per acquisition", "$25.60",
  "Employee engagement", "83%",
  "Innovation index", "9.5/10",
  "Customer complaints resolved", "98.6%",
  "Market share growth", "+2.3%",
  "Production capacity utilization", "87%",
  "Website traffic source diversity", "5 channels",
  "Brand equity", "$1.2 billion"
)

named_colors <- c(
  "blue",
  "indigo",
  "purple",
  "pink",
  "red",
  "orange",
  "yellow",
  "green",
  "teal",
  "cyan"
)

gradient_classes <-
  expand.grid(named_colors, named_colors) |>
  dplyr::filter(Var1 != Var2) |>
  dplyr::mutate(class = paste0("bg-gradient-", Var1, "-", Var2)) |>
  dplyr::pull(class)

theme_colors <- list(
  "primary",
  "secondary",
  "success",
  "danger",
  "warning",
  "info",
  "light",
  "dark"
)

generate_random_walk <- function(num_steps = 90) {
  start_date <- as.POSIXct(as.integer(Sys.time()) * runif(1), origin = "1970-01-01")

  increments <- rnorm(num_steps)
  cumulative_sum <- cumsum(increments)
  time_series <- c(0, cumulative_sum) + rnorm(1, 0, 50) + 25

  dates <- seq(start_date, length.out = num_steps + 1, by = "day")

  data.frame(date = dates, value = time_series)
}


random_plotly_plot <- function(color = "white") {
  plot <- switch(
    sample(c("bar", "box", "line"), 1),
    bar = plot_ly(
      x = ~ runif(50),
      type = "histogram",
      histnorm = "probability",
      color = I(color)
    ),
    box = plot_ly(x = ~rnorm(50), type = "box", color = I(color)),
    line = plot_ly(generate_random_walk())  |>
      add_lines(
        x = ~ date,
        y = ~ value,
        color = I(color),
        fill = "tozeroy",
        span = I(1),
        alpha = 0.2
      )
  )

  plot %>%
  layout(
    xaxis = list(visible = FALSE, showgrid = FALSE, title = ""),
    yaxis = list(visible = FALSE, showgrid = FALSE, title = ""),
    hovermode = "x",
    margin = list(t = 0, r = 0, l = 0, b = 0),
    font = list(color = "white"),
    paper_bgcolor = "transparent",
    plot_bgcolor = "transparent"
  ) %>%
  config(displayModeBar = FALSE) %>%
  htmlwidgets::onRender(
    "function(el) {
      var ro = new ResizeObserver(function() {
         var visible = el.offsetHeight > 200;
         Plotly.relayout(el, {'xaxis.visible': visible});
      });
      ro.observe(el);
    }"
  )
}

bs_get_variables   <- memoise::memoise(bslib::bs_get_variables)
get_color_contrast <- memoise::memoise(bslib:::get_color_contrast)

get_theme_color <- function(theme = NULL, global_theme = bs_global_theme()) {
  if (is.null(theme)) {
    color <- "black"
  } else if (grepl("^bg-", theme) || !grepl("^text-", theme)) {
    message("theme_color: ", theme)
    color <- sub("^bg-(gradient-)?", "$", theme)
    if (grepl("-gradient-", theme)) {
      color <- sub("-\\w+$", "", color)
    }
    message("color_var: ", color)
    color <- bs_get_variables(global_theme, color)
    color <- get_color_contrast(unname(color))
    message("color: ", color)
  } else {
    message("theme: ", theme)
    color <- bs_get_variables(
      global_theme,
      sub("^text-", "$", theme)
    )[[1]]
    message("color: ", color)
  }
  message("")
  color
}

make_value_boxes <- function(themes, add_showcase = TRUE) {
  n_themes <- length(themes)
  replace <- n_themes > length(random_values)
  ridx <- sample(seq_len(nrow(random_values)), n_themes, replace = replace)

  vb <- vector("list", n_themes)
  for (i in seq_along(vb)) {
    theme <- themes[[i]]
    color <- get_theme_color(theme)

    vb[[i]] <- value_box(
      random_values$label[ridx[i]],
      random_values$value[ridx[i]],
      theme_color = themes[[i]],
      # class = "inverted",
      showcase = if (add_showcase) switch(
        sample(c("icon", "plot"), 1, prob = c(0.6, 0.4)),
        icon = bsicons::bs_icon(sample(bsicons:::icon_info$name, 1)),
        plot = random_plotly_plot(color = color)
      ),
      showcase_layout = if (sample(0:1, 1)) showcase_left_center() else showcase_top_right(max_height = "85px"),
      full_screen = TRUE
    )
  }

  vb
}


ui <- page_fluid(
  theme = bs_theme(preset = "shiny") |>
  # theme = bs_theme(version = 4) |>
    bs_add_variables(
      "bslib-value-box-enable-border" = "auto"
    ),
  class = "p-5",
  actionButton("refresh", "Shuffle stats and icons", class = "btn-secondary bg-gradient-pink-purple"),
  h2("Default", class = "mt-5 mb-3"),
  uiOutput("default"),
  h2("Default (No showcase)", class = "mt-5 mb-3"),
  uiOutput("default_plain"),
  h2("Theme colors", class = "mt-5 mb-3"),
  uiOutput("theme_colors"),
  h2("Theme colors (text)", class = "mt-5 mb-3"),
  uiOutput("theme_colors_text"),
  h2("Named colors", class = "mt-5 mb-3"),
  uiOutput("named_colors"),
  h2("Named colors (text)", class = "mt-5 mb-3"),
  uiOutput("named_colors_text"),
  h2("Gradient colors", class = "mt-5 mb-3"),
  uiOutput("gradient_colors")
)

server <- function(input, output, server) {
  # bs_themer()

  output$default <- renderUI({
    input$refresh
    layout_column_wrap(
      width = 1 / 4,
      fill = FALSE,
      !!!make_value_boxes(list(NULL, NULL, NULL, NULL))
    )
  })

  output$default_plain <- renderUI({
    input$refresh
    layout_column_wrap(
      width = 1 / 4,
      fill = FALSE,
      !!!make_value_boxes(list(NULL, NULL, NULL, NULL), add_showcase = FALSE)
    )
  })

  output$theme_colors <- renderUI({
    input$refresh
    layout_column_wrap(
      width = 1 / 4,
      fill = FALSE,
      !!!make_value_boxes(theme_colors)
    )
  })

  output$theme_colors_text <- renderUI({
    input$refresh
    layout_column_wrap(
      width = 1 / 4,
      fill = FALSE,
      !!!make_value_boxes(paste0("text-", theme_colors))
    )
  })

  output$named_colors <- renderUI({
    input$refresh
    layout_column_wrap(
      width = 1 / 4,
      fill = FALSE,
      !!!make_value_boxes(named_colors)
    )
  })

  output$named_colors_text <- renderUI({
    input$refresh
    layout_column_wrap(
      width = 1 / 4,
      fill = FALSE,
      !!!make_value_boxes(paste0("text-", named_colors))
    )
  })

  output$gradient_colors <- renderUI({
    input$refresh
    layout_column_wrap(
      width = 1 / 4,
      fill = FALSE,
      !!!make_value_boxes(gradient_classes)
    )
  })
}

shinyApp(ui, server)

Wide	Compact

[cpsievert]

LGTM once the remaining comments are addressed! 🚀

[cpsievert]

I was just playing around with the gradients, and was pretty surprised by this result

value_box(
    title = "Customer lifetime value",
    value = "$5,000",
    showcase = bsicons::bs_icon("bank2"),
    theme = "bg-gradient-teal-indigo"
)

Do we really want these percentages on the gradients?

https://github.com/rstudio/bslib/pull/758/files#diff-1b2fdaf1338331b67efc1180416859fa8027300513335cac78779ff782967405R45

[gadenbuie]

Do we really want these percentages on the gradients?

Yeah, I think these values tend to make better gradients that are interesting but not overpowering. Here it is with essentially 0% to 100% (not that this is bad either):

I do think it'd be completely reasonable to put CSS variables in front of those values though so they can be customized easily.

[gadenbuie]

Okay, I added CSS variables that make each of the orientation, start and end positions pick up on CSS variables, which could be used like this (or set globally on :root, or anywhere in the DOM really)

value_box(
  title = "Customer lifetime value",
  value = "$5,000",
  showcase = bsicons::bs_icon("bank2"),
  theme = "bg-gradient-teal-indigo",
  style = css(
    "--bg-gradient-deg" = "210deg",
    "--bg-gradient-start" = "10%",
    "--bg-gradient-end" = "90%"
  )
)

I initially adjusted the fallback and contrast-driving color to be an even mix of the two colors, since that's our best guess, but this degraded the appearance of the default case. Users can rely on the fg argument of value_box_theme() if needed.