R/extensions.R

In Appsilon/shiny.fluent: Microsoft Fluent UI for Shiny Apps

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` and `CommandBar.shinyInput`.
#'
#' @param key Key of the item.
#' @param text Text to be displayed on the menu.
#' @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` and `CommandBar.shinyInput`.
#'
#' @seealso CommandBar
#' @export
CommandBarItem <- function(
  key,
  text,
  onClick = setInputValue(inputId = key, value = 0, event = TRUE),
  ...
) {
  structure(
    list(
      key = key,
      text = text,
      onClick = onClick,
      ...
    ),
    componentName = commandBarItem
  )
}

#' 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
#'
#' Creates a Fluent UI page with sensible defaults (included Fabric CSS classes, proper class given
#' to the body tag, suppressed Bootstrap).
#'
#' The Bootstrap library is suppressed by default,
#' as it doesn't work well with Fluent UI in general.
#'
#' @param ... The contents of the document body.
#' @param suppressBootstrap Whether to suppress Bootstrap.
#' @return Object which can be passed as the UI of a Shiny app.
#'
#' @export
fluentPage <- function(..., suppressBootstrap = TRUE) {
  htmltools::tags$body(class = "ms-Fabric",
    if (suppressBootstrap) htmltools::suppressDependencies("bootstrap"),
    htmltools::htmlDependency(
      name = "office-ui-fabric-core",
      version = "11.0.0",
      src = list(href = "https://static2.sharepointonline.com/files/fabric/office-ui-fabric-core/11.0.0/css/"),
      stylesheet = "fabric.min.css"
    ),
    ...
  )
}

#' parseTheme
#'
#' Reads a theme JSON generated by Theme Designer: \url{https://fabricweb.z5.web.core.windows.net/pr-deploy-site/refs/heads/master/theming-designer/}
#' and parses it to an object digestable by \code{\link{ThemeProvider}}
#'
#' @param path A path to JSON file containing the theme created in Theme Designer
#' @param json A JSON string containing the theme created in Theme Designer
#' @return A list with Fluent theme that can be used in \code{\link{ThemeProvider}}
#'
#' @seealso [ThemeProvider()] for usage of this function
#' @export
parseTheme <- function(path = NULL, json = NULL) {
  if (is.null(path) && is.null(json)) stop("Provide 'path' or 'json' argument")
  if (!is.null(path) && !is.null(json)) stop("Only one 'path' or 'json' argument must be used'")
  if (!is.null(path)) {
    palette <- jsonlite::read_json(path, simplifyVector = TRUE)
  } else {
    palette <- jsonlite::parse_json(json, simplifyVector = TRUE)
  }
  list(
    palette = palette
  )
}