Possibility of user-defined custom toggles [enhancement]

[candidosobrinhosa]

Hello! Thanks for all the hard work!

I am currently hosting a web app reporting SARS in Brazil in two languages: English and Portuguese.

In order to swap between them, the user have to access radio buttons inside a dropdownmenu(notification) but a switch would look way better.

I wonder if there is a way to add a custom toggle, just like the "dark theme" and the new "help" toggles.

Best regards

[sactyr]

@candidosobrinhosa I am looking for the same and I managed to add a custom toggle using this code, but it looks fugly:

dashboardHeader(
    disable = FALSE
    ,rightUi = tags$li(
      class = "dropdown"
      ,prettySwitch(
          inputId = "test_toggle"
          ,label = NULL
          ,status = "primary"
          ,fill = TRUE
        )
        
    )
    
  )

It would be nice to include a native toggle switch just like the "dark" and "help" toggles. In the help for dashboardHeader it says rightUi and leftUi takes an element like dropdownMenu, but it would be good to know what other elements are possible here.

[sactyr]

ok so with my limited css knowledge I managed to align and make it a bit nicer, but prettySwitch is still a bit bigger than the other two toggles. If anyone knows how to scale it to the same size as other toggles that would be nice.

dashboardHeader(
    disable = FALSE
    ,rightUi = tags$li(
      class = "dropdown"
      ,prettySwitch(
          inputId = "test_toggle"
          ,label = NULL
          ,status = "primary"
          ,fill = TRUE
        ) %>% 
        tagAppendAttributes(
          class = "test_toggle_custom"
          ,style = "
          margin-bottom: 0; 
          margin-top: 0.5rem!important;
          margin-left: 0.5rem!important;
          margin-right: 0.5rem!important;
          width:32px" 
        )
    )
    
  )

[DivadNojnarg]

Hi,

I think you could leverage Bootstrap 4 power and use the custom switch component (the same I used in the header for the theme switch and help switch): https://getbootstrap.com/docs/4.2/components/forms/#switches

library(shiny)
library(bs4Dash)

switch_input <- function(inputId, label, checked = FALSE, disabled = FALSE) {
  div(
    class = "custom-control custom-switch",
    tags$input(
      id = inputId,
      type = "checkbox",
      disabled = if (disabled) NA,
      class = "custom-control-input"
    ),
    tags$label(
      label,
      `for` = inputId,
      class = "custom-control-label"
    )
  )
}

ui <- dashboardPage(
  header = dashboardHeader(
    title = dashboardBrand(
      title = "My dashboard",
      color = "primary",
      href = "https://adminlte.io/themes/v3",
      image = "https://adminlte.io/themes/v3/dist/img/AdminLTELogo.png"
    ),
    switch_input("plop", "Activate me!")
  ),
  sidebar = dashboardSidebar(),
  body = dashboardBody(),
  controlbar = dashboardControlbar(),
  title = "DashboardPage"
)

server <- function(input, output, session) {
  observe({
    print(input$plop)
  })
}

shinyApp(ui, server)

[sactyr]

@DivadNojnarg That is awesome thanks! I think the checked argument is not being called within the switch_input function, and I couldn't see from the Bootstrap 4 switches doco how it is being used.

Update: Just figured how to include the checked argument:

switch_input <- function(inputId, label, checked = FALSE, disabled = FALSE) {
  div(
    class = "custom-control custom-switch",
    tags$input(
      id = inputId,
      type = "checkbox",
      disabled = if (disabled) NA,
      checked = if (checked) NA,
      class = "custom-control-input"
    ),
    tags$label(
      label,
      `for` = inputId,
      class = "custom-control-label"
    )
  )
}

[sactyr]

I have generalised @DivadNojnarg's switch_input function to accept other types of custom control inputs from Bootstrap 4, such as checkbox and radio. These seems to only work for one input per type:

custom_control_input <- function(inputId, type = c("switch", "checkbox", "radio"), label, checked = FALSE, disabled = FALSE) {
  
  div(
    class = paste0("custom-control custom-", type),
    tags$input(
      id = inputId,
      type = ifelse(type == "switch", "checkbox", type),
      disabled = if (disabled) NA,
      checked = if (checked) NA,
      class = "custom-control-input"
    ),
    tags$label(
      label,
      `for` = inputId,
      class = "custom-control-label"
    )
  )
}

I did some digging and implemented a similar function for form check inputs that seems to accept multiple choice inputs per type. Useful if you want to use the same style of inputs throughout your bs4Dash app:

library(shiny)
library(bs4Dash)


form_check_input <- function(inputId, type = c("checkbox", "radio"), label, radio_name, checked, disabled, inline = FALSE) {
  
  if (length(unique(c(length(checked), length(disabled), length(label)))) == 1) {
    
    lapply(seq_along(label), function(x) {
      
      div(
        class = paste("form-check", if (inline) "form-check-inline")
        ,tags$input(
          class = "form-check-input"
          ,type = type
          ,name = ifelse(type == "radio", radio_name, NA) 
          ,id = paste0(inputId, x)
          ,disabled = if (disabled[x]) NA
          ,checked = if (checked[x]) NA
        )
        ,tags$label(
          class = "form-check-label"
          ,`for` = paste0(inputId, x)
          ,label[x]
        )
      )
      
    })
    
  } else {
    
    stop("Check lengths of label, checked and disabled are all same")
    
  }
  
}

ui <- dashboardPage(
  header = dashboardHeader(
    title = dashboardBrand(
      title = "My dashboard",
      color = "primary",
      href = "https://adminlte.io/themes/v3",
      image = "https://adminlte.io/themes/v3/dist/img/AdminLTELogo.png"
    )
  ),
  sidebar = dashboardSidebar(),
  body = dashboardBody(
    
    form_check_input(
      inputId = "plop"
      , type = "checkbox"
      , label = c("a","b")
      , radio_name = "testradio"
      , checked = c(TRUE, FALSE)
      , disabled = c(FALSE, FALSE)
      ,inline = TRUE
    )
    
  ),
  controlbar = dashboardControlbar(),
  title = "DashboardPage"
)

server <- function(input, output, session) {
  observe({
    print(
      c(input$plop1, input$plop2)
    )
  })

}