shinyWidgets::pickerInput not compatible with bslib

[Polkas]

shinyWidgets::pickerInput seems to not be compatible with bslib, please try out the example and different themes (especially default and colorful). Even for default bootstrap 5 the shinyWidgets::pickerInput ui is looking bad as have almost the same color as background (#f8f9fa vs rgba(0,0,0,0.03)). The ui for shinyWidgets::pickerInput is not updated properly, is it expected as e.g. it is not supported? Thanks.

Example (it is a quick and not precious update of the bslib::bs_theme_preview):

theme = bslib::bs_theme()
with_themer = TRUE
bslib:::assert_bs_theme(theme)
old_theme <- bslib:::bs_global_get()
bslib:::bs_global_set(theme)
library(shiny)
library(ggplot2)
library(bslib)
library(rlang)
library(curl)

# enlarged auto fonts
if (is_installed("thematic")) {
  thematic::thematic_shiny(
    font = thematic::font_spec("auto", scale = 2, update = TRUE)
  )
}


if ("3" %in% theme_version(theme)) {
  warning("This example app requires Bootstrap 4 or higher", call. = FALSE)
}

rounded <- isTRUE(as.logical(bs_get_variables(theme %||% bslib::bs_theme(), "enable-rounded")))
pill <- function(...) {
  shiny::tabPanel(..., class = "p-3 border", class = if (rounded) "rounded")
}
tab <- function(...) {
  shiny::tabPanel(..., class = "p-3 border border-top-0", class = if (rounded) "rounded-bottom")
}
gradient <- function(theme_color = "primary") {
  bg_color <- paste0("bg-", theme_color)
  bgg_color <- if ("4" %in% theme_version(theme)) {
    paste0("bg-gradient-", theme_color)
  } else {
    paste(bg_color, "bg-gradient")
  }
  bg_div <- function(color_class, ...) {
    display_classes <- paste(
      paste0(".", strsplit(color_class, "\\s+")[[1]]),
      collapse = " "
    )
    div(
      class = "p-3", class = color_class,
      display_classes, ...
    )
  }
  fluidRow(
    column(6, bg_div(bg_color)),
    column(6, bg_div(bgg_color))
  )
}

theme_colors <- c("primary", "secondary", "default", "success", "info", "warning", "danger", "dark")
gradients <- lapply(theme_colors, gradient)

progressBar <- div(
  class="progress",
  div(
    class="progress-bar w-25",
    role="progressbar",
    "aria-valuenow"="25",
    "aria-valuemin"="0",
    "aria-valuemax"="100"
  )
)

shinyApp(
  navbarPage(
    theme = theme,
    title = "Theme demo",
    collapsible = TRUE,
    id = "navbar",
    tabPanel(
      "Inputs",
      tabsetPanel(
        type = "pills", id = "inputs",
        pill(
          "inputPanel()",
          inputPanel(
            sliderInput("slider", "sliderInput()", min = 0, max = 100, value = c(30, 70), step = 20),
            selectInput("selectize", "selectizeInput()", choices = state.abb),
            selectInput("selectizeMulti", "selectizeInput(multiple=T)", choices = state.abb, multiple = TRUE),
            dateInput("date", "dateInput()", value = "2020-12-24"),
            dateRangeInput("dateRange", "dateRangeInput()", start = "2020-12-24", end = "2020-12-31"),
            shinyWidgets::pickerInput("selectize2", "pickerInput()", choices = state.abb)
          ),
          br(),
          textOutput("inputPanelOutputHeader"),
          verbatimTextOutput("inputPanelOutput"),
          br(),
          tags$p("Here are some", tags$code("actionButton()"), "s demonstrating different theme (i.e., accent) colors"),
          tags$div(
            class = "d-flex justify-content-center",
            actionButton("primary", "Primary", icon("product-hunt"), class = "btn-primary m-2"),
            actionButton("secondary", "Secondary (default)", class = "m-2"),
            actionButton("success", "Success", icon("check"), class = "btn-success m-2"),
            actionButton("info", "Info", icon("info"),  class = "btn-info m-2"),
            actionButton("warning", "warning", icon("exclamation"), class = "btn-warning m-2"),
            actionButton("danger", "Danger", icon("exclamation-triangle"), class = "btn-danger m-2"),
            actionButton("dark", "Dark", icon("moon"), class = "btn-dark m-2"),
            actionButton("light", "Light", icon("sun"), class = "btn-light m-2")
          )
        ),
        pill(
          "wellPanel()",
          wellPanel(
            fluidRow(
              column(
                6,
                selectInput("select", "selectInput()", choices = state.abb, selectize = FALSE),
                selectInput("selectMulti", "selectInput(multiple=T)", choices = state.abb, multiple = TRUE, selectize = FALSE),
                textInput("text", "textInput()", placeholder = "Enter some text"),
                numericInput("numeric", "numericInput()", value = 0),
                shinyWidgets::pickerInput("selectMulti2", "pickerInput()", choices = state.abb, multiple = TRUE)
              ),
              column(
                6,
                passwordInput("password", "passwordInput()", "secret"),
                textAreaInput("textArea", "textAreaInput()", placeholder = "A text area"),
                checkboxInput("check", "checkboxInput()", value = TRUE),
                checkboxGroupInput("checkGroup", "checkboxGroupInput()", choices = c("A", "B")),
                radioButtons("radioButtons", "radioButtons()", choices = c("A", "B"))
              )
            )
          ),
          br(),
          textOutput("wellPanelOutputHeader"),
          br(),
          verbatimTextOutput("wellPanelOutput")
        )
      )
    )
  ),
  function(input, output, session) {
    
    
    output$inputPanelOutputHeader <- renderText({
      "Below are the values bound to each input widget above"
    })
    
    output$inputPanelOutput <- renderPrint({
      str(list(
        sliderInput = input$slider,
        selectizeInput = input$selectize,
        selectizeMultiInput = input$selectizeMulti,
        dateInput = input$date,
        dateRangeInput = input$dateRange
      ))
    })
    
    output$wellPanelOutputHeader <- renderText({
      "Below are the values bound to each input widget above"
    })
    
    output$wellPanelOutput <- renderPrint({
      str(list(
        selectInput = input$select,
        selectMultiInput = input$selectMulti,
        textInput = input$text,
        numericInput = input$numeric,
        passwordInput = input$password,
        textAreaInput = input$textArea,
        checkInput = input$check,
        checkGroupInput = input$checkGroup,
        radioButtonsInput = input$radioButtons
      ))
    })
    
 
    fake_progress <- function(style = "notification") {
      withProgress(
        message = 'Calculation in progress',
        detail = 'This may take a while...',
        value = 0,
        style = style,
        {
          for (i in 1:15) {
            incProgress(1/15)
            Sys.sleep(0.25)
          }
        })
    }
    
    observeEvent(input$showProgress, {
      fake_progress()
      # TODO: old progress styling could be improved
      #fake_progress("old")
    })
    
    observeEvent(input$showProgress2, {
      p <- Progress$new()
      p$set(
        message = 'Calculation in progress',
        detail = 'This may take a while...',
        value = 0.5
      )
    })
    
    lapply(c("default", "message", "warning", "error"), function(x) {
      X <- tools::toTitleCase(x)
      observeEvent(input[[paste0("show", X)]], {
        showNotification(paste(X, "notification styling"), type = x)
      })
    })
    
    output$thematic_needed <- renderUI({
      if (bslib:::is_installed("thematic")) return(NULL)
      
      htmltools::HTML(
        "<span class=\"bg-warning\">&nbsp;!! Install the <a href='https://rstudio.github.io/thematic/'><code>thematic</code></a> package to enable auto-theming of static R plots !!&nbsp;</span>"
      )
    })
    
  }
) |>
  run_with_themer()

[pvictor]

pickerInput() is compatible with bslib afaik. pickerInput() have the appearance of a button with default class btn-light, that's why it is grey in your demo, you can use a different button's class with :

options = shinyWidgets::pickerOptions(style = "btn-outline-primary")

or btn-primary for plain background. Then styling pickerInput() will be the same as styling your primary button.

[Polkas]

Wow thank you for so quick answer, a legendary maintenance of the package. The suggestion is great as "btn-outline-secondary" or "btn-outline-light" are very close to what is offered by selectInput. However are not the same, comparing all 4 bootstrap versions is not easy NULL,3,4,5 (NULL is not perfectly identical to 3). What I could suggest is to think about the default setup for shinyWidgets::pickerInput, especially as bootstrap 5 will be a market standard with time. Once more thanks for your support.

[pvictor]

You're welcome. I agree that "btn-outline-secondary" will be a better default, I have to see how to use it only for BS5.

[Polkas]

I think the .renderHook could work well here https://github.com/dreamRs/shinyWidgets/blob/1b6cab48b1ea2c9338f94b43d089e4b580223d23/R/input-selectpicker.R#L96.

hmmm something like:

tags$select(dropNulls(options), .renderHook = function(res_tag) {
      theme <- bslib::bs_current_theme()
      bs_version <- if (bslib::is_bs_theme(theme)) {
        bslib::theme_version(theme)
       } else {
        "3"
      }
      if (bs_version == "3") {
        # sth 
        res_tag
      } else if (bs_version %in% c("4", "5")) {
        htmltools::tagAppendAttributes(res_tag, style = "btn-outline-secondary")
      } else {
        stop("Bootstrap 3, 4, and 5 are supported.")
      }
})

[Polkas]

The another solution could be sth like this, it could be unstable if sb call it before bs theme is known (outside fluidPage). However if run outside fluidPage then it will assume no additional action.

      theme <- bslib::bs_current_theme()
      bs_version <- if (bslib::is_bs_theme(theme)) {
        bslib::theme_version(theme)
       } else {
        "3"
      }
      if (bs_version != "3" && is.null(options[["style"]])) options[["style"]] <- "btn-outline-secondary"
      selectTag <- tag("select", dropNulls(options)) 

[pvictor]

Another solution could be to do it in JavaScript at widgets' initialization 🤔