Skip to content

Commit

Permalink
feat(build-a-box): Add example value box builder app (#790)
Browse files Browse the repository at this point in the history
  • Loading branch information
gadenbuie authored Sep 14, 2023
1 parent 7d7b6e9 commit 7c72c6d
Show file tree
Hide file tree
Showing 23 changed files with 1,289 additions and 12 deletions.
22 changes: 13 additions & 9 deletions .github/workflows/R-CMD-check.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -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):
Expand All @@ -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
10 changes: 8 additions & 2 deletions DESCRIPTION
Original file line number Diff line number Diff line change
Expand Up @@ -57,6 +57,8 @@ Remotes:
rstudio/htmltools
Config/Needs/deploy:
BH,
colourpicker,
commonmark,
cpp11,
dplyr,
DT,
Expand All @@ -65,6 +67,7 @@ Config/Needs/deploy:
gt,
hexbin,
histoslider,
htmlwidgets,
lattice,
leaflet,
lubridate,
Expand All @@ -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,
Expand Down
2 changes: 2 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
Binary file modified R/sysdata.rda
Binary file not shown.
11 changes: 11 additions & 0 deletions R/value-box.R
Original file line number Diff line number Diff line change
Expand Up @@ -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"}
Expand Down
34 changes: 34 additions & 0 deletions inst/examples/build-a-box/R/code_modal.R
Original file line number Diff line number Diff line change
@@ -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
)
)
}
37 changes: 37 additions & 0 deletions inst/examples/build-a-box/R/colors.R
Original file line number Diff line number Diff line change
@@ -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)
)
123 changes: 123 additions & 0 deletions inst/examples/build-a-box/R/mod-global-controls.R
Original file line number Diff line number Diff line change
@@ -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)
}
Loading

0 comments on commit 7c72c6d

Please sign in to comment.