ci: Test formatting workflow

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

@@ -17,6 +17,8 @@ jobs:
     uses: rstudio/shiny-workflows/.github/workflows/website.yaml@v1
   routine:
     uses: rstudio/shiny-workflows/.github/workflows/routine.yaml@v1
+    with:
+      format-r-code: true
   R-CMD-check:
     uses: rstudio/shiny-workflows/.github/workflows/R-CMD-check.yaml@v1
   deploy:

R/accordion.R

@@ -70,8 +70,15 @@
 #'
 #' shinyApp(ui, server)
 #'
-accordion <- function(..., id = NULL, open = NULL, multiple = TRUE, class = NULL, width = NULL, height = NULL) {
-
+accordion <- function(
+  ...,
+  id = NULL,
+  open = NULL,
+  multiple = TRUE,
+  class = NULL,
+  width = NULL,
+  height = NULL
+) {
   args <- rlang::list2(...)
   argnames <- rlang::names2(args)
 
@@ -82,9 +89,13 @@ accordion <- function(..., id = NULL, open = NULL, multiple = TRUE, class = NULL
     open <- shiny::restoreInput(id = id, default = open)
   }
 
-  is_open <- vapply(children, function(x) {
-    isTRUE(open) || isTRUE(tagGetAttribute(x, "data-value") %in% open)
-  }, logical(1))
+  is_open <- vapply(
+    children,
+    function(x) {
+      isTRUE(open) || isTRUE(tagGetAttribute(x, "data-value") %in% open)
+    },
+    logical(1)
+  )
 
   if (!any(is_open) && !identical(open, FALSE)) {
     is_open[1] <- TRUE
@@ -103,12 +114,13 @@ accordion <- function(..., id = NULL, open = NULL, multiple = TRUE, class = NULL
   }
 
   children <- Map(
-    children, is_open,
+    children,
+    is_open,
     f = function(x, open) {
-
       if (!multiple) {
         x <- tagAppendAttributes(
-          x, "data-bs-parent" = paste0("#", id),
+          x,
+          "data-bs-parent" = paste0("#", id),
           .cssSelector = ".accordion-collapse"
         )
       }
@@ -117,7 +129,9 @@ accordion <- function(..., id = NULL, open = NULL, multiple = TRUE, class = NULL
       if (open) {
         tq <- tagQuery(x)
         tq$find(".accordion-collapse")$addClass("show")
-        tq$find(".accordion-button")$removeClass("collapsed")$removeAttrs("aria-expanded")$addAttrs("aria-expanded" = "true")
+        tq$find(".accordion-button")$removeClass("collapsed")$removeAttrs(
+          "aria-expanded"
+        )$addAttrs("aria-expanded" = "true")
         x <- tq$allTags()
       }
 
@@ -150,7 +164,6 @@ accordion <- function(..., id = NULL, open = NULL, multiple = TRUE, class = NULL
 #' @param icon A [htmltools::tag] child (e.g., [bsicons::bs_icon()]) which is positioned just before the `title`.
 #' @export
 accordion_panel <- function(title, ..., value = title, icon = NULL) {
-
   id <- paste0("bslib-accordion-panel-", p_randomInt(1000, 10000))
 
   btn <- tags$button(
@@ -205,7 +218,9 @@ accordion_panel <- function(title, ..., value = title, icon = NULL) {
 #' @export
 accordion_panel_set <- function(id, values, session = get_current_session()) {
   send_panel_message(
-    id, session, method = "set",
+    id,
+    session,
+    method = "set",
     values = if (isTRUE(values)) values else as.list(check_character(values))
   )
 }
@@ -214,7 +229,9 @@ accordion_panel_set <- function(id, values, session = get_current_session()) {
 #' @export
 accordion_panel_open <- function(id, values, session = get_current_session()) {
   send_panel_message(
-    id, session, method = "open",
+    id,
+    session,
+    method = "open",
     values = if (isTRUE(values)) values else as.list(check_character(values))
   )
 }
@@ -223,7 +240,9 @@ accordion_panel_open <- function(id, values, session = get_current_session()) {
 #' @export
 accordion_panel_close <- function(id, values, session = get_current_session()) {
   send_panel_message(
-    id, session, method = "close",
+    id,
+    session,
+    method = "close",
     values = if (isTRUE(values)) values else as.list(check_character(values))
   )
 }
@@ -237,10 +256,18 @@ accordion_panel_close <- function(id, values, session = get_current_session()) {
 #'
 #' @describeIn accordion_panel_set insert a new [accordion_panel()]
 #' @export
-accordion_panel_insert <- function(id, panel, target = NULL, position = c("after", "before"), session = get_current_session()) {
+accordion_panel_insert <- function(
+  id,
+  panel,
+  target = NULL,
+  position = c("after", "before"),
+  session = get_current_session()
+) {
   position <- match.arg(position)
   send_panel_message(
-    id, session, method = "insert",
+    id,
+    session,
+    method = "insert",
     panel = processDeps(panel, session),
     target = if (!is.null(target)) check_character(target, max_length = 1),
     position = position
@@ -249,24 +276,39 @@ accordion_panel_insert <- function(id, panel, target = NULL, position = c("after
 
 #' @describeIn accordion_panel_set remove [accordion_panel()]s.
 #' @export
-accordion_panel_remove <- function(id, target, session = get_current_session()) {
+accordion_panel_remove <- function(
+  id,
+  target,
+  session = get_current_session()
+) {
   send_panel_message(
-    id, session, method = "remove",
+    id,
+    session,
+    method = "remove",
     target = as.list(check_character(target))
   )
 }
 
-
 #' @describeIn accordion_panel_set update a [accordion_panel()].
 #' @param ... Elements that become the new content of the panel.
 #' @inheritParams accordion_panel
 #' @export
-accordion_panel_update <- function(id, target, ..., title = NULL, value = NULL, icon = NULL, session = get_current_session()) {
+accordion_panel_update <- function(
+  id,
+  target,
+  ...,
+  title = NULL,
+  value = NULL,
+  icon = NULL,
+  session = get_current_session()
+) {
   rlang::check_dots_unnamed()
   body <- rlang::list2(...)
 
   send_panel_message(
-    id, session, method = "update",
+    id,
+    session,
+    method = "update",
     target = check_character(target, max_length = 1),
     value = if (!is.null(value)) check_character(value, max_length = 1),
     body = if (length(body) == 0) NULL else processDeps(body, session),
@@ -275,7 +317,6 @@ accordion_panel_update <- function(id, target, ..., title = NULL, value = NULL,
   )
 }
 
-
 # Send message before the next flush since things like remove/insert may
 # remove/create input/output values. Also do this for set/open/close since,
 # you might want to open a panel after inserting it.
@@ -285,7 +326,12 @@ send_panel_message <- function(id, session, ...) {
   session$onFlush(callback, once = TRUE)
 }
 
-check_character <- function(x, max_length = Inf, min_length = 1, call = rlang::caller_env()) {
+check_character <- function(
+  x,
+  max_length = Inf,
+  min_length = 1,
+  call = rlang::caller_env()
+) {
   x_name <- deparse(substitute(x))
   if (!is.character(x)) {
     abort(

R/breakpoints.R

@@ -33,10 +33,13 @@ breakpoints <- function(..., xs = NULL, sm = NULL, md = NULL, lg = NULL) {
   }
 
   # Ensure that breakpoints are in the increasing order
-  break_nms <- sort(factor(
-    names(breaks), ordered = TRUE,
-    levels = unique(c(bs_breakpoints(), names(breaks)))
-  ))
+  break_nms <- sort(
+    factor(
+      names(breaks),
+      ordered = TRUE,
+      levels = unique(c(bs_breakpoints(), names(breaks)))
+    )
+  )
 
   structure(
     breaks[as.character(break_nms)],
@@ -54,16 +57,18 @@ print.bslib_breakpoints <- function(x, ...) {
   for (bp in names(x)) {
     vals <- format(x[[bp]], width = width_vals, justify = "right")
     cat(
-      " ", format(bp, width = width_nms, justify = "right"), ": ",
-      paste0(vals, collapse = " "), "\n",
+      " ",
+      format(bp, width = width_nms, justify = "right"),
+      ": ",
+      paste0(vals, collapse = " "),
+      "\n",
       sep = ""
     )
   }
 
   invisible(x)
 }
 
-
 is_breakpoints <- function(x) {
   inherits(x, "bslib_breakpoints")
 }

R/bs-dependencies.R

@@ -60,7 +60,6 @@ bs_theme_dependencies <- function(
   jquery = jquerylib::jquery_core(3),
   precompiled = get_precompiled_option("bslib.precompiled", default = TRUE)
 ) {
-
   theme <- as_bs_theme(theme)
   version <- theme_version(theme)
 
@@ -75,9 +74,10 @@ bs_theme_dependencies <- function(
   out_file <- NULL
   # Look for a precompiled css file if user asks for it AND the default options
   # are used.
-  if (precompiled &&
-      identical(sass_options, sass_options(output_style = "compressed")))
-  {
+  if (
+    precompiled &&
+      identical(sass_options, sass_options(output_style = "compressed"))
+  ) {
     precompiled_css <- precompiled_css_path(theme)
     if (!is.null(precompiled_css)) {
       out_dir <- file.path(tempdir(), paste0("bslib-precompiled-", version))
@@ -99,7 +99,6 @@ bs_theme_dependencies <- function(
 
   # If precompiled css not found, compile normally.
   if (is.null(out_file)) {
-
     contrast_warn <- get_shiny_devmode_option(
       "bslib.color_contrast_warnings",
       default = FALSE,
@@ -128,29 +127,38 @@ bs_theme_dependencies <- function(
 
   js_files <- bootstrap_javascript(version)
   js_map_files <- bootstrap_javascript_map(version)
-  success_js_files <- file.copy(c(js_files, js_map_files), out_file_dir, overwrite = TRUE)
+  success_js_files <- file.copy(
+    c(js_files, js_map_files),
+    out_file_dir,
+    overwrite = TRUE
+  )
   if (any(!success_js_files)) {
-    warning("Failed to copy over bootstrap's javascript files into the htmlDependency() directory.")
+    warning(
+      "Failed to copy over bootstrap's javascript files into the htmlDependency() directory."
+    )
   }
 
-  htmltools::resolveDependencies(c(
-    if (inherits(jquery, "html_dependency")) list(jquery) else jquery,
-    list(
-      htmlDependency(
-        name = "bootstrap",
-        version = get_exact_version(version),
-        src = out_file_dir,
-        stylesheet = basename(out_file),
-        script = basename(js_files),
-        all_files = TRUE, # include font and map files
-        meta = list(viewport = "width=device-width, initial-scale=1, shrink-to-fit=no")
-      )
-    ),
-    htmlDependencies(out_file)
-  ))
+  htmltools::resolveDependencies(
+    c(
+      if (inherits(jquery, "html_dependency")) list(jquery) else jquery,
+      list(
+        htmlDependency(
+          name = "bootstrap",
+          version = get_exact_version(version),
+          src = out_file_dir,
+          stylesheet = basename(out_file),
+          script = basename(js_files),
+          all_files = TRUE, # include font and map files
+          meta = list(
+            viewport = "width=device-width, initial-scale=1, shrink-to-fit=no"
+          )
+        )
+      ),
+      htmlDependencies(out_file)
+    )
+  )
 }
 
-
 #' Themeable HTML components
 #'
 #' @description
@@ -190,9 +198,15 @@ bs_theme_dependencies <- function(
 #'
 #' @family Bootstrap theme functions
 #' @export
-bs_dependency <- function(input = list(), theme, name, version,
-  cache_key_extra = NULL, .dep_args = list(), .sass_args = list())
-{
+bs_dependency <- function(
+  input = list(),
+  theme,
+  name,
+  version,
+  cache_key_extra = NULL,
+  .dep_args = list(),
+  .sass_args = list()
+) {
   sass_args <- c(
     list(
       rules = input,
@@ -221,19 +235,25 @@ bs_dependency <- function(input = list(), theme, name, version,
   }
 
   if ("package" %in% names(.dep_args)) {
-    warning("`package` won't have any effect since `src` must be an absolute path")
+    warning(
+      "`package` won't have any effect since `src` must be an absolute path"
+    )
   }
 
   script <- .dep_args[["script"]]
   if (length(script)) {
     if (basename(outfile) %in% basename(script)) {
-      stop("`script` file basename(s) must all be something other than ", basename(outfile))
+      stop(
+        "`script` file basename(s) must all be something other than ",
+        basename(outfile)
+      )
     }
     success <- file.copy(script, dirname(outfile), overwrite = TRUE)
     if (!all(success)) {
       stop(
         "Failed to copy the following script(s): ",
-        paste(script[!success], collapse = ", "), ".\n\n",
+        paste(script[!success], collapse = ", "),
+        ".\n\n",
         "Make sure script are absolute path(s)."
       )
     }
@@ -349,7 +369,9 @@ as_bs_theme <- function(theme) {
 
   # This is a historical artifact that should happen
   if (is_sass_bundle(theme) || inherits(theme, "sass_layer")) {
-    stop("`theme` cannot be a `sass_bundle()` or `sass_layer()` (use `bs_bundle()` to add a bundle)")
+    stop(
+      "`theme` cannot be a `sass_bundle()` or `sass_layer()` (use `bs_bundle()` to add a bundle)"
+    )
   }
 
   # NULL means default Bootstrap