feat(build-a-box): Add example value box builder app

.github/workflows/R-CMD-check.yaml

@@ -40,10 +40,6 @@ jobs:
       - name: Install bslib from GitHub
         shell: Rscript {0}
         run: |
-          # rsconnect 1.0 introduced an issue with deploying from CI
-          # Once a proper fix is CRAN, we can go back install.packages
-          if (!require('remotes')) install.packages('remotes')
-          remotes::install_version("rsconnect", "0.8.29")
           pak::pkg_install("rstudio/bslib", dependencies = TRUE, upgrade = TRUE)
 
       # Workaround for this (probably spurious error):
@@ -58,18 +54,26 @@ jobs:
         run: |
           install.packages("cpp11")
 
-      - name: Register account
+      - name: Register account(s)
         shell: Rscript {0}
         run: |
           rsconnect::setAccountInfo(
             name   = '${{ secrets.SHINYAPPS_NAME }}',
             token  = '${{ secrets.SHINYAPPS_TOKEN }}',
             secret = '${{ secrets.SHINYAPPS_SECRET }}'
           )
+          rsconnect::setAccountInfo(
+            name   = 'bslib',
+            token  = '${{ secrets.SHINYAPPS_BSLIB_TOKEN }}',
+            secret = '${{ secrets.SHINYAPPS_BSLIB_SECRET }}'
+          )
 
       - name: Deploy
+        shell: bash
         run: |
-          Rscript 'inst/themer-demo/deploy.R'
-          Rscript 'inst/examples/card/deploy.R'
-          Rscript 'inst/examples/value_box/deploy.R'
-          Rscript 'inst/examples/flights/deploy.R'
+          deployScripts=$(find inst -name "deploy.R" -type f)
+
+          for deployScript in $deployScripts; do
+            echo "Deploying $deployScript"
+            Rscript $deployScript
+          done

DESCRIPTION

@@ -57,6 +57,8 @@ Remotes:
     rstudio/htmltools
 Config/Needs/deploy: 
     BH,
+    colourpicker,
+    commonmark,
     cpp11,
     dplyr,
     DT,
@@ -65,6 +67,7 @@ Config/Needs/deploy:
     gt,
     hexbin,
     histoslider,
+    htmlwidgets,
     lattice,
     leaflet,
     lubridate,
@@ -75,9 +78,12 @@ Config/Needs/deploy:
     reshape2,
     rprojroot,
     rsconnect,
-    scales
+    rstudio/shiny,
+    scales,
+    styler,
+    tibble
 Config/Needs/routine: chromote, desc, renv
-Config/Needs/website: 
+Config/Needs/website:
     brio,
     crosstalk,
     dplyr,

NEWS.md

@@ -23,6 +23,8 @@
 
 * The `showcase_layout` argument of `value_box()` now accepts one of three character values: `"left center"`, `"top right"`, `"bottom"`. (#758)
 
+* A new [Build a Box app](https://bslib.shinyapps.io/build-a-box/) is now available online or via bslib. See `?value_box()` for details. The app helps preview a set of value boxes while you configure and customize their appearance and provides you with code to copy and paste into your app. (#790)
+
 * Added `input_dark_mode()`, a new input control that provides a toggle button that can be used to switch between the dark and light modes when using Bootstrap 5.3. By default, dark mode is applied automatically if the user's operating system is also in dark mode. App authors can toggle dark mode programmatically from the server using `toggle_dark_mode()`, and if you provide `input_dark_mode()` with an `id`, you can read the current color mode via the corresponding input value. (#787)
 
 ## Improvements

R/value-box.R

@@ -5,6 +5,17 @@
 #' `value` represents (for example, it could hold a [bsicons::bs_icon()], or
 #' even a [shiny::plotOutput()]).
 #'
+#' @section Build a Box App:
+#'
+#'   Explore all of the `value_box()` options and layouts interactively with the
+#'   [Build a Box app](https://bslib.shinyapps.io/build-a-box/), available
+#'   online thanks to [shinyapps.io](https://www.shinyapps.io/). Or, you can
+#'   run the app locally with:
+#'
+#'   ```r
+#'   shiny::runApp(system.file("examples", "build-a-box", package = "bslib"))
+#'   ```
+#'
 #' @section Themes:
 #'
 #'   ```{r child="man/fragments/value-box-themes.Rmd"}

inst/examples/build-a-box/R/code_modal.R

@@ -0,0 +1,34 @@
+code_modal <- function(code) {
+  if (rlang::is_call(code)) {
+    code <- rlang::expr_text(code)
+  }
+
+  if (requireNamespace("styler", quietly = TRUE)) {
+    code <- styler::style_text(code)
+  }
+
+  code <- paste(code, collapse = "\n")
+
+  showModal(
+    modalDialog(
+      HTML(sprintf(
+        '<pre><code id="value-box-code">%s</code></pre>',
+        code
+      )),
+      p(
+        id = "copy-clipboard-not-supported",
+        class = "text-muted d-none",
+        HTML("Press <kbd>Ctrl</kbd>/<kbd>Cmd</kbd> + <kbd>C</kbd> to copy the value box example code.")
+      ),
+      tags$button(
+        id = "copy-code-to-clipboard",
+        class = "btn btn-outline-primary",
+        onclick = "copyValueBoxCode()",
+        "Copy to clipboard"
+      ),
+      singleton(tags$script(src = "code-modal.js")),
+      footer = modalButton("Done"),
+      easyClose = TRUE
+    )
+  )
+}

inst/examples/build-a-box/R/colors.R

@@ -0,0 +1,37 @@
+theme_colors <- list(
+  "primary",
+  "secondary",
+  "success",
+  "danger",
+  "warning",
+  "info",
+  "light",
+  "dark"
+)
+
+named_colors <- c(
+  "blue",
+  "indigo",
+  "purple",
+  "pink",
+  "red",
+  "orange",
+  "yellow",
+  "green",
+  "teal",
+  "cyan"
+)
+
+gc <- expand.grid(named_colors, named_colors)
+gc <- gc[gc$Var1 != gc$Var2,]
+gradient_classes <- sprintf("bg-gradient-%s-%s", gc$Var1, gc$Var2)
+
+
+all_themes <- c(
+  "Default" = "",
+  theme_colors,
+  named_colors,
+  paste0("text-", theme_colors),
+  paste0("text-", named_colors),
+  sort(gradient_classes)
+)

inst/examples/build-a-box/R/mod-global-controls.R

@@ -0,0 +1,123 @@
+ui_global_controls <- function(id) {
+  ns <- shiny::NS(id)
+
+  tagList(
+    layout_columns(
+      class = "align-items-end",
+      selectizeInput(
+        ns("theme_style"),
+        "Theme style",
+        list(
+          "Default" = "default",
+          "All" = "all",
+          "Semantic Colors" = list(
+            "Semantic Background" = "semantic-bg",
+            "Semantic Text" = "semantic-fg"
+          ),
+          "Theme Colors" = list(
+            "Colored Background" = "colors-bg",
+            "Colored Text" = "colors-fg"
+          ),
+          "Vibrant" = list(
+            "Gradient Background" = "gradient"
+          )
+        )
+      ),
+      shuffleButton(ns("random_theme"), "Theme"),
+      shuffleButton(ns("random_stat"), "Stats")
+    ),
+    layout_columns(
+      class = "align-items-start",
+      div(
+        radioButtons(
+          ns("showcase_item"),
+          "Showcase Item",
+          choices = c("Plot", "Icon"),
+          inline = TRUE
+        ),
+        conditionalPanel(
+          "input.showcase_item == 'Plot'",
+          ns = ns,
+          p(
+            class = "text-muted",
+            "See",
+            tags$a(href = "https://rstudio.github.io/bslib/articles/value-boxes/index.html#expandable-sparklines", "Expandable Sparklines"),
+            "for example plot code."
+          )
+        ),
+        conditionalPanel(
+          "input.showcase_item == 'Icon'",
+          ns = ns,
+          shuffleButton(ns("random_icon"), "Icons")
+        )
+      ),
+      radioButtons(
+        ns("showcase_layout"),
+        "Showcase Layout",
+        choices = c("Left center", "Top right", "Bottom"),
+        inline = TRUE
+      )
+    )
+  )
+}
+
+server_global_controls <- function(input, output, sessions, one, two, three) {
+  observeEvent(c(input$random_theme, input$theme_style), {
+    new_values <- switch(
+      input$theme_style,
+      all = {
+        one$theme$shuffle()
+        two$theme$shuffle()
+        three$theme$shuffle()
+        NULL
+      },
+      default = {
+        one$theme$set("Default")
+        two$theme$set("Default")
+        three$theme$set("Default")
+        NULL
+      },
+      "semantic-bg" = sample(setdiff(theme_colors, c("light", "dark")), 3),
+      "semantic-fg" = paste0("text-", sample(setdiff(theme_colors, c("light", "dark")), 3)),
+      "colors-bg" = sample(named_colors, 3, replace = TRUE),
+      "colors-fg" = paste0("text-", sample(named_colors, 3, replace = TRUE)),
+      gradient = sample(gradient_classes, 3)
+    )
+
+    if (is.null(new_values)) return()
+
+    one$theme$set(new_values[[1]])
+    two$theme$set(new_values[[2]])
+    three$theme$set(new_values[[3]])
+  }, ignoreInit = TRUE)
+
+  observeEvent(input$random_stat, {
+    one$random_stat()
+    two$random_stat()
+    three$random_stat()
+  })
+
+  observeEvent(input$random_icon, {
+    one$showcase_icon$shuffle()
+    two$showcase_icon$shuffle()
+    three$showcase_icon$shuffle()
+  })
+
+  observeEvent(input$showcase_item, {
+    item <- tolower(input$showcase_item)
+    one$set_showcase_item(item)
+    two$set_showcase_item(item)
+    three$set_showcase_item(item)
+  }, ignoreInit = TRUE)
+
+  observeEvent(input$showcase_layout, {
+    layout <- tolower(input$showcase_layout)
+    one$set_showcase_layout(layout)
+    two$set_showcase_layout(layout)
+    three$set_showcase_layout(layout)
+  }, ignoreInit = TRUE)
+}
+
+module_global_controls <- function(id, one, two, three) {
+  callModule(server_global_controls, id, one = one, two = two, three = three)
+}