Introduce CommandBar.shinyInput (#189)

* feat: introduce CommandBar.shinyInput * fix: docs typo * fix: documentation and package check notes * docs: combine CommandBar docs * docs: update CommandBarItem * feat: add tests for CommandBar * refactor: test cases titles * refactor: add comment to example code --------- Co-authored-by: Jakub Sobolewski <[email protected]>
Appsilon · Oct 2, 2023 · fe47c9f · fe47c9f
1 parent ed1c67e
commit fe47c9f
Show file tree

Hide file tree

Showing 11 changed files with 491 additions and 128 deletions.
diff --git a/.Rbuildignore b/.Rbuildignore
@@ -11,3 +11,4 @@
 ^data-raw$
 ^scrape-docs/
 ^vignettes/
+^.*\.sass_cache_keys
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -25,10 +25,11 @@ Depends:
 Imports:
   htmltools,
   jsonlite,
-  rlang,
+  purrr,
   shiny,
   shiny.react (>= 0.3.0)
 Suggests:
+  chromote,
   covr,
   dplyr,
   DT,
@@ -39,14 +40,14 @@ Suggests:
   leaflet,
   mockery,
   plotly,
-  purrr,
   rcmdcheck,
   RColorBrewer,
   rmarkdown,
   sass,
   shiny.i18n (>= 0.3.0),
   shiny.router (>= 0.3.1),
   shinyjs,
+  shinytest2,
   sortable,
   stringi,
   testthat (>= 3.0.0),

diff --git a/NAMESPACE b/NAMESPACE
@@ -19,6 +19,7 @@ export(ColorPicker.shinyInput)
 export(ComboBox)
 export(ComboBox.shinyInput)
 export(CommandBar)
+export(CommandBar.shinyInput)
 export(CommandBarButton)
 export(CommandBarButton.shinyInput)
 export(CommandBarItem)

diff --git a/R/extensions.R b/R/extensions.R
@@ -1,27 +1,69 @@
+setInputValue <- function(inputId, value, event = TRUE) {
+  fmt <- if (event) {
+    "() => Shiny.setInputValue('%s', %s, { priority: 'event' })"
+  } else {
+    "() => Shiny.setInputValue('%s', %s)"
+  }
+  JS(sprintf(fmt, inputId, if (!is.numeric(value)) sprintf("'%s'", value) else value))
+}
+
+commandBarItem <- "CommandBarItem"
+
+isCommandBarItem <- function(x) {
+  isTRUE(attr(x, "componentName") == commandBarItem)
+}
+
 #' Command bar item
 #'
-#' Helper function for constructing items for `CommandBar`.
-#'
-#' CommandBar expects items definition as a nested structure, which gets lengthy and verbose.
-#' This function helps makes this definition shorter. Returns a list with all arguments passed through,
-#' except for `text`, `icon` (which will inserted as proper `iconProps`) and `subitems` (which will be inserted as
-#' proper `subMenuProps`).
+#' Helper function for constructing items for `CommandBar` and `CommandBar.shinyInput`.
 #'
+#' @param key Key of the item.
 #' @param text Text to be displayed on the menu.
-#' @param icon Optional name of an icon.
-#' @param subitems Optional list of CommandBar items.
+#' @param onClick A JS function that runs on item click. By default it sends input value to `input[[key]]`.
+#'   If used within `CommandBar.shinyInput`, it will send the value to the input ID specified
+#'   in `inputId` argument of `CommandBar.shinyInput`.
 #' @param ... Additional props to pass to CommandBarItem.
-#' @return Item suitable for use in the CommandBar.
+#' @return Item suitable for use in the `CommandBar` and `CommandBar.shinyInput`.
 #'
 #' @seealso CommandBar
 #' @export
-CommandBarItem <- function(text, icon = NULL, subitems = NULL, ...) {
-  props <- rlang::dots_list(...)
+CommandBarItem <- function(
+  key,
+  text,
+  onClick = setInputValue(inputId = key, value = 0, event = TRUE),
+  ...
+) {
+  structure(
+    list(
+      key = key,
+      text = text,
+      onClick = onClick,
+      ...
+    ),
+    componentName = commandBarItem
+  )
+}
 
-  props$text <- text
-  if (is.character(icon)) props$iconProps <- list(iconName = icon)
-  if (!is.null(subitems)) props$subMenuProps <- list(items = subitems)
-  props
+#' CommandBar.shinyInput
+#'
+#' @param inputId ID of the component. Value of the clicked CommandBarItem will be sent to this ID.
+#' @param itemValueGetter A function that takes a CommandBarItem and returns a value to be sent to Shiny. By default it returns `key` of the item.
+#' @rdname CommandBar
+#'
+#' @export
+CommandBar.shinyInput <- function(
+  inputId,
+  ...,
+  itemValueGetter = function(el) el$key
+) {
+  attachOnClick <- function(el) {
+    el$onClick <- setInputValue(inputId, itemValueGetter(el))
+    el
+  }
+  args <- list(...)
+  args$items <- recursiveModify(args$items, attachOnClick, isCommandBarItem)
+  args$farItems <- recursiveModify(args$farItems, attachOnClick, isCommandBarItem)
+  do.call(CommandBar, args)
 }
 
 #' Basic Fluent UI page

diff --git a/R/utils.R b/R/utils.R
@@ -0,0 +1,12 @@
+recursiveModify <- function(x, modify = identity, when = function(x) TRUE) {
+  purrr::modify_tree(
+    x,
+    pre = function(el) {
+      if (!is.null(el) && when(el)) {
+        return(modify(el))
+      }
+      el
+    },
+    is_node = is.list
+  )
+}
diff --git a/inst/examples/CommandBar.R b/inst/examples/CommandBar.R
@@ -1,69 +1,91 @@
 library(shiny)
 library(shiny.fluent)
 
-items <- list(
+items <- function(ns) {
   list(
-    key = "newItem",
-    text = "New",
-    cacheKey = "myCacheKey",
-    iconProps = list(iconName = "Add"),
-    subMenuProps = list(
-      items = list(
-        list(
-          key = "emailMessage",
-          text = "Email message",
-          iconProps = list(iconName = "Mail")
-        ),
-        list(
-          key = "calendarEvent",
-          text = "Calendar event",
-          iconProps = list(iconName = "Calendar")
+    CommandBarItem(
+      key = ns("newItem"),
+      text = "New",
+      cacheKey = "myCacheKey",
+      split = TRUE,
+      iconProps = list(iconName = "Add"),
+      subMenuProps = list(
+        items = list(
+          CommandBarItem(
+            key = ns("emailMessage"),
+            text = "Email message",
+            iconProps = list(iconName = "Mail")
+          ),
+          CommandBarItem(
+            key = ns("calendarEvent"),
+            text = "Calendar event",
+            iconProps = list(iconName = "Calendar")
+          )
         )
       )
+    ),
+    CommandBarItem(
+      key = ns("upload"),
+      text = "Upload",
+      iconProps = list(iconName = "Upload")
+    ),
+    CommandBarItem(
+      key = ns("share"),
+      text = "Share",
+      iconProps = list(iconName = "Share")
+    ),
+    CommandBarItem(
+      key = ns("download"),
+      text = "Download",
+      iconProps = list(iconName = "Download")
     )
-  ),
-  list(
-    key = "upload",
-    text = "Upload",
-    iconProps = list(iconName = "Upload")
-  ),
-  list(
-    key = "share",
-    text = "Share",
-    iconProps = list(iconName = "Share")
-  ),
-  list(
-    key = "download",
-    text = "Download",
-    iconProps = list(iconName = "Download")
   )
-)
+}
 
-farItems <- list(
-  list(
-    key = "tile",
-    text = "Grid view",
-    ariaLabel = "Grid view",
-    iconOnly = TRUE,
-    iconProps = list(iconName = "Tiles")
-  ),
+farItems <- function(ns) {
   list(
-    key = "info",
-    text = "Info",
-    ariaLabel = "Info",
-    iconOnly = TRUE,
-    iconProps = list(iconName = "Info")
+    CommandBarItem(
+      key = ns("tile"),
+      text = "Grid view",
+      ariaLabel = "Grid view",
+      iconOnly = TRUE,
+      iconProps = list(iconName = "Tiles")
+    ),
+    CommandBarItem(
+      key = ns("info"),
+      text = "Info",
+      ariaLabel = "Info",
+      iconOnly = TRUE,
+      iconProps = list(iconName = "Info")
+    )
   )
-)
-
+}
 
 ui <- function(id) {
   ns <- NS(id)
-  CommandBar(items = items, farItems = farItems)
+  tagList(
+    CommandBar(
+      items = items(ns),
+      farItems = farItems(ns)
+    ),
+    textOutput(ns("commandBarItems")),
+    CommandBar.shinyInput(
+      inputId = ns("commandBar"),
+      items = items(identity),
+      farItems = farItems(identity)
+    ),
+    textOutput(ns("commandBar"))
+  )
 }
 
 server <- function(id) {
-  moduleServer(id, function(input, output, session) { })
+  moduleServer(id, function(input, output, session) {
+    commandBarItemClicked <- reactiveVal()
+    observeEvent(input$newItem, commandBarItemClicked("newItem clicked (explicitly observed)"))
+    observeEvent(input$upload, commandBarItemClicked("upload clicked (explicitly observed)"))
+    output$commandBarItems <- renderText(commandBarItemClicked())
+    output$commandBar <- renderText(input$commandBar)
+  })
 }
 
 if (interactive()) {